Commits

Yaron Minsky committed c6749eb

rule monitoring linked into command line

  • Participants
  • Parent commits 39c382f

Comments (0)

Files changed (7)

 PKG core
 PKG async
 PKG core_extended
+PKG textutils
+
 open Core.Std
 open Async.Std
+module Shell = Core_extended.Std.Shell
 
 module Config = struct
   type t = { server: string
            ; user: Username.t sexp_option
-           } with sexp
+           } 
+  with sexp
 end
 
 let load_config () =
   loop ()
 ;;
 
+let shell_run cmd args =
+  In_thread.run(fun () ->
+      Core_extended.Shell.run_full cmd args)
+
+let clear_string =
+  lazy (shell_run "clear" [])
+
+let spinner =
+  let states = [| "|" ; "/"; "-"; "\\" |] in
+  let pos = ref 0 in
+  (fun () ->
+     pos := (!pos + 1) % Array.length states;
+     states.(!pos)
+  )
+
+let span_string span =
+  let { Time.Span.Parts.
+        sign = _
+      ; hr; min; sec
+      ; ms = _ ; us = _
+      } =
+    Time.Span.to_parts span
+  in
+  sprintf "%02d:%02d:%02d" hr min sec
+;;
+
+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)
+      ; Column.create "time"  (fun (_,s,_) -> Time.Span.to_string s)
+      ; Column.create "status" (fun (_,_,status) ->
+          match status with `Acked -> "X" | `Unacked -> " ")
+      ]
+    )
+  in
+  printf "%s\n" (Ascii_table.to_string ~display:Ascii_table.Display.line cols violations);
+  return ()
+;;
+
+let monitor_violations user conn ~stop =
+  Clock.every' (sec 10.) ~stop (fun () ->
+    Rpc.Rpc.dispatch_exn Protocol.todays_violations conn user
+    >>= print_violations
+  )
+;;
+
+let stop_on_term () =
+  let stop_ivar = Ivar.create () in
+  Signal.handle [Signal.term] ~f:(fun (_:Signal.t) ->
+      Ivar.fill stop_ivar ());
+  Ivar.read stop_ivar
+
+
+let monitor_violations =
+  Command.async_basic
+    ~summary:"Monitor for violations"
+    (shared_flags ())
+    (fun user () -> setup_conn user (fun user conn ->
+         let stop = stop_on_term () in
+         monitor_violations user conn ~stop;
+         stop
+       ))
+
+let monitor =
+  Command.async_basic
+    ~summary:"Monitor your time spent"
+    (shared_flags ())
+    (fun user () -> setup_conn user (fun user conn ->
+       force clear_string
+       >>= fun cstring ->
+       let stop = stop_on_term  () in
+       Clock.every' (sec 1.) ~stop (fun () ->
+         Rpc.Rpc.dispatch_exn Protocol.status conn user
+         >>| fun { Protocol.Status. state; elapsed } ->
+         let total_elapsed =
+           Map.data elapsed
+           |> List.fold ~init:Time.Span.zero ~f:Time.Span.(+)
+         in
+         printf "%s%s %s %s\n"
+           cstring
+           (spinner ())
+           (span_string total_elapsed)
+           (match state with
+            | `Active cat -> sprintf "{%s}" (Category.to_string cat)
+            | `Not_running -> "(paused)"
+           )
+       );
+       stop
+     ))
+
+module Ascii_table = Textutils.Ascii_table
+
+let report =
+  Command.async_basic
+    ~summary:"Print a report of time spent"
+    Command.Spec.(
+      shared_flags ()
+      +> days_flag ()
+    )
+    (fun user days () -> setup_conn user (fun user conn ->
+       Rpc.Rpc.dispatch_exn Protocol.report conn user
+       >>= fun report ->
+       let report =
+         Map.to_alist report
+         |> (fun l -> List.drop l (List.length l - days))
+       in
+       let categories =
+         List.map ~f:snd report
+         |> List.map ~f:Map.keys
+         |> List.concat
+         |> List.dedup
+       in
+       let open Ascii_table in
+       let date_column =
+         Column.create "date"
+           (fun (date,_) -> Date.to_string date)
+       in
+       let cat_columns =
+         List.map categories ~f:(fun cat ->
+           Column.create
+             (Category.to_string cat)
+             (fun (_date,by_cat) ->
+                match Map.find by_cat cat with
+                | None -> "-"
+                | Some span -> span_string span
+             ))
+       in
+       let total_column =
+         Column.create "total"
+           (fun (_date,by_cat) ->
+              Map.data by_cat
+              |> List.fold ~init:Time.Span.zero ~f:Time.Span.(+)
+              |> span_string
+           )
+       in
+       printf "%s\n"
+         (to_string
+            ~display:Display.column_titles
+            ([date_column]
+             @ (if List.length categories > 1 then cat_columns else [])
+             @ [total_column]
+            )
+            report);
+       return ()
+     ))
+
+let full_report =
+  Command.async_basic
+   ~summary:"Print a detailed report of all the screentime sessions"
+   Command.Spec.(
+     shared_flags ()
+     +> days_flag ()
+   )
+   (fun user days () -> setup_conn user (fun user conn ->
+      Rpc.Rpc.dispatch_exn Protocol.full_report conn user
+      >>= fun report ->
+      let open Ascii_table in
+      let ofday_string t =
+        Time.to_local_ofday t |> Time.Ofday.to_sec_string
+      in
+      let columns =
+        [ Column.create "category" (fun (c,_,_) -> Category.to_string c)
+        ; Column.create "start"    (fun (_,t,_) -> ofday_string t)
+        ; Column.create "stop"     (fun (_,_,t) -> ofday_string t)
+        ; Column.create "min"     (fun (_,start,stop) ->
+          Time.diff stop start
+          |> Time.Span.to_min
+          |> Float.to_int
+          |> Int.to_string)
+        ]
+      in
+      Map.to_alist report
+      |> (fun l -> List.drop l (List.length l - days))
+      |> List.iter ~f:(fun (date,sessions) ->
+        printf "*** Date: %s ***\n\n" (Date.to_string date);
+        printf "%s\n" (to_string
+                         ~display:Display.column_titles
+                         columns
+                         (List.rev sessions)));
+      Deferred.unit
+    ))
+
+
 let rules =
   let show_rules =
     Command.async_basic
     [ "show", show_rules
     ; "edit", edit_rules
     ; "violations", rule_violations
+    ; "monitor",   monitor_violations
     ]
 
