Commits

Yaron Minsky  committed 13b70da

reorganized violation code

  • Participants
  • Parent commits 62248aa

Comments (0)

Files changed (3)

File client_common.ml

 let clear_string =
   lazy (shell_run "clear" [])
 
+let clear_screen () =
+  force clear_string
+  >>| fun clear_string ->
+  print_endline clear_string

File client_common.mli

 
 val shell_run : string -> string list -> string Deferred.t
 val clear_string : string Deferred.t lazy_t
+val clear_screen : unit -> unit Deferred.t

File rule_client.ml

          |> printf "%s\n"
        ))
 
-let _print_violations violations =
-  let module Ascii_table = Textutils.Std.Ascii_table in
-  force clear_string
-  >>= fun clear_string ->
-  printf "%s" clear_string;
-  let cols = 
-    Ascii_table.(
-      [ Column.create "rule"  (fun (r,_,_) -> r.Rule.name |> Rule.Name.to_string)
-      ; Column.create "time"  (fun (_,s,_) -> Time.Span.to_string s)
-      ; Column.create "status" (fun (_,_,(status : Rule_store.Status.t)) ->
-          match status with Acked -> "Ack" | Unacked -> "-")
-      ]
-    )
-  in
-  printf "%s\n" (Ascii_table.to_string ~display:Ascii_table.Display.line cols violations);
-  return ()
-;;
-
 let violation_pipe user conn =
   let (r,w) = Pipe.create () in
   let stop = Pipe.closed r in
       else Pipe.write w violations);
   r
 
-let reportable_violations prev curr =
-  let to_map vs =
-    vs
-    |> List.map ~f:(fun (rule,x,y) -> (rule,(x,y)))
-    |> Rule.Map.of_alist_exn
-  in
-  Map.merge (to_map prev) (to_map curr)
-    ~f:(fun ~key:_ diff ->
-        match diff with
-        | `Left _ | `Right _ -> None
-        | `Both ((prev_span,_),(curr_span,status)) ->
-          match (status : Rule_store.Status.t) with
-          | Acked -> None
-          | Unacked ->
-            if Time.Span.(curr_span > prev_span)
-            then Some (curr_span,status)
-            else None
+module Full_violation = struct
+  type t =
+    { rule: Rule.t
+    ; status: Rule_store.Status.t
+    ; exceeded_by: Time.Span.t
+    ; reportable: bool
+    }
+
+  let print_list ts =
+    let module Ascii_table = Textutils.Std.Ascii_table in
+    let cols = 
+      Ascii_table.(
+        [ Column.create "rule"  (fun t -> t.rule.name |> Rule.Name.to_string)
+        ; Column.create "exceeded by" (fun t -> Time.Span.to_string t.exceeded_by)
+        ; Column.create "status" (fun t ->
+            match t.status with Acked -> "Ack" | Unacked -> "-")
+        ; Column.create "reportable" (fun t -> Bool.to_string t.reportable)
+        ]
       )
-  |> Map.to_alist
-  |> List.map ~f:(fun (x,(y,z)) -> (x,y,z))
+    in
+    printf "%s"
+      (Ascii_table.to_string ~display:Ascii_table.Display.line cols ts)
 
-let reportable_violation_pipe user conn =
-  let violations = violation_pipe user conn in
-  let (r,w) = Pipe.create () in
-  let rec loop prev =
-    Pipe.read violations
-    >>= function
-    | `Eof -> Pipe.close w; Deferred.unit
-    | `Ok curr -> 
-      if Pipe.is_closed w then Deferred.unit
-      else (Pipe.write w (reportable_violations prev curr)
-            >>= fun () -> loop curr)
-  in
-  don't_wait_for begin
-    Pipe.read violations 
-    >>= function
-    | `Eof -> Pipe.close w; Deferred.unit
-    | `Ok first -> loop first
-  end;
-  r
+  let create_unreportable (rule,exceeded_by,status) =
+    { rule; exceeded_by; status; reportable = false }
+
+  let create ~prev ~curr =
+    let to_map vs =
+      vs
+      |> List.map ~f:(fun (rule,x,y) -> (rule,(x,y)))
+      |> Rule.Map.of_alist_exn
+    in
+    Map.merge (to_map prev) (to_map curr)
+      ~f:(fun ~key:rule diff ->
+          match diff with
+          | `Left _  -> None
+          | `Right (exceeded_by,status) ->
+            Some {rule;exceeded_by;status;reportable=false}
+          | `Both ((prev_span,_),(curr_span,status)) ->
+            let reportable = 
+              match (status : Rule_store.Status.t) with
+              | Acked ->  false
+              | Unacked -> Time.Span.(curr_span > prev_span)
+            in
+            let exceeded_by = curr_span in
+            Some {rule;status;exceeded_by;reportable}
+        )
+    |> Map.data
+
+  let get_pipe user conn =
+    let violations = violation_pipe user conn in
+    let (r,w) = Pipe.create () in
+    let rec loop prev =
+      Pipe.read violations
+      >>= function
+      | `Eof -> Pipe.close w; Deferred.unit
+      | `Ok curr -> 
+        if Pipe.is_closed w then Deferred.unit
+        else (
+          Pipe.write w (create ~prev ~curr)
+          >>= fun () -> loop curr
+        )
+    in
+    don't_wait_for begin
+      Pipe.read violations 
+      >>= function
+      | `Eof -> Pipe.close w; Deferred.unit
+      | `Ok first -> 
+        Pipe.write w (List.map ~f:create_unreportable first)
+        >>= fun () ->
+        loop first
+    end;
+    r
+end
 
 let monitor_violations user conn ~stop =
