[server] synchronized values, states & models

src/plugins/server/states.ml

@@ -20,8 +20,10 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open Data
+
 (* -------------------------------------------------------------------------- *)
-(* --- Values & States                                                    --- *)
+(* --- Values                                                             --- *)
 (* -------------------------------------------------------------------------- *)
 
 let register_value (type a) ~page ~name ~descr ?(details=[])
@@ -35,11 +37,15 @@ let register_value (type a) ~page ~name ~descr ?(details=[])
       ~descr:(plain "Signal for value " @ href h) () in
   Request.register ~page ~kind:`GET ~name:(name ^ ".get")
     ~descr:(plain "Getter for value " @ href h)
-    ~input:(module Data.Junit) ~output get ;
+    ~input:(module Junit) ~output get ;
   signal
 
+(* -------------------------------------------------------------------------- *)
+(* --- States                                                             --- *)
+(* -------------------------------------------------------------------------- *)
+
 let register_state (type a) ~page ~name ~descr ?(details=[])
-    ~(data : a Data.data) ~get ~set =
+    ~(data : a data) ~get ~set =
   let open Markdown in
   let title =  Printf.sprintf "`STATE` %s" name in
   let index = [ Printf.sprintf "%s (`STATE`)" name ] in
@@ -49,10 +55,222 @@ let register_state (type a) ~page ~name ~descr ?(details=[])
       ~descr:(plain "Signal for state " @ href h) () in
   Request.register ~page ~kind:`GET ~name:(name ^ ".get")
     ~descr:(plain "Getter for state " @ href h)
