From d0f6ca8473dbd6fed982efa8620899e5b3406876 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Loi=CC=88c=20Correnson?= <loic.correnson@cea.fr>
Date: Fri, 15 Mar 2019 11:16:03 +0100
Subject: [PATCH] [server] new request API
---
src/plugins/server/data.ml | 51 +++---
src/plugins/server/doc.ml | 2 +-
src/plugins/server/doc.mli | 3 +-
src/plugins/server/kernel_ast.ml | 15 +-
src/plugins/server/kernel_fc.ml | 16 +-
src/plugins/server/kernel_project.ml | 19 +--
src/plugins/server/request.ml | 247 ++++++++++++++++++++++++++-
src/plugins/server/request.mli | 143 ++++++++++++++++
src/plugins/server/syntax.ml | 36 +++-
src/plugins/server/syntax.mli | 13 +-
10 files changed, 480 insertions(+), 65 deletions(-)
diff --git a/src/plugins/server/data.ml b/src/plugins/server/data.ml
index 1a8849d9879..0089341017a 100644
--- a/src/plugins/server/data.ml
+++ b/src/plugins/server/data.ml
@@ -201,7 +201,7 @@ let text_page = Doc.page `Kernel ~title:"Rich Text Format" ~filename:"text.md"
module Jtext =
struct
include Jany
- let syntax = Syntax.publish text_page ~name:"text"
+ let syntax = Syntax.publish ~page:text_page ~name:"text"
~synopsis:Syntax.any ~descr:(Markdown.praw "Formatted text.")
end
@@ -237,8 +237,14 @@ struct
| None -> None
| Some v ->
let jd = D.to_json v in
- defaults := Fmap.add name jd !defaults ; Some jd
- in fdocs := (name , D.syntax , def , descr) :: !fdocs ;
+ defaults := Fmap.add name jd !defaults ;
+ Some (Markdown.tt @@ Json.to_string jd) in
+ fdocs := Syntax.{
+ fd_name = name ;
+ fd_syntax = D.syntax ;
+ fd_default = def ;
+ fd_descr = descr ;
+ } :: !fdocs ;
let member r = Fmap.mem name r in
let getter r = D.of_json (Fmap.find name r) in
let setter r v = Fmap.add name (D.to_json v) r in
@@ -246,7 +252,12 @@ struct
let option (type a) name ~descr (d : a data) : a option field =
let module D = (val d) in
- fdocs := (name , Syntax.option D.syntax , None , descr) :: !fdocs ;
+ fdocs := Syntax.{
+ fd_name = name ;
+ fd_syntax = D.syntax ;
+ fd_default = None ;
+ fd_descr = descr ;
+ } :: !fdocs ;
let member r = Fmap.mem name r in
let getter r =
try Some (D.of_json (Fmap.find name r)) with Not_found -> None in
@@ -255,34 +266,11 @@ struct
| Some v -> Fmap.add name (D.to_json v) r in
{ member ; getter ; setter }
- let fields () =
- let field = `Center "Field" in
- let format = `Center "Format" in
- let default = `Center "Default" in
- let descr = `Left "Description" in
- if Fmap.is_empty !defaults then
- Markdown.table [ field ; format ; descr ]
- (List.map
- (fun (fd,sy,_def,descr) ->
- [ Markdown.tt fd ; Syntax.format sy ; descr ])
- !fdocs)
- else
- let mk_syntax def sy = if def <> None then Syntax.option sy else sy in
- let mk_default = function
- | None -> Markdown.text []
- | Some js -> Markdown.tt (Json.to_string js) in
- Markdown.table [ field ; format ; default ; descr ]
- (List.map
- (fun (fd,sy,def,descr) -> [
- Markdown.tt fd ;
- Syntax.format @@ mk_syntax def sy ;
- mk_default def ; descr ;
- ])
- !fdocs)
+ let fields () = Syntax.fields ~kind:"Field" !fdocs
let syntax =
let descr = Markdown.( R.descr </> mk_block fields ) in
- Syntax.publish R.page ~name:R.name ~synopsis:(Syntax.record []) ~descr
+ Syntax.publish ~page:R.page ~name:R.name ~synopsis:(Syntax.record []) ~descr
let of_json js =
List.fold_left
@@ -317,7 +305,7 @@ sig
end
let publish_id (module A : Info) =
- Syntax.publish A.page ~name:A.name ~synopsis:Syntax.int ~descr:A.descr
+ Syntax.publish ~page:A.page ~name:A.name ~synopsis:Syntax.int ~descr:A.descr
module INDEXER(M : Map)(I : Info) :
sig
@@ -520,7 +508,8 @@ struct
(struct
type t = E.t
- let syntax = Syntax.publish E.page ~name:E.name
+ let syntax = Syntax.publish
+ ~page:E.page ~name:E.name
~synopsis:Syntax.ident
~descr:Markdown.( E.descr </> mk_block values )
diff --git a/src/plugins/server/doc.ml b/src/plugins/server/doc.ml
index 0bfc615de78..351c563e823 100644
--- a/src/plugins/server/doc.ml
+++ b/src/plugins/server/doc.ml
@@ -80,7 +80,7 @@ let page chapter ~title ~filename =
sections=[] } in
pages := Pages.add path page !pages ; page
-let publish page ?name ?(index=[]) ~title content sections =
+let publish ~page ?name ?(index=[]) ~title content sections =
let id = match name with Some id -> id | None -> title in
let href = `Section( page.path , id ) in
let section = Markdown.section ?name ~title content sections in
diff --git a/src/plugins/server/doc.mli b/src/plugins/server/doc.mli
index 7a9db9e4b42..e204916f44b 100644
--- a/src/plugins/server/doc.mli
+++ b/src/plugins/server/doc.mli
@@ -51,7 +51,8 @@ val page : chapter -> title:string -> filename:string -> page
If index items are provided, they are added
to the server documentation index.
*)
-val publish : page ->
+val publish :
+ page:page ->
?name:string ->
?index:string list ->
title:string ->
diff --git a/src/plugins/server/kernel_ast.ml b/src/plugins/server/kernel_ast.ml
index acef66913aa..adf62a4c4e5 100644
--- a/src/plugins/server/kernel_ast.ml
+++ b/src/plugins/server/kernel_ast.ml
@@ -28,15 +28,14 @@ module Jutil = Yojson.Basic.Util
(* --- Frama-C Ast Services --- *)
(* -------------------------------------------------------------------------- *)
-let ast_page =
- Doc.page `Kernel ~title:"Ast Services" ~filename:"ast.md"
+let page = Doc.page `Kernel ~title:"Ast Services" ~filename:"ast.md"
module ExecCompute = Request.Register(Junit)(Junit)
(struct
let kind = `EXEC
let name = "Kernel.Ast.ExecCompute"
let descr = Markdown.rm "Ensures that AST is computed"
- let page = ast_page
+ let page = page
let details = []
type input = unit
type output = unit
@@ -107,8 +106,7 @@ module PP = Printer_tag.Make(Tag)
module Stmt = Data.Collection
(struct
type t = stmt
- let syntax = Syntax.publish ast_page
- ~name:"stmt"
+ let syntax = Syntax.publish ~page ~name:"stmt"
~synopsis:Syntax.ident
~descr:(Markdown.praw "Code statement identifier")
let to_json st = `String (Tag.of_stmt st)
@@ -137,8 +135,7 @@ module Ki = Data.Collection
module Kf = Data.Collection
(struct
type t = kernel_function
- let syntax = Syntax.publish ast_page
- ~name:"function"
+ let syntax = Syntax.publish ~page ~name:"function"
~synopsis:Syntax.ident
~descr:(Markdown.praw "Function, identified by its global name.")
let to_json kf = `String (Kernel_function.get_name kf)
@@ -156,7 +153,7 @@ module GetFunctions = Request.Register(Junit)(Kf.Jlist)
let kind = `GET
let name = "Kernel.Ast.GetFunctions"
let descr = Markdown.rm "Collect all functions in the AST"
- let page = ast_page
+ let page = page
let details = []
type input = unit
type output = kernel_function list
@@ -171,7 +168,7 @@ module PrintFunction = Request.Register(Kf)(Jtext)
let kind = `GET
let name = "Kernel.Ast.PrintFunction"
let descr = Markdown.rm "Print the AST of a function"
- let page = ast_page
+ let page = page
let details = []
type input = kernel_function
type output = json
diff --git a/src/plugins/server/kernel_fc.ml b/src/plugins/server/kernel_fc.ml
index efaae9a32c8..893b961fd22 100644
--- a/src/plugins/server/kernel_fc.ml
+++ b/src/plugins/server/kernel_fc.ml
@@ -28,8 +28,7 @@ module Senv = Server_parameters
open Data
-let fc_page =
- Doc.page `Kernel ~title:"Kernel Services" ~filename:"kernel.md"
+let page = Doc.page `Kernel ~title:"Kernel Services" ~filename:"kernel.md"
(* -------------------------------------------------------------------------- *)
(* --- Config --- *)
@@ -64,7 +63,7 @@ module GetConfig =
(Junit)
(ConfigInfo)
(struct
- let page = fc_page
+ let page = page
let kind = `GET
let name = "Kernel.GetConfig"
let descr = Markdown.rm "Kernel configuration"
@@ -82,8 +81,7 @@ module GetConfig =
module RawSource =
struct
type t = Filepath.position
- let syntax = Syntax.publish fc_page
- ~name:"source"
+ let syntax = Syntax.publish ~page ~name:"source"
~synopsis:(Syntax.record [ "file" , Syntax.string ; "line" , Syntax.int ])
~descr:(Markdown.praw "Source position. The file path is normalized, \
and the line number starts at one.")
@@ -110,7 +108,7 @@ module LogSource = Collection(RawSource)
module RawKind =
struct
type t = Log.kind
- let page = fc_page
+ let page = page
let name = "Kind"
let descr = Markdown.praw "Frama-C message category."
let values = [
@@ -134,7 +132,7 @@ struct
module R = Record
(struct
- let page = fc_page
+ let page = page
let name = "log"
let descr = Markdown.praw "Message event record."
end)
@@ -212,7 +210,7 @@ module SetLogs =
let name = "Kernel.SetLogs"
let descr = Markdown.rm "Turn logs monitoring on/off"
let details = []
- let page = fc_page
+ let page = page
let kind = `SET
type input = bool
type output = unit
@@ -227,7 +225,7 @@ module GetLogs =
let name = "Kernel.GetLogs"
let descr = Markdown.rm "Flush emitted logs since last call (max 100)"
let details = []
- let page = fc_page
+ let page = page
let kind = `GET
type input = unit
type output = Log.event list
diff --git a/src/plugins/server/kernel_project.ml b/src/plugins/server/kernel_project.ml
index b9c7d963469..8cb431633c0 100644
--- a/src/plugins/server/kernel_project.ml
+++ b/src/plugins/server/kernel_project.ml
@@ -27,13 +27,12 @@
open Data
module Jutil = Yojson.Basic.Util
-let project_page =
- Doc.page `Kernel ~title:"Project Management" ~filename:"project.md"
+let page = Doc.page `Kernel ~title:"Project Management" ~filename:"project.md"
module ProjectInfo =
struct
type t = Project.t
- let syntax = Syntax.publish project_page ~name:"project"
+ let syntax = Syntax.publish ~page ~name:"project"
~synopsis:(Syntax.(record ["id",string;"name",string;"current",boolean]))
~descr:(Markdown.praw "Project informations")
let name_of_json = function
@@ -53,7 +52,7 @@ end
module ProjectRequest =
struct
type t = Project.t * string * json
- let syntax = Syntax.publish project_page ~name:"project"
+ let syntax = Syntax.publish ~page ~name:"project"
~synopsis:(Syntax.(record ["project",string;"request",string;"data",any]))
~descr:(Markdown.praw "Request to be executed on the specified project.")
let of_json js =
@@ -76,7 +75,7 @@ module GetCurrent =
(Junit)
(ProjectInfo)
(struct
- let page = project_page
+ let page = page
let kind = `GET
let name = "Kernel.Project.GetCurrent"
let descr = Markdown.rm "Returns the current project"
@@ -91,7 +90,7 @@ module SetCurrent =
(ProjectInfo)
(Junit)
(struct
- let page = project_page
+ let page = page
let kind = `SET
let name = "Kernel.Project.SetCurrent"
let descr = Markdown.rm "Switches the current project"
@@ -106,7 +105,7 @@ module GetProjects =
(Junit)
(Jlist(ProjectInfo))
(struct
- let page = project_page
+ let page = page
let kind = `GET
let name = "Kernel.Project.GetList"
let descr = Markdown.rm "List of projects"
@@ -121,7 +120,7 @@ module GetOn =
(ProjectRequest)
(Jany)
(struct
- let page = project_page
+ let page = page
let kind = `GET
let name = "Kernel.Project.GetOn"
let descr = Markdown.rm "Execute a GET request within the given project"
@@ -136,7 +135,7 @@ module SetOn =
(ProjectRequest)
(Jany)
(struct
- let page = project_page
+ let page = page
let kind = `SET
let name = "Kernel.Project.SetOn"
let descr = Markdown.rm "Execute a SET request within the given project"
@@ -151,7 +150,7 @@ module ExecOn =
(ProjectRequest)
(Jany)
(struct
- let page = project_page
+ let page = page
let kind = `EXEC
let name = "Kernel.Project.ExecOn"
let descr = Markdown.rm "Execute an EXEC request within the given project"
diff --git a/src/plugins/server/request.ml b/src/plugins/server/request.ml
index 80ef1bf3242..ca448e9a289 100644
--- a/src/plugins/server/request.ml
+++ b/src/plugins/server/request.ml
@@ -21,6 +21,7 @@
(**************************************************************************)
module Senv = Server_parameters
+module Jutil = Yojson.Basic.Util
(* -------------------------------------------------------------------------- *)
(* --- Request Registry --- *)
@@ -43,6 +44,9 @@ sig
val to_json : t -> json
end
+type 'a input = (module Input with type t = 'a)
+type 'a output = (module Output with type t = 'a)
+
module type RequestInfo =
sig
type input
@@ -137,7 +141,7 @@ struct
[[ Syntax.format Input.syntax ;
Syntax.format Output.syntax ; Rq.descr ]]
in
- Doc.publish Rq.page ~index:[Rq.name] ~title synopsis Rq.details
+ Doc.publish ~page:Rq.page ~index:[Rq.name] ~title synopsis Rq.details
let () =
check_name Rq.name ;
@@ -148,3 +152,244 @@ struct
end
(* -------------------------------------------------------------------------- *)
+(* --- Multiple Fields Requests --- *)
+(* -------------------------------------------------------------------------- *)
+
+module Fmap = Map.Make(String)
+
+type rq = {
+ mutable param : json Fmap.t ;
+ mutable result : json Fmap.t ;
+}
+
+let fmap_of_json r js =
+ List.fold_left
+ (fun r (fd,js) -> Fmap.add fd js r)
+ r (Jutil.to_assoc js)
+
+let fmap_to_json r =
+ `Assoc (Fmap.fold (fun fd js r -> (fd,js)::r) r [])
+
+type 'a param = rq -> 'a
+type 'a result = rq -> 'a -> unit
+
+(* -------------------------------------------------------------------------- *)
+(* --- Input/Output Request Processing --- *)
+(* -------------------------------------------------------------------------- *)
+
+type _ rq_input =
+ | Pnone
+ | Pdata : 'a input -> 'a rq_input
+ | Pfields : Syntax.field list -> unit rq_input
+
+type _ rq_output =
+ | Rnone
+ | Rdata : 'a output -> 'a rq_output
+ | Rfields : Syntax.field list -> unit rq_output
+
+(* json input processing *)
+let mk_input (type a) name (input : a rq_input) : (rq -> json -> a) =
+ match input with
+ | Pnone -> Senv.fatal "No input defined for request '%s'" name
+ | Pdata d -> let module D = (val d) in (fun _rq js -> D.of_json js)
+ | Pfields _ -> (fun rq js -> rq.param <- fmap_of_json rq.param js)
+
+(* json output processing *)
+let mk_output (type b) name (output : b rq_output) : (rq -> b -> json) =
+ match output with
+ | Rnone -> Senv.fatal "No output defined for request '%s'" name
+ | Rdata d -> let module D = (val d) in (fun _rq v -> D.to_json v)
+ | Rfields _ -> (fun rq () -> fmap_to_json rq.result)
+
+(* json input syntax *)
+let sy_input (type a) (input : a rq_input) : Syntax.t =
+ match input with
+ | Pnone -> assert false
+ | Pdata d -> let module D = (val d) in D.syntax
+ | Pfields _ -> Syntax.record []
+
+(* json output syntax *)
+let sy_output (type b) (output : b rq_output) : Syntax.t =
+ match output with
+ | Rnone -> assert false
+ | Rdata d -> let module D = (val d) in D.syntax
+ | Rfields _ -> Syntax.record []
+
+(* json input documentation *)
+let doc_input (type a) (input : a rq_input) : Markdown.block =
+ match input with
+ | Pnone -> assert false
+ | Pdata _ -> Markdown.empty
+ | Pfields fs -> Syntax.fields ~kind:"Input" (List.rev fs)
+
+(* json output syntax *)
+let doc_output (type b) (output : b rq_output) : Markdown.block =
+ match output with
+ | Rnone -> assert false
+ | Rdata _ -> Markdown.empty
+ | Rfields fs -> Syntax.fields ~kind:"Output" (List.rev fs)
+
+(* current input fields *)
+let fds_input (type a) name (input : a rq_input) : Syntax.field list =
+ match input with
+ | Pdata _ -> Senv.fatal "Can not define named parameters for request '%s'" name
+ | Pnone -> []
+ | Pfields fds -> fds
+
+(* current output fields *)
+let fds_output (type a) name (output : a rq_output) : Syntax.field list =
+ match output with
+ | Rdata _ -> Senv.fatal "Can not define named results request '%s'" name
+ | Rnone -> []
+ | Rfields fds -> fds
+
+(* -------------------------------------------------------------------------- *)
+(* --- Multi-Parameters Requests --- *)
+(* -------------------------------------------------------------------------- *)
+
+type ('a,'b) signature = {
+ page : Doc.page ;
+ kind : kind ;
+ name : string ;
+ descr : Markdown.text ;
+ details : Markdown.block ;
+ mutable defined : bool ;
+ mutable defaults : json Fmap.t ;
+ mutable input : 'a rq_input ;
+ mutable output : 'b rq_output ;
+}
+
+let failure_missing name fmap =
+ Data.failure
+ (Printf.sprintf "Missing parameter '%s'" name)
+ (fmap_to_json fmap)
+
+(* -------------------------------------------------------------------------- *)
+(* --- Named Input Parameters Definitions --- *)
+(* -------------------------------------------------------------------------- *)
+
+let param (type a b) (s : (unit,b) signature) ~name ~descr
+ ?default (input : a input) : a param =
+ let module D = (val input) in
+ let fd = Syntax.{
+ fd_name = name ;
+ fd_syntax = if default = None then D.syntax else Syntax.option D.syntax ;
+ fd_default = None ;
+ fd_descr = descr ;
+ } in
+ s.input <- Pfields (fd :: fds_input s.name s.input) ;
+ fun rq ->
+ try D.of_json (Fmap.find name rq.param)
+ with Not_found ->
+ match default with
+ | None -> failure_missing name rq.param
+ | Some v -> v
+
+let param_opt (type a b) (rq : (unit,b) signature) ~name ~descr
+ (input : a input) : a option param =
+ let module D = (val input) in
+ let fd = Syntax.{
+ fd_name = name ;
+ fd_syntax = Syntax.option D.syntax ;
+ fd_default = None ;
+ fd_descr = descr ;
+ } in
+ rq.input <- Pfields (fd :: fds_input rq.name rq.input) ;
+ fun rq ->
+ try Some(D.of_json (Fmap.find name rq.param))
+ with Not_found -> None
+
+(* -------------------------------------------------------------------------- *)
+(* --- Named Output Parameters Definitions --- *)
+(* -------------------------------------------------------------------------- *)
+
+let result (type a b) (s : (a,unit) signature) ~name ~descr
+ ?default (output : b output) : b result =
+ let module D = (val output) in
+ let fd = Syntax.{
+ fd_name = name ;
+ fd_syntax = D.syntax ;
+ fd_default = None ;
+ fd_descr = descr ;
+ } in
+ s.output <- Rfields (fd :: fds_output s.name s.output) ;
+ ( match default with None -> () | Some v ->
+ s.defaults <- Fmap.add name (D.to_json v) s.defaults ) ;
+ fun rq v -> rq.result <- Fmap.add name (D.to_json v) rq.result
+
+let result_opt (type a b) (s : (a,unit) signature) ~name ~descr
+ (output : b output) : b option result =
+ let module D = (val output) in
+ let fd = Syntax.{
+ fd_name = name ;
+ fd_syntax = Syntax.option D.syntax ;
+ fd_default = None ;
+ fd_descr = descr ;
+ } in
+ s.output <- Rfields (fd :: fds_output s.name s.output) ;
+ fun rq opt ->
+ match opt with None -> () | Some v ->
+ rq.result <- Fmap.add name (D.to_json v) rq.result
+
+(* -------------------------------------------------------------------------- *)
+(* --- Opened Signature Definition --- *)
+(* -------------------------------------------------------------------------- *)
+
+let signature
+ ~page ~kind ~name ~descr ?(details=Markdown.empty)
+ ?input ?output () =
+ check_name name ;
+ check_page page name ;
+ check_kind kind name ;
+ let input = match input with None -> Pnone | Some d -> Pdata d in
+ let output = match output with None -> Rnone | Some d -> Rdata d in
+ {
+ page ; kind ; name ; descr ; details ;
+ defaults = Fmap.empty ;
+ input ; output ; defined = false ;
+ }
+
+(* -------------------------------------------------------------------------- *)
+(* --- Opened Signature Process --- *)
+(* -------------------------------------------------------------------------- *)
+
+let register_sig (type a b) (s : (a,b) signature) (process : rq -> a -> b) =
+ if s.defined then
+ Senv.fatal "Request '%s' is defined twice" s.name ;
+ let input = mk_input s.name s.input in
+ let output = mk_output s.name s.output in
+ let defaults = s.defaults in
+ let processor js =
+ let rq = { param = Fmap.empty ; result = defaults } in
+ js |> input rq |> process rq |> output rq
+ in
+ let skind = Main.string_of_kind s.kind in
+ let title = Printf.sprintf "`%s` %s" skind s.name in
+ let pp_syntax fmt sy = Markdown.pp_text fmt (Syntax.format sy) in
+ let synopsis = Markdown.fmt_block (fun fmt ->
+ Format.fprintf fmt "> `'%s'` ( %a ) : %a" s.name
+ pp_syntax (sy_input s.input)
+ pp_syntax (sy_output s.output)
+ ) in
+ let content =
+ Markdown.concat [
+ Markdown.par s.descr ;
+ synopsis ;
+ s.details ;
+ doc_input s.input ;
+ doc_output s.output ;
+ ] in
+ let _ = Doc.publish ~page:s.page ~name:s.name ~title content [] in
+ Main.register s.kind s.name processor ;
+ s.defined <- true
+
+(* -------------------------------------------------------------------------- *)
+(* --- Request Registration --- *)
+(* -------------------------------------------------------------------------- *)
+
+let register ~page ~kind ~name ~descr ?details ~input ~output ~process () =
+ register_sig
+ (signature ~page ~kind ~name ~descr ?details ~input ~output ())
+ (fun _rq v -> process v)
+
+(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/request.mli b/src/plugins/server/request.mli
index bdd9eed2f4a..966f7da9b70 100644
--- a/src/plugins/server/request.mli
+++ b/src/plugins/server/request.mli
@@ -41,6 +41,149 @@ sig
val to_json : t -> json
end
+type 'a input = (module Input with type t = 'a)
+type 'b output = (module Output with type t = 'b)
+
+(** {2 Simple Requests Registration} *)
+
+(** Register a simple request of type [(a -> b)]. *)
+val register :
+ page:Doc.page ->
+ kind:kind ->
+ name:string ->
+ descr:Markdown.text ->
+ ?details:Markdown.block ->
+ input:'a input ->
+ output:'b output ->
+ process:('a -> 'b) ->
+ unit -> unit
+
+(** {2 Requests with Named Parameters}
+
+ The API below allows for creating requests with
+ named and optional parameters. Although such requests
+ could be defined with simple registration and {i record} datatypes,
+ the helpers below allow more flexibility and a better correspondance
+ between optional parameters and OCaml option types.
+
+ To register a request with named parameters and/or named results,
+ you first create a {i signature}. Then you define named
+ parameters and results, and finally you {i register} the processing
+ function:
+
+ {[
+ let () =
+ let s = Request.signature ~page ~kind ~name ~descr () in
+ let get_a = Request.param s ~name:"a" ~descr:"…" (module A) in
+ let get_b = Request.param s ~name:"b" ~descr:"…" (module B) in
+ let set_c = Request.result s ~name:"c" ~descr:"…" (module C) in
+ let set_d = Request.result s ~name:"d" ~descr:"…" (module D) in
+ Request.register_sig s
+ (fun rq () ->
+ let (c,d) = some_job (get_a rq) (get_b rq) in
+ set_c rq c ; set_d rq d)
+ ]}
+
+*)
+
+(** Under definition request signature. *)
+type ('a,'b) signature
+
+(** Create an opened request signature.
+ Depending on whether [~input] and [~output] datatype are provided,
+ you shall define named parameters and results before registering the
+ request processing function. *)
+val signature :
+ page:Doc.page ->
+ kind:kind ->
+ name:string ->
+ descr:Markdown.text ->
+ ?details:Markdown.block ->
+ ?input:'a input ->
+ ?output:'b output ->
+ unit -> ('a,'b) signature
+
+(** Request JSON parameters. *)
+type rq
+
+(** Named input parameter. *)
+type 'a param = rq -> 'a
+
+(** Named output parameter. *)
+type 'b result = rq -> 'b -> unit
+
+(** Register the request JSON processing function.
+ This call finalize the signature definition and shall be called
+ once on the signature. *)
+val register_sig : ('a,'b) signature -> (rq -> 'a -> 'b) -> unit
+
+(** {2 Named Parameters and Results}
+
+ The functions bellow must be called on a freshly created signature
+ {i before} its final registration. The obtained getters and setters
+ shall be only used within the registered process.
+
+ The correspondance between input/output JSON syntax and OCaml values
+ is summarized in the tables below.Abstract_domain
+
+ For named input parameters:
+ [
+
+ API: Input JSON OCaml Getter
+ -----------------------------------------------------
+ Request.param { f: a } 'a (* might raise an exception *)
+ Request.param ~default { f: a? } 'a (* defined by default *)
+ Request.param_opt { f: a? } 'a option
+
+ ]
+
+
+ For named output parameters:
+ [
+
+ API: Input JSON OCaml Setter
+ ----------------------------------------------------
+ Request.result { f: a } 'a (* shall be set by process *)
+ Request.result ~default { f: a } 'a (* defined by default *)
+ Request.param_opt { f: a? } 'a option
+
+ ]
+
+*)
+
+
+(** Named input parameter. If a default value is provided,
+ the JSON input field becomes optional. Otherwized, it is required. *)
+val param : (unit,'b) signature ->
+ name:string ->
+ descr:Markdown.text ->
+ ?default:'a ->
+ 'a input -> 'a param
+
+(** Named optional input parameter. *)
+val param_opt : (unit,'b) signature ->
+ name:string ->
+ descr:Markdown.text ->
+ 'a input -> 'a option param
+
+(** Named output parameter. If a default value is provided,
+ the JSON output field is initialized with it.
+ Otherwized, it shall be set at each invocation of the request processing
+ funciton. *)
+val result : ('a,unit) signature ->
+ name:string ->
+ descr:Markdown.text ->
+ ?default:'b ->
+ 'b output -> 'b result
+
+(** Named optional output parameter. The initial value is set to [None]. *)
+val result_opt : ('a,unit) signature ->
+ name:string ->
+ descr:Markdown.text ->
+ 'b output -> 'b option result
+
+(** {2 Functorial Interface} *)
+
module type RequestInfo =
sig
type input
diff --git a/src/plugins/server/syntax.ml b/src/plugins/server/syntax.ml
index 79e030cb641..63cbcd0abab 100644
--- a/src/plugins/server/syntax.ml
+++ b/src/plugins/server/syntax.ml
@@ -61,7 +61,7 @@ let format { descr } = descr
let protect a =
if a.atomic then a.descr else Markdown.(rm "(" <+> a.descr <+> rm ")")
-let publish page ~name ~synopsis ~descr =
+let publish ~page ~name ~synopsis ~descr =
check_name name ;
check_page page name ;
let title = Printf.sprintf "`Data` %s" name in
@@ -70,7 +70,7 @@ let publish page ~name ~synopsis ~descr =
name Markdown.pp_text synopsis.descr
) in
let content = Markdown.( syntax </> descr ) in
- let href = Doc.publish page ~name ~title ~index:[name] content [] in
+ let href = Doc.publish ~page ~name ~title ~index:[name] content [] in
atom @@ Markdown.href ~title:name href
let any = atom @@ Markdown.it "any"
@@ -105,4 +105,36 @@ let record fds =
Markdown.(glue ~sep:(raw " `;` ") (List.map field fds))
in atom @@ Markdown.(tt "{" <+> fields <+> tt "}")
+type field = {
+ fd_name : string ;
+ fd_syntax : t ;
+ fd_default : Markdown.text option ;
+ fd_descr : Markdown.text ;
+}
+
+let fields ~kind (fds : field list) =
+ let c_field = `Center kind in
+ let c_format = `Center "Format" in
+ let c_default = `Center "Default" in
+ let c_descr = `Left "Description" in
+ if List.for_all (fun f -> f.fd_default = None) fds then
+ Markdown.table [ c_field ; c_format ; c_descr ]
+ (List.map
+ (fun f ->
+ [ Markdown.tt f.fd_name ; format f.fd_syntax ; f.fd_descr ])
+ fds)
+ else
+ let mk_syntax def sy = if def <> None then option sy else sy in
+ let mk_default = function
+ | None -> Markdown.text []
+ | Some default -> default in
+ Markdown.table [ c_field ; c_format ; c_default ; c_descr ]
+ (List.map
+ (fun f -> [
+ Markdown.tt f.fd_name ;
+ format @@ mk_syntax f.fd_default f.fd_syntax ;
+ mk_default f.fd_default ; f.fd_descr ;
+ ])
+ fds)
+
(* -------------------------------------------------------------------------- *)
diff --git a/src/plugins/server/syntax.mli b/src/plugins/server/syntax.mli
index de443d599c0..6b6262ffb3e 100644
--- a/src/plugins/server/syntax.mli
+++ b/src/plugins/server/syntax.mli
@@ -31,7 +31,8 @@ val format : t -> Markdown.text
(** The provided synopsis must be very short, to fit in one line.
Extended definition, like record fields and such, must be detailed in
the description block. *)
-val publish : Doc.page -> name:string -> synopsis:t -> descr:Markdown.block -> t
+val publish :
+ page:Doc.page -> name:string -> synopsis:t -> descr:Markdown.block -> t
val any : t
val int : t (* small, non-decimal, number *)
@@ -48,4 +49,14 @@ val union : t list -> t
val option : t -> t
val record : (string * t) list -> t
+type field = {
+ fd_name : string ;
+ fd_syntax : t ;
+ fd_default : Markdown.text option ;
+ fd_descr : Markdown.text ;
+}
+
+(** Builds a table with fields column named « Kind » *)
+val fields : kind:string -> field list -> Markdown.block
+
(* -------------------------------------------------------------------------- *)
--
GitLab