-  let r = reportable_violation_pipe user conn in
+  let r = Full_violation.get_pipe user conn in
   upon stop (fun () -> Pipe.close_read r);
   Pipe.iter r ~f:(fun violations ->
-      Deferred.List.iter violations ~f:(fun (rule,exceeded_by,status) ->
-          match (status : Rule_store.Status.t) with
-          | Acked -> Deferred.unit
-          | Unacked ->
-            Notify.spawn
-              ~title:"Screentime exceeded"
-              ~sound:`Default
-              (sprintf "\"%s\" exceeded by %s"
-                 (Rule.Name.to_string rule.Rule.name)
-                 (Time.Span.to_string exceeded_by))
-        ))
-  |> don't_wait_for
+      clear_screen ()
+      >>= fun () ->
+      Full_violation.print_list violations;
+      Deferred.List.iter violations
+        ~f:(fun {Full_violation. rule;exceeded_by;status=_;reportable} ->
+            if not reportable then Deferred.unit
+            else
+              Notify.spawn
+                ~title:"Screentime exceeded"
+                ~sound:`Default
+                ~execute:"true"
+                (sprintf "'%s' exceeded by %s"
+                   (Rule.Name.to_string rule.Rule.name)
+                   (Time.Span.to_string exceeded_by))
+          ))
 
 let monitor_violations =
   Command.async_basic
     ~summary:"Monitor for violations"
     (shared_flags ())
     (fun user () -> setup_conn user (fun user conn ->
-         let stop = force on_term_signal in
-         monitor_violations user conn ~stop;
-         stop
+         monitor_violations user conn ~stop:(force on_term_signal)))
+
+let ack =
+  Command.async_basic
+    ~summary:"Acknowledge a rule, and prevent futher warnings"
+    Command.Spec.(
+      shared_flags ()
+      +> anon ("rule" %: Arg_type.create Rule.Name.of_string)
+    )
+    (fun user rule () -> setup_conn user (fun user conn ->
+         Rpc.Rpc.dispatch_exn Protocol.acknowledge conn (user,rule)
        ))
 
 let command =
   Command.group
     ~summary:"Tools for interacting with screentime rules"
-    [ "show", show_rules
-    ; "edit", edit_rules
-    ; "violations", rule_violations
-    ; "monitor",   monitor_violations
+    [ "show"       , show_rules
+    ; "edit"       , edit_rules
+    ; "violations" , rule_violations
+    ; "monitor"    , monitor_violations
+    ; "ack"        , ack
     ]