Commits

Yaron Minsky  committed ed3d6c5

refactored client into a few pieces

  • Participants
  • Parent commits 3452c3b

Comments (0)

Files changed (11)

 _build
 *.byte
 *.native
+a.out
 PKG async
 PKG core_extended
 PKG textutils
+PKG async_shell
 EXT nonrec
 FLG -w -4-33-40-41-42-43-34-44
+all: main.native
+
+FORCE:
+	true
+
+%.native %.byte %.cmo: FORCE
+	corebuild \
+	    -j 4 \
+	    -cflag -g \
+	    -cflags -w,-40,-w,-18 \
+	    -pkg core_extended,async,textutils,async_shell \
+	    $@
+
 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
-end
-
-let load_config () =
-  match Unix.getenv "HOME" with
-  | None -> failwith "no $HOME defined.  Can't open config"
-  | Some home ->
-    Reader.load_sexp (home ^/ ".screentime-monitor") Config.t_of_sexp
-    >>| function
-      | Error err ->
-        failwiths "Failed to load config file" err <:sexp_of<Error.t>>
-      | Ok config ->
-        config
-;;
-
-let get_username () =
-  let uid = Unix.getuid () in
-  Unix.Passwd.getbyuid uid
-  >>| function
-    | None -> failwith "Could not compute username"
-    | Some pwd -> Username.of_string pwd.Unix.Passwd.name
-;;
-
-let setup_conn username k =
-  load_config ()
-  >>= fun config ->
-  (match username with
-   | Some x -> return x
-   | None ->
-     match config.Config.user with
-     | Some x -> return x
-     | None -> get_username ())
-  >>= fun username ->
-  Common.with_rpc_conn
-    ~host:config.Config.server
-    ~port:Common.port
-    (fun conn -> k username conn)
-
-let username_spec = Command.Spec.Arg_type.create Username.of_string
-let category_spec = Command.Spec.Arg_type.create Category.of_string
-
-let shared_flags () =
-  Command.Spec.(
-    empty
-    +> flag "-username" (optional username_spec)
-         ~doc:"Username to act as"
-  )
-
-let days_flag () =
-  Command.Spec.(
-    flag "-days" (optional_with_default 4 int)
-      ~doc:"number of days the report should go back"
-  )
+open Client_common
 
 let start =
   Command.async_basic
     (fun username () -> setup_conn username (fun username conn ->
        Rpc.Rpc.dispatch_exn Protocol.stop conn username))
 
-let edit_file sexpable ~editor ~tempfile =
-  let rec loop () =
-    Unix.system_exn (String.concat [editor;" ";tempfile])
-    >>= fun () ->
-    With_format.load tempfile sexpable
-    >>= function
-    | Ok resp -> return (Some resp)
-    | Error e ->
-      printf "Failed to parse rule:\n%s\n"
-        (e |> Error.sexp_of_t |> Sexp.to_string_hum);
-      printf "Try again? (Y/n): ";
-      Reader.read_line (Lazy.force Reader.stdin)
-      >>= fun response ->
-      let reread =
-        match response with
-        | `Eof -> true
-        | `Ok s ->
-          match s |> String.lowercase |> String.strip with
-          | "n" | "no" -> false
-          | _ -> true
-      in
-      if not reread then (printf "Abandoning edit\n"; return None)
-      else loop ()
-  in
-  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
   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 |> 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 -> "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"
     (fun user () -> setup_conn user (fun user conn ->
        force clear_string
        >>= fun cstring ->
-       let stop = stop_on_term  () in
+       let stop = force on_term_signal in
        Clock.every' (sec 1.) ~stop (fun () ->
          Rpc.Rpc.dispatch_exn Protocol.status conn user
          >>| fun { Protocol.Status. state; elapsed } ->
       Deferred.unit
     ))
 
