diff --git a/src/plugins/server/states.ml b/src/plugins/server/states.ml
index f3af381df65192e3ea920fbbc0e9a87311c81c9a..dcc2e97ec4d56f1bf4d1393e318ba083f39dcfef 100644
--- a/src/plugins/server/states.ml
+++ b/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
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/states.mli b/src/plugins/server/states.mli
index 8bd97b3a34b424f98258308237381ca8d3971736..3dc8cb6b62f661a95abebf9601a63726265b6517 100644
--- a/src/plugins/server/states.mli
+++ b/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
+
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/syntax.ml b/src/plugins/server/syntax.ml
index 727d520370b2a9a5d4c7ec5a8eac0cd534c46842..bfc7218a57a7580c4c1544c03dd58b703c51d2e9 100644
--- a/src/plugins/server/syntax.ml
+++ b/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)
diff --git a/src/plugins/server/syntax.mli b/src/plugins/server/syntax.mli
index d2537edf19d77b2b70d9339c86223056c722eaaa..1080751de02a8a87362784a8db6f9d62499c3c8f 100644
--- a/src/plugins/server/syntax.mli
+++ b/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 }