-    ~input:(module Data.Junit) ~output:(module (val data)) get ;
+    ~input:(module Junit) ~output:(module (val data)) get ;
   Request.register ~page ~kind:`SET ~name:(name ^ ".set")
     ~descr:(plain "Setter for state " @ href h)
-    ~input:(module (val data)) ~output:(module Data.Junit) set ;
+    ~input:(module (val data)) ~output:(module Junit) set ;
   signal
 
 (* -------------------------------------------------------------------------- *)
+(* --- Model Signature                                                    --- *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a column = Syntax.field * ('a -> json)
+
+type 'a signature = 'a column list ref
+
+let signature () = ref []
+
+let column (type a) (s : a signature) ~name ~descr (output : a Request.output) =
+  let module D = (val output) in
+  if name = "id" then
+    raise (Invalid_argument "Server.States.column: invalid name") ;
+  if List.exists (fun (fd,_) -> fd.Syntax.name = name) !s then
+    raise (Invalid_argument "Server.States.column: duplicate name") ;
+  let fd = Syntax.{ name ; syntax = D.syntax ; descr } in
+  s := (fd , D.to_json) :: !s
+
+module Kmap = Map.Make(String)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Model Content                                                      --- *)
+(* -------------------------------------------------------------------------- *)
+
+type 'a update = Remove | Add of 'a
+type 'a content = {
+  mutable cleared : bool ;
+  mutable updates : 'a update Kmap.t ;
+}
+
+type 'a model = {
+  signal : Request.signal ;
+  key : 'a -> string ;
+  iter : ('a -> unit) -> unit ;
+  getter : (string * ('a -> json)) list ;
+  mutable current : 'a content option ; (* fast access *)
+  projects : (string , 'a content) Hashtbl.t ; (* indexed by project *)
+}
+
+let synchronize model =
+  begin
+    Project.register_after_set_current_hook
+      ~user_only:false (fun _ -> model.current <- None) ;
+    let cleanup p =
+      Hashtbl.remove model.projects (Project.get_unique_name p) in
+    Project.register_before_remove_hook cleanup ;
+    Project.register_todo_before_clear cleanup ;
+  end
+
+let current model =
+  match model.current with
+  | Some w -> w
+  | None ->
+    let prj = Project.(current () |> get_unique_name) in
+    let content =
+      try Hashtbl.find model.projects prj
+      with Not_found ->
+        let w = {
+          cleared = true ;
+          updates = Kmap.empty ;
+        } in
+        Hashtbl.add model.projects prj w ; w
+    in model.current <- Some content ; content
+
+let reload model =
+  let m = current model in
+  m.cleared <- true ; m.updates <- Kmap.empty
+
+let update model k =
+  let m = current model in
+  if not m.cleared then m.updates <- Kmap.add (model.key k) (Add k) m.updates
+
+let remove model k =
+  let m = current model in
+  if not m.cleared then m.updates <- Kmap.add (model.key k) Remove m.updates
+
+(* -------------------------------------------------------------------------- *)
+(* --- Fetch Model Updates                                                --- *)
+(* -------------------------------------------------------------------------- *)
+
+type buffer = {
+  reload : bool ;
+  mutable capacity : int ;
+  mutable pending : int ;
+  mutable removed : string list ;
+  mutable updated : json list ;
+}
+
+let add_entry buffer cols key v =
+  let fjs = List.fold_left (fun fjs (fd,to_json) ->
+      try (fd , to_json v) :: fjs
+      with Not_found -> fjs
+    ) [] cols in
+  buffer.updated <- `Assoc( ("key", `String key):: fjs) :: buffer.updated ;
+  buffer.capacity <- pred buffer.capacity
+
+let remove_entry buffer key =
+  buffer.removed <- key :: buffer.removed ;
+  buffer.capacity <- pred buffer.capacity
+
+let update_entry buffer cols key = function
+  | Remove -> remove_entry buffer key
+  | Add v -> add_entry buffer cols key v
+
+let fetch model n =
+  let m = current model in
+  let reload = m.cleared in
+  let buffer = {
+    reload ;
+    capacity = n ;
+    pending = 0 ;
+    removed = [] ;
+    updated = [] ;
+  } in
+  begin
+    if reload then
+      begin
+        m.cleared <- false ;
+        model.iter
+          begin fun v ->
+          let key = model.key v in
+          if buffer.capacity > 0 then
+            add_entry buffer model.getter key v
+          else
+            ( m.updates <- Kmap.add key (Add v) m.updates ;
+              buffer.pending <- succ buffer.pending ) ;
+          end ;
+      end
+    else
+      m.updates <- Kmap.filter
+          begin fun key upd ->
+            if buffer.capacity > 0 then
+              ( update_entry buffer model.getter key upd ; false )
+            else
+              ( buffer.pending <- succ buffer.pending ; true )
+          end m.updates ;
+  end ;
+  buffer
+
+(* -------------------------------------------------------------------------- *)
+(* --- Signature Registry                                                 --- *)
+(* -------------------------------------------------------------------------- *)
+
+let register_model ~page ~name ~descr ?(details=[]) ~key ~iter s =
+  let open Markdown in
+  let title =  Printf.sprintf "`MODEL` %s" name in
+  let index = [ Printf.sprintf "%s (`MODEL`)" name ] in
+  let columns = !s in
+  let description = [
+    Block [Text descr] ;
+    Syntax.fields ~title:(Printf.sprintf "Model %s" name)
+      begin
+        Syntax.{
+          name="key" ;
+          syntax=Syntax.ident ;
+          descr=plain "entry identifier" ;
+        } :: List.rev (List.map fst columns)
+      end ;
+    Block details
+  ] in
+  let mref = Doc.publish ~page:page ~name:name ~title ~index description [] in
+  let signal = Request.signal ~page ~name:(name ^ ".sig")
+      ~descr:(plain "Signal for model " @ href mref) () in
+  let getter = List.map (fun (fd,to_js) -> fd.Syntax.name , to_js) columns in
+  let model = {
+    key ; iter ; getter ; signal ;
+    current = None ; projects = Hashtbl.create 0
+  } in
+  let signature =
+    Request.signature ~kind:`GET ~page ~name:(name ^ ".fetch")
+      ~descr:(plain "Fetch updates for model " @ href mref)
+      ~input:(module Jint)
+      ~details:[
+        Text(plain
+               "Collect all model updates since the last fetch.\n\
+                The number of fetched entries is limited to the\n\
+                provided integer. When `reload:true` is returned,\n\
+                _all_ previously received entries must be removed.")]
+      () in
+  let module Jentries =
+      (struct
+        include Jany
+        let syntax = Syntax.data "entry" mref
+      end) in
+  let set_reload = Request.result signature
+      ~name:"reload" ~descr:(plain "model fully reloaded")
+      (module Jbool) in
+  let set_removed = Request.result signature
+      ~name:"removed" ~descr:(plain "removed entries")
+      (module Jident.Jlist) in
+  let set_updated = Request.result signature
+      ~name:"updated" ~descr:(plain "updated entries")
+      (module Jlist(Jentries)) in
+  let set_pending = Request.result signature
+      ~name:"pending" ~descr:(plain "remaining entries to be fetched")
+      (module Jint) in
+  Request.register_sig signature
+    begin fun rq n ->
+      let buffer = fetch model n in
+      set_reload rq buffer.reload ;
+      set_removed rq buffer.removed ;
+      set_updated rq buffer.updated ;
+      set_pending rq buffer.pending ;
+    end ;
+  Request.register ~kind:`GET ~page ~name:(name ^ ".reload")
+    ~descr:(plain "Force full reload for model " @ href mref)
+    ~input:(module Junit) ~output:(module Junit)
+    (fun () -> reload model) ;
+  synchronize model ;
+  model
+
+(* -------------------------------------------------------------------------- *)

src/plugins/server/states.mli

@@ -39,4 +39,28 @@ val register_state :
   set:('a -> unit) ->
   Request.signal
 
+type 'a signature
+
+val signature :
+  unit -> 'a signature
+
+val column :
+  'a signature -> name:string -> descr:Markdown.text ->
+  'a Request.output -> unit
+
+type 'a model
+
+val reload : 'a model -> unit
+val update : 'a model -> 'a -> unit
+val remove : 'a model -> 'a -> unit
+
+val register_model :
+  page:Doc.page ->
+  name:string ->
+  descr:Markdown.text ->
+  ?details:Markdown.block ->
+  key:('a -> string) ->
+  iter:(('a -> unit) -> unit) ->
+  'a signature -> 'a model
+
 (* -------------------------------------------------------------------------- *)

src/plugins/server/syntax.ml

@@ -81,6 +81,7 @@ let ident = atom @@ Markdown.emph "ident"
 let string = atom @@ Markdown.emph "string"
 let number = atom @@ Markdown.emph "number"
 let boolean = atom @@ Markdown.emph "boolean"
+let data name dref = atom @@ Markdown.href ~text:(Markdown.emph name) dref
 
 let escaped name =
   Markdown.code (Printf.sprintf "'%s'" @@ String.escaped name)

src/plugins/server/syntax.mli

@@ -49,6 +49,7 @@ val tuple : t list -> t
 val union : t list -> t
 val option : t -> t
 val record : (string * t) list -> t
+val data : string -> Markdown.href -> t
 
 type field = { name : string ; syntax : t ; descr : Markdown.text }