-let rules =
-  let show_rules =
-    Command.async_basic
-      ~summary:"Retrieve the screentime rules"
-      (shared_flags ())
-      (fun username () -> setup_conn username (fun username conn ->
-         Rpc.Rpc.dispatch_exn Protocol.get_rules conn username
-         >>| fun rules ->
-         printf "%s\n" (With_format.format rules)
-       ))
-  in
-  let edit_rules =
-    Command.async_basic
-      ~summary:"Set the screentime rule"
-      (shared_flags ())
-      (fun username () -> setup_conn username (fun username conn ->
-         Rpc.Rpc.dispatch_exn Protocol.get_rules conn username
-         >>= fun rule ->
-         let tempfile = Filename.temp_file "rule" ".scm" in
-         Writer.save tempfile ~contents:(With_format.format rule)
-         >>= fun () ->
-         let editor =
-           match Sys.getenv "EDITOR" with None -> "emacs" | Some x -> x
-         in
-         edit_file (module Rule.List) ~editor ~tempfile
-         >>= function
-         | None -> return ()
-         | Some rules ->
-           printf "Set the rules for %s? (y/N):" (Username.to_string username);
-           Reader.read_line (Lazy.force Reader.stdin)
-           >>= fun response ->
-           let upload =
-             match response with
-             | `Eof -> false
-             | `Ok s ->
-               match s |> String.lowercase |> String.strip with
-               | "y" | "yes" -> true
-               | _ -> false
-           in
-           if not upload then
-             (printf "Not setting rules.\n"; return ())
-           else
-             Rpc.Rpc.dispatch_exn Protocol.set_rules conn (username,rules)
-             >>| fun () ->
-             printf "Rules set\n"
-       ))
-  in
-  let rule_violations =
-    Command.async_basic
-      ~summary:"Get any rule violations"
-      (shared_flags ())
-      (fun username () -> setup_conn username (fun username conn ->
-         Rpc.Rpc.dispatch_exn Protocol.todays_violations conn username
-         >>| fun violations ->
-         violations
-         |> <:sexp_of<(Rule.t * Time.Span.t * Rule_store.Status.t) list>>
-         |> Sexp.to_string_hum
-         |> printf "%s\n"
-       ))
-  in
-  Command.group
-    ~summary:"Tools for interacting with screentime rules"
-    [ "show", show_rules
-    ; "edit", edit_rules
-    ; "violations", rule_violations
-    ; "monitor",   monitor_violations
-    ]
-
 let commands =
   [ "start"       , start
   ; "stop"        , stop
   ; "monitor"     , monitor
   ; "report"      , report
   ; "full-report" , full_report
-  ; "rules"       , rules
+  ; "rules"       , Rule_client.command
   ]
 
 

File client_common.ml

+open Core.Std
+open Async.Std
+
+module Config = struct
+  type t = { server: string
+           ; user: Username.t sexp_option
+           } 
+  with sexp
+end
+
+let load_config () =
+  match Unix.getenv "HOME" with
+  | None -> failwith "no $HOME defined.  Can't open config"
+  | Some home ->
+    Reader.load_sexp (home ^/ ".screentime-monitor") Config.t_of_sexp
+    >>| function
+    | Error err ->
+      failwiths "Failed to load config file" err <:sexp_of<Error.t>>
+    | Ok config ->
+      config
+;;
+
+let get_username () =
+  let uid = Unix.getuid () in
+  Unix.Passwd.getbyuid uid
+  >>| function
+  | None -> failwith "Could not compute username"
+  | Some pwd -> Username.of_string pwd.Unix.Passwd.name
+;;
+
+let setup_conn username k =
+  load_config ()
+  >>= fun config ->
+  (match username with
+   | Some x -> return x
+   | None ->
+     match config.Config.user with
+     | Some x -> return x
+     | None -> get_username ())
+  >>= fun username ->
+  Common.with_rpc_conn
+    ~host:config.Config.server
+    ~port:Common.port
+    (fun conn -> k username conn)
+
+let username_spec = Command.Spec.Arg_type.create Username.of_string
+let category_spec = Command.Spec.Arg_type.create Category.of_string
+
+let on_term_signal =
+  lazy (
+    let stop_ivar = Ivar.create () in
+    Signal.handle [Signal.term] ~f:(fun (_:Signal.t) ->
+        Ivar.fill stop_ivar ());
+    Ivar.read stop_ivar
+  )
+
+let shared_flags () =
+  Command.Spec.(
+    empty
+    +> flag "-username" (optional username_spec)
+      ~doc:"Username to act as"
+  )
+
+let days_flag () =
+  Command.Spec.(
+    flag "-days" (optional_with_default 4 int)
+      ~doc:"number of days the report should go back"
+  )
+
+let edit_file sexpable ~editor ~tempfile =
+  let rec loop () =
+    Unix.system_exn (String.concat [editor;" ";tempfile])
+    >>= fun () ->
+    With_format.load tempfile sexpable
+    >>= function
+    | Ok resp -> return (Some resp)
+    | Error e ->
+      printf "Failed to parse rule:\n%s\n"
+        (e |> Error.sexp_of_t |> Sexp.to_string_hum);
+      printf "Try again? (Y/n): ";
+      Reader.read_line (Lazy.force Reader.stdin)
+      >>= fun response ->
+      let reread =
+        match response with
+        | `Eof -> true
+        | `Ok s ->
+          match s |> String.lowercase |> String.strip with
+          | "n" | "no" -> false
+          | _ -> true
+      in
+      if not reread then (printf "Abandoning edit\n"; return None)
+      else loop ()
+  in
+  loop ()
+;;
+
+let shell_run cmd args =
+  In_thread.run(fun () ->
+      Core_extended.Shell.run_full cmd args)
+
+let clear_string =
+  lazy (shell_run "clear" [])
+

File client_common.mli

