Commits

Yaron Minsky committed 1542c7c

improved editing a bit

Comments (0)

Files changed (9)

 PKG async
 PKG core_extended
 PKG textutils
-
+EXT nonrec
+FLG -w -4-33-40-41-42-43-34-44
     (fun username () -> setup_conn username (fun username conn ->
        Rpc.Rpc.dispatch_exn Protocol.stop conn username))
 
-let edit_file of_sexp ~editor ~tempfile =
+let edit_file sexpable ~editor ~tempfile =
   let rec loop () =
     Unix.system_exn (String.concat [editor;" ";tempfile])
     >>= fun () ->
-    Reader.load_sexp tempfile of_sexp
+    With_format.load tempfile sexpable
     >>= function
     | Ok resp -> return (Some resp)
     | Error e ->
       printf "Failed to parse rule:\n%s\n"
-        (Error.sexp_of_t e |> Sexp.to_string_hum);
+        (e |> Error.sexp_of_t |> Sexp.to_string_hum);
       printf "Try again? (Y/n): ";
       Reader.read_line (Lazy.force Reader.stdin)
       >>= fun response ->
   printf "%s" clear_string;
   let cols = 
     Ascii_table.(
-      [ Column.create "rule"  (fun (r,_,_) -> r.Rule.name)
+      [ 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) ->
-          match status with `Acked -> "X" | `Unacked -> " ")
+      ; Column.create "status" (fun (_,_,(status : Rule_store.Status.t)) ->
+          match status with Acked -> "X" | Unacked -> " ")
       ]
     )
   in
       Deferred.unit
     ))
 
-
 let rules =
   let show_rules =
     Command.async_basic
       (shared_flags ())
       (fun username () -> setup_conn username (fun username conn ->
          Rpc.Rpc.dispatch_exn Protocol.get_rules conn username
-         >>| fun rule ->
-         printf "%s\n" (rule |> Rule.Set.sexp_of_t |> Sexp.to_string_hum)
+         >>| fun rules ->
+         printf "%s\n" (With_format.format rules)
        ))
   in
   let edit_rules =
          Rpc.Rpc.dispatch_exn Protocol.get_rules conn username
          >>= fun rule ->
          let tempfile = Filename.temp_file "rule" ".scm" in
-         Writer.save_sexp tempfile (Rule.Set.sexp_of_t rule)
+         Writer.save tempfile ~contents:(With_format.format rule)
          >>= fun () ->
          let editor =
            match Sys.getenv "EDITOR" with None -> "emacs" | Some x -> x
          in
-         edit_file Rule.Set.t_of_sexp ~editor ~tempfile
+         edit_file (module Rule.List) ~editor ~tempfile
          >>= function
          | None -> return ()
          | Some rules ->
          Rpc.Rpc.dispatch_exn Protocol.todays_violations conn username
          >>| fun violations ->
          violations
-         |> <:sexp_of<(Rule.t * Time.Span.t * [`Acked | `Unacked]) list>>
+         |> <:sexp_of<(Rule.t * Time.Span.t * Rule_store.Status.t) list>>
          |> Sexp.to_string_hum
          |> printf "%s\n"
        ))
 
 let todays_violations =
   let module R = struct
-    type t = (Rule.t * Time.Span.t * [`Acked | `Unacked]) list with bin_io
+    type t = (Rule.t * Time.Span.t * Rule_store.Status.t) list with bin_io
   end in
   Rpc.Rpc.create
     ~name:"todays-violations"
-    ~version:1
+    ~version:2
     ~bin_query:Username.bin_t
     ~bin_response:R.bin_t
 
 let get_rules =
   let module R = struct
-    type t = Rule.Set.t with bin_io
+    type t = Rule.t list With_format.t with bin_io
   end in
   Rpc.Rpc.create
     ~name:"get-rule"
-    ~version:0
+    ~version:1
     ~bin_query:Username.bin_t
     ~bin_response:R.bin_t
 
 let set_rules =
   let module Q = struct
-    type t = Username.t * Rule.Set.t with bin_io
+    type t = Username.t * Rule.t list With_format.t with bin_io
   end in
   Rpc.Rpc.create
     ~name:"set-rule"
-    ~version:1
+    ~version:2
     ~bin_query:Q.bin_t
     ~bin_response:Unit.bin_t
 
 let acknowledge =
   let module Q = struct
-    type t = Username.t * Rule.t with bin_io
+    type t = Username.t * Rule.Name.t with bin_io
   end in
   Rpc.Rpc.create
     ~name:"acknowledge"