-let clear_string () =
-  In_thread.run (fun () ->
-    Core_extended.Shell.run_full "clear" []
-  )
-
-let spinner =
-  let states = [| "|" ; "/"; "-"; "\\" |] in
-  let pos = ref 0 in
-  (fun () ->
-     pos := (!pos + 1) % Array.length states;
-     states.(!pos)
-  )
-
-let span_string span =
-  let { Time.Span.Parts.
-        sign = _
-      ; hr; min; sec
-      ; ms = _ ; us = _
-      } =
-    Time.Span.to_parts span
-  in
-  sprintf "%02d:%02d:%02d" hr min sec
-
-let monitor =
-  Command.async_basic
-    ~summary:"Monitor your time spent"
-    (shared_flags ())
-    (fun username () -> setup_conn username (fun username conn ->
-       let stop_ivar = Ivar.create () in
-       let stop = Ivar.read stop_ivar in
-       clear_string ()
-       >>= fun cstring ->
-       Signal.handle [Signal.term] ~f:(fun (_:Signal.t) ->
-         Ivar.fill stop_ivar ());
-       Clock.every' (sec 1.) ~stop (fun () ->
-         Rpc.Rpc.dispatch_exn Protocol.status conn username
-         >>| fun { Protocol.Status. state; elapsed } ->
-         let total_elapsed =
-           Map.data elapsed
-           |> List.fold ~init:Time.Span.zero ~f:Time.Span.(+)
-         in
-         printf "%s%s %s %s\n"
-           cstring
-           (spinner ())
-           (span_string total_elapsed)
-           (match state with
-            | `Active cat -> sprintf "{%s}" (Category.to_string cat)
-            | `Not_running -> "(paused)"
-           )
-       );
-       stop
-     ))
-
-module Ascii_table = Textutils.Ascii_table
-
-let report =
-  Command.async_basic
-    ~summary:"Print a report of time spent"
-    Command.Spec.(
-      shared_flags ()
-      +> days_flag ()
-    )
-    (fun username days () -> setup_conn username (fun username conn ->
-       Rpc.Rpc.dispatch_exn Protocol.report conn username
-       >>= fun report ->
-       let report =
-         Map.to_alist report
-         |> (fun l -> List.drop l (List.length l - days))
-       in
-       let categories =
-         List.map ~f:snd report
-         |> List.map ~f:Map.keys
-         |> List.concat
-         |> List.dedup
-       in
-       let open Ascii_table in
-       let date_column =
-         Column.create "date"
-           (fun (date,_) -> Date.to_string date)
-       in
-       let cat_columns =
-         List.map categories ~f:(fun cat ->
-           Column.create
-             (Category.to_string cat)
-             (fun (_date,by_cat) ->
-                match Map.find by_cat cat with
-                | None -> "-"
-                | Some span -> span_string span
-             ))
-       in
-       let total_column =
-         Column.create "total"
-           (fun (_date,by_cat) ->
-              Map.data by_cat
-              |> List.fold ~init:Time.Span.zero ~f:Time.Span.(+)
-              |> span_string
-           )
-       in
-       printf "%s\n"
-         (to_string
-            ~display:Display.column_titles
-            ([date_column]
-             @ (if List.length categories > 1 then cat_columns else [])
-             @ [total_column]
-            )
-            report);
-       return ()
-     ))
-
-let full_report =
-  Command.async_basic
-   ~summary:"Print a detailed report of all the screentime sessions"
-   Command.Spec.(
-     shared_flags ()
-     +> days_flag ()
-   )
-   (fun username days () -> setup_conn username (fun username conn ->
-      Rpc.Rpc.dispatch_exn Protocol.full_report conn username
-      >>= fun report ->
-      let open Ascii_table in
-      let ofday_string t =
-        Time.to_local_ofday t |> Time.Ofday.to_sec_string
-      in
-      let columns =
-        [ Column.create "category" (fun (c,_,_) -> Category.to_string c)
-        ; Column.create "start"    (fun (_,t,_) -> ofday_string t)
-        ; Column.create "stop"     (fun (_,_,t) -> ofday_string t)
-        ; Column.create "min"     (fun (_,start,stop) ->
-          Time.diff stop start
-          |> Time.Span.to_min
-          |> Float.to_int
-          |> Int.to_string)
-        ]
-      in
-      Map.to_alist report
-      |> (fun l -> List.drop l (List.length l - days))
-      |> List.iter ~f:(fun (date,sessions) ->
-        printf "*** Date: %s ***\n\n" (Date.to_string date);
-        printf "%s\n" (to_string
-                         ~display:Display.column_titles
-                         columns
-                         (List.rev sessions)));
-      Deferred.unit
-    ))
-
 let commands =
   [ "start"       , start
   ; "stop"        , stop
 
 
 
-(*
-let log =
-  simple ~summary:"Start logging time"
-    (fun username conn ->
-       Rpc.Rpc.dispatch_exn Protocol.start conn username
-       >>= fun () ->
-       let stop = Ivar.create () in
-       Signal.handle [Signal.term] ~f:(fun (_:Signal.t) ->
-         Ivar.fill stop ());
-       every (sec 0.5)
-    )
-*)

File protocol.mli

   with sexp, bin_io
 end
 
-val start    : (Username.t * Category.t,unit) Rpc.Rpc.t
-val stop     : (Username.t,unit) Rpc.Rpc.t
-val status   : (Username.t,Status.t) Rpc.Rpc.t
+val start    : (Username.t * Category.t, unit) Rpc.Rpc.t
+val stop     : (Username.t, unit) Rpc.Rpc.t
+val status   : (Username.t, Status.t) Rpc.Rpc.t
 val users    : (unit, Username.t list) Rpc.Rpc.t
-val shutdown : (unit,unit) Rpc.Rpc.t
+val shutdown : (unit, unit) Rpc.Rpc.t
 val report   :
   (Username.t,
    Time.Span.t Category.Map.t Date.Map.t)
     }
   with sexp, bin_io, compare, fields
 end
+include Sexpable.To_stringable(T)
 include T
 
 let check t daylogs =
             if not matches then acc
             else Time.Span.(+) acc span))
   in
-  let extra = Time.Span.(-) t.limit relevant_span in
-  if Time.Span.(>) extra Time.Span.zero then `Exceeded extra else `Ok
+  let excess = Time.Span.(relevant_span - t.limit) in
+  if Time.Span.(excess > Time.Span.zero) then `Exceeded excess else `Ok
 
 
 include Comparable.Make_binable(T)
   }
 with sexp, bin_io, fields
 include Comparable.S_binable with type t := t
+include Stringable with type t := t
 
 (** Returns the list of violations of the rule, where the time spans are the
     amount by which each scope is over the limit. *)
    ; P.set_rules         ++ set_rules
   ]
 
+
 let command =
   Command.async_basic
     ~summary:"Start the screen time server"
   return (List.map ~f:Username.of_string subdirs)
 
 let load_as_closed t user now =
-  let today = Time.to_local_date now in
   Sys.ls_dir (t.dir ^/ Username.to_string user)
   >>= fun dates ->
   (List.map ~f:Date.of_string dates