+open Core.Std
+open Async.Std
+
+module Config : sig
+  type t = { server: string
+           ; user: Username.t sexp_option
+           } 
+  with sexp
+end
+
+val load_config : unit -> Config.t Deferred.t
+val get_username : unit -> Username.t Deferred.t
+val setup_conn
+  :  Username.t option
+  -> (Username.t -> Rpc.Connection.t -> 'a Deferred.t)
+  -> 'a Deferred.t
+
+val username_spec : Username.t Command.Spec.Arg_type.t
+val category_spec : Category.t Command.Spec.Arg_type.t
+
+(** Returns a deferred which becomes determined when the term signal
+    is hit *)
+val on_term_signal : unit Deferred.t lazy_t
+val shared_flags : unit -> (Username.t option -> 'a, 'a) Command.Spec.t
+val days_flag : unit -> int Command.Spec.param
+val edit_file
+  : (module Core.Std.Sexpable with type t = 'a)
+  -> editor:string
+  -> tempfile:string
+  -> 'a With_format.t option Deferred.t
+
+val shell_run : string -> string list -> string Deferred.t
+val clear_string : string Deferred.t lazy_t
+open Core.Std
+open Async.Std
+
+let spawn ~title ?sound ?execute message =
+  Async_shell.run
+    "terminal-notifier"
+    ( [ "-message" ; message ]
+      @ [ "-title"; title ]
+      @ (match sound with
+          | None -> []
+          | Some sound ->
+            [ "-sound"; (match sound with `Default -> "default" | `Path x -> x) ])
+      @ (match execute with
+          | None -> []
+          | Some command -> [ "-execute";command ])
+    )
+
+open Core.Std
+open Async.Std
+
+val spawn  
+  :  title:string
+  -> ?sound:[`Default | `Path of string]
+  -> ?execute:string
+  -> string  (** the message to be sent *)
+  -> unit Deferred.t
+    

File rule_client.ml

+open Core.Std
+open Async.Std
+open Client_common
+
+let show_rules =
+  Command.async_basic
+    ~summary:"Retrieve the screentime rules"
+    (shared_flags ())
+    (fun username () -> setup_conn username (fun username conn ->
+         Rpc.Rpc.dispatch_exn Protocol.get_rules conn username
+         >>| fun rules ->
+         printf "%s\n" (With_format.format rules)
+       ))
+
+let edit_rules =
+  Command.async_basic
+    ~summary:"Set the screentime rule"
+    (shared_flags ())
+    (fun username () -> setup_conn username (fun username conn ->
+         Rpc.Rpc.dispatch_exn Protocol.get_rules conn username
+         >>= fun rule ->
+         let tempfile = Filename.temp_file "rule" ".scm" in
+         Writer.save tempfile ~contents:(With_format.format rule)
+         >>= fun () ->
+         let editor =
+           match Sys.getenv "EDITOR" with None -> "emacs" | Some x -> x
+         in
+         edit_file (module Rule.List) ~editor ~tempfile
+         >>= function
+         | None -> return ()
+         | Some rules ->
+           printf "Set the rules for %s? (y/N):" (Username.to_string username);
+           Reader.read_line (Lazy.force Reader.stdin)
+           >>= fun response ->
+           let upload =
+             match response with
+             | `Eof -> false
+             | `Ok s ->
+               match s |> String.lowercase |> String.strip with
+               | "y" | "yes" -> true
+               | _ -> false
+           in
+           if not upload then
+             (printf "Not setting rules.\n"; return ())
+           else
+             Rpc.Rpc.dispatch_exn Protocol.set_rules conn (username,rules)
+             >>| fun () ->
+             printf "Rules set\n"
+       ))
+
+let rule_violations =
+  Command.async_basic
+    ~summary:"Get any rule violations"
+    (shared_flags ())
+    (fun username () -> setup_conn username (fun username conn ->
+         Rpc.Rpc.dispatch_exn Protocol.todays_violations conn username
+         >>| fun violations ->
+         violations
+         |> <:sexp_of<(Rule.t * Time.Span.t * Rule_store.Status.t) list>>
+         |> Sexp.to_string_hum
+         |> 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 monitor_violations user conn ~stop =
+  Clock.every' (sec 10.) ~stop (fun () ->
+      Rpc.Rpc.dispatch_exn Protocol.todays_violations conn user
+      >>= fun violations -> 
+      print_violations violations
+      >>= fun () ->
+      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))
+            |> Deferred.ignore
+        ))
+;;
+
+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
+       ))
+
+let command =
+  Command.group
+    ~summary:"Tools for interacting with screentime rules"
+    [ "show", show_rules
+    ; "edit", edit_rules
+    ; "violations", rule_violations
+    ; "monitor",   monitor_violations
+    ]

File rule_client.mli

+open Core.Std
+open Async.Std
+
+val command : Command.t
 let get_rules t user =
   Rule_store.get_rules t.rules user
 
-let acknowledge _t (_user,_rule) =
-  assert false
+let acknowledge t (user,rule) =
+  Rule_store.ack t.rules user rule
 
 let implementations =
   let module P = Protocol in