-    ~version:0
+    ~version:1
     ~bin_query:Q.bin_t
     ~bin_response:Unit.bin_t
     Rpc.Rpc.t
 val todays_violations :
   (Username.t,
-   (Rule.t * Time.Span.t * [ `Acked | `Unacked]) list)
+   (Rule.t * Time.Span.t * Rule_store.Status.t) list)
     Rpc.Rpc.t
-val get_rules : (Username.t, Rule.Set.t) Rpc.Rpc.t
-val set_rules : (Username.t * Rule.Set.t, unit) Rpc.Rpc.t
-val acknowledge : (Username.t * Rule.t, unit) Rpc.Rpc.t
+val get_rules : (Username.t, Rule.t list With_format.t) Rpc.Rpc.t
+val set_rules : (Username.t * Rule.t list With_format.t, unit) Rpc.Rpc.t
+val acknowledge : (Username.t * Rule.Name.t, unit) Rpc.Rpc.t
 open Core.Std
 
+module Name : Identifiable = String
+
 module T = struct
   type t =
-    { days       : Day_of_week.t list
+    { name       : Name.t
+    ; days       : Day_of_week.t list
     ; categories : Category.t Blang.t
     ; limit      : Time.Span.t
-    ; name       : string
     }
   with sexp, bin_io, compare, fields
 end
 include Sexpable.To_stringable(T)
 include T
 
-let check t daylogs =
+let check (t:t) daylogs =
   let relevant_span =
     let days = Day_of_week.Set.of_list t.days in
     List.fold daylogs ~init:Time.Span.zero ~f:(fun acc (date,daylog) ->
   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)
 
-include Comparable.Make_binable(T)
+module List = struct
+  type nonrec t = t list with sexp, bin_io
+
+  let t_of_sexp sexp =
+    let rules = t_of_sexp sexp in
+    let names = List.map rules ~f:(fun r -> r.name) in
+    match List.find_a_dup names with
+    | Some dup -> of_sexp_error ("Duplicate name found :" ^ Name.to_string dup) sexp
+    | None -> rules
+end
+
 open Core.Std
 
+module Name : Identifiable
+
 type t =
-  { days       : Day_of_week.t list
+  { name       : Name.t
+  ; days       : Day_of_week.t list
   ; categories : Category.t Blang.t
   ; limit      : Time.Span.t
-  ; name       : string
   }
 with sexp, bin_io, fields
 include Comparable.S_binable with type t := t
   -> [ `Ok | `Exceeded of Time.Span.t ]
 
 
+module List : sig
+  type nonrec t = t list with sexp, bin_io
+end
 
 
 type t = { dir: string }
 
-module Ruleset = struct
-  type t = [ `Acked | `Unacked ] Rule.Map.t
+module Status = struct
+  type t = Acked | Unacked with sexp, bin_io
+end
+
+module For_user = struct
+  type t = { acked: Rule.Name.Set.t
+           ; rules: Rule.t list With_format.t
+           }
   with sexp, bin_io
 end
 
-
 let create ~dir =
   let open Deferred.Or_error.Monad_infix in
   return (Ok { dir })
 let fname t user =
   t.dir ^/ Username.to_string user
 
-let get t user =
-  Common.load_file Ruleset.t_of_sexp
-    ~default:(fun () -> Rule.Map.empty)
+let load t user =
+  Common.load_file
+    For_user.t_of_sexp
+    ~default:(fun () ->
+        { For_user.
+          acked = Rule.Name.Set.empty
+        ; rules = With_format.create (module Rule.List) []
+        })
     (fname t user)
 
-let set t user ruleset =
+let save t user ruleset =
   let fname = fname t user in
   Common.ensure_dirname_exists ~fname
   >>= fun () ->
-  Writer.save_sexp fname (Ruleset.sexp_of_t ruleset)
+  Writer.save_sexp fname (For_user.sexp_of_t ruleset)
 
-let ack t user rule =
-  get t user
-  >>= fun ruleset ->
-  set t user (Map.add ruleset ~key:rule ~data:`Acked)
+let ack t user rule_name =
+  load t user
+  >>= fun for_user ->
+  save t user 
+    { for_user with acked = Set.add for_user.acked rule_name }
 
-let unack t user rule =
-  get t user
-  >>=  fun ruleset ->
-  set t user (Map.add ruleset ~key:rule ~data:`Unacked)
+let unack t user rule_name =
+  load t user
+  >>=  fun for_user ->
+  save t user 
+    { for_user with acked = Set.remove for_user.acked rule_name }
 
 let set_rules t user new_rules =
-  get t user
-  >>= fun old_ruleset ->
-  let merged_ruleset =
-    Set.to_list new_rules
-    |> List.map ~f:(fun rule -> (rule, `Unacked))
-    |> Rule.Map.of_alist_exn
-    |> (fun new_ruleset ->
-      Map.merge old_ruleset new_ruleset
-        ~f:(fun ~key:_ -> function
-          | `Left  _     -> None
-          | `Right x     -> Some x
-          | `Both (x, _) -> Some x
-        ))
-  in
-  set t user merged_ruleset
+  load t user
+  >>= fun for_user ->
+  save t user { for_user with rules = new_rules }
 
 let get_rules t user =
-  get t user
-  >>| fun ruleset ->
-  Map.keys ruleset |> Rule.Set.of_list
+  load t user
+  >>| fun for_user ->
+  for_user.rules
 
-let clear_acks_on_other_rules t user rules_to_keep =
-  get t user
-  >>= fun ruleset ->
-  let ruleset' =
-    Map.mapi ruleset ~f:(fun ~key:rule ~data:ack_state ->
-      if not (Set.mem rules_to_keep rule)
-      then `Unacked
-      else ack_state)
-  in
-  set t user ruleset'
+let get_rules_with_status t user =
+  load t user
+  >>| fun for_user ->
+  List.map (With_format.get for_user.rules) ~f:(fun rule ->
+      (rule, if Set.mem for_user.acked rule.name then Status.Acked else Unacked))
 
+let clear_acks_on_other_rules t user to_keep =
+  load t user
+  >>= fun for_user ->
+  save t user (
+    let to_keep = Rule.Name.Set.of_list to_keep in
+    let acked = Set.diff for_user.acked (Set.diff for_user.acked to_keep) in
+    { for_user with acked }
+  )
 
+
 
 type t
 
+module Status : sig
+  type t = Acked | Unacked with sexp, bin_io
+end
+
 val create : dir:string -> t Deferred.Or_error.t
 
-val get
-  :  t -> Username.t
-  -> [`Acked | `Unacked] Rule.Map.t Deferred.t
+val get_rules_with_status
+  : t -> Username.t -> (Rule.t * Status.t) list Deferred.t
 
-val set
+(* Sets the set of rules, inheriting ack-states from the existing ruleset *)
+val set_rules
   :  t
   -> Username.t
-  -> [`Acked | `Unacked] Rule.Map.t
+  -> Rule.t list With_format.t
   -> unit Deferred.t
 
-(* Sets the set of rules, inheriting ack-states from the existing ruleset *)
-val set_rules : t -> Username.t -> Rule.Set.t -> unit Deferred.t
-val get_rules : t -> Username.t -> Rule.Set.t Deferred.t
+val get_rules
+  :  t
+  -> Username.t
+  -> Rule.t list With_format.t Deferred.t
 
-val ack   : t -> Username.t -> Rule.t -> unit Deferred.t
-val unack : t -> Username.t -> Rule.t -> unit Deferred.t
+val ack   : t -> Username.t -> Rule.Name.t -> unit Deferred.t
+val unack : t -> Username.t -> Rule.Name.t -> unit Deferred.t
 
+(** Clears acks on rules other than the ones provided.  Used to clear
+    acks on rules that are not in violation. *)
 val clear_acks_on_other_rules
-  : t -> Username.t -> Rule.Set.t -> unit Deferred.t
+  : t -> Username.t -> Rule.Name.t list -> unit Deferred.t
     >>| fun daylog ->
     (date,Daylog.close daylog date ~now))
   >>= fun daylogs ->
-  Rule_store.get t.rules user
-  >>= fun rulemap ->
+  Rule_store.get_rules_with_status t.rules user
+  >>= fun rules_with_status ->
   let violations =
-    Map.to_alist rulemap
-    |> List.filter_map ~f:(fun (rule,acked) ->
+    List.filter_map rules_with_status ~f:(fun (rule,status) ->
       match Rule.check rule daylogs with
       | `Ok -> None
-      | `Exceeded by -> Some (rule,by,acked))
+      | `Exceeded by -> Some (rule,by,status))
   in
-  let violated_rules =
-    List.map ~f:(fun (x,_,_) -> x) violations
-    |> Rule.Set.of_list
-  in
+  let violated_rules = List.map violations ~f:(fun (r,_,_) -> r.name) in
   Rule_store.clear_acks_on_other_rules t.rules user violated_rules
   >>| fun () ->
   violations
 let get_rules t user =
   Rule_store.get_rules t.rules user
 
+let acknowledge _t (_user,_rule) =
+  assert false
+
 let implementations =
   let module P = Protocol in
   let (++) = Rpc.Rpc.implement in
    ; P.todays_violations ++ todays_violations
    ; P.get_rules         ++ get_rules
    ; P.set_rules         ++ set_rules
+   ; P.acknowledge       ++ acknowledge
   ]