Resto: allow optional/multi argument in query string

lib_node_services/RPC.ml

@@ -43,12 +43,32 @@ module Data = struct
         (fun s -> PDynamic s) ;
     ]
 
+  let query_kind_encoding =
+    let open Data_encoding in
+    union [
+      case ~tag:0 (obj1 (req "single" arg_encoding))
+        (function Single s -> Some s | _ -> None)
+        (fun s -> Single s) ;
+      case ~tag:1 (obj1 (req "optional" arg_encoding))
+        (function Optional s -> Some s | _ -> None)
+        (fun s -> Optional s) ;
+      case ~tag:2 (obj1 (req "flag" unit))
+        (function Flag -> Some () | _ -> None)
+        (fun () -> Flag) ;
+      case ~tag:3 (obj1 (req "multi" arg_encoding))
+        (function Multi s -> Some s | _ -> None)
+        (fun s -> Multi s) ;
+    ]
+
   let query_item_encoding =
     let open Data_encoding in
     conv
-      (fun {name ; description} -> (name, description))
+      (fun { name ; description ; kind } -> (name, description, kind))
-      (fun (name, description) -> {name ; description})
+      (fun (name, description, kind) -> { name ; description ; kind })
-      (obj2 (req "name" string) (opt "description" string))
+      (obj3
+         (req "name" string)
+         (opt "description" string)
+         (req "kind" query_kind_encoding))
 
   let service_descr_encoding =
     let open Data_encoding in
@@ -61,7 +81,7 @@ module Data = struct
          (req "meth" meth_encoding)
          (req "path" (list path_item_encoding))
          (opt "description" string)
-         (req "query" (list query_item_encoding))
+         (req "query" (list (dynamic_size query_item_encoding)))
          (opt "input" json_schema)
          (req "output" json_schema)
          (req "erro" json_schema))

vendors/ocplib-resto/lib_resto-directory/resto_directory.ml

@@ -326,8 +326,9 @@ module Make (Encoding : ENCODING) = struct
       let rec loop : type a b. (a, b) query_fields -> _ = function
         | F0 -> []
         | F1 (f, fs) ->
-            { Description.name = f.fname ;
+            { Description.name = field_name f ;
-              description = f.fdescription } :: loop fs in
+              description = field_description f ;
+              kind = field_kind f } :: loop fs in
       loop fields
 
 

vendors/ocplib-resto/lib_resto-json/resto_json.ml

@@ -44,12 +44,36 @@ module Encoding = struct
         (fun s -> PDynamic s) ;
     ]
 
+  let query_kind_encoding =
+    let open Json_encoding in
+    union [
+      case
+        (obj1 (req "single" arg_encoding))
+        (function Single s -> Some s | _ -> None)
+        (fun s -> Single s) ;
+      case
+        (obj1 (req "optional" arg_encoding))
+        (function Optional s -> Some s | _ -> None)
+        (fun s -> Optional s) ;
+      case
+        (obj1 (req "flag" empty))
+        (function Flag -> Some () | _ -> None)
+        (fun () -> Flag) ;
+      case
+        (obj1 (req "multi" arg_encoding))
+        (function Multi s -> Some s | _ -> None)
+        (fun s -> Multi s) ;
+    ]
+
   let query_item_encoding =
     let open Json_encoding in
     conv
-      (fun {name ; description} -> (name, description))
+      (fun {name ; description ; kind} -> (name, description, kind))
-      (fun (name, description) -> {name ; description})
+      (fun (name, description, kind) -> {name ; description ; kind})
-      (obj2 (req "name" string) (opt "description" string))
+      (obj3
+         (req "name" string)
+         (opt "description" string)
+         (req "kind" query_kind_encoding))
 
   let service_descr_encoding =
     let open Json_encoding in

vendors/ocplib-resto/lib_resto/resto.ml

@@ -93,13 +93,45 @@ module Internal = struct
     | F1: ('a, 'b) query_field * ('a, 'c) query_fields ->
       ('a, 'b -> 'c) query_fields
 
-  and ('a, 'b) query_field = {
+  and ('a, 'b) query_field =
-    fname : string ;
+    | Single : {
-    ftype : 'b arg ;
+        name : string ; description : string option ;
-    fdefault : 'b ;
+        ty : 'b arg ; default : 'b ; get : 'a -> 'b ;
-    fget : 'a -> 'b ;
+      } -> ('a, 'b) query_field
-    fdescription : string option ;
+    | Opt : {
-  }
+        name : string ; description : string option ;
+        ty : 'b arg ; get : 'a -> 'b option ;
+      } -> ('a, 'b option) query_field
+    | Flag : {
+        name : string ; description : string option ;
+        get : 'a -> bool ;
+      } -> ('a, bool) query_field
+    | Multi : {
+        name : string ; description : string option ;
+        ty : 'b arg ; get : 'a -> 'b list ;
+      } -> ('a, 'b list) query_field
+
+  type query_kind =
+    | Single of descr
+    | Optional of descr
+    | Flag
+    | Multi of descr
+
+  let field_name (type t) : (_,t) query_field -> _ = function
+    | Single { name } -> name
+    | Opt { name } -> name
+    | Flag { name } -> name
+    | Multi { name } -> name
+  let field_description (type t) : (_,t) query_field -> _ = function
+    | Single { description } -> description
+    | Opt { description } -> description
+    | Flag { description } -> description
+    | Multi { description } -> description
+  let field_kind (type t) : (_,t) query_field -> query_kind = function
+    | Single { ty ; _ } -> Single ty.descr
+    | Opt { ty ; _ } -> Optional ty.descr
+    | Flag _ -> Flag
+    | Multi { ty ; _ } -> Multi ty.descr
 
   let from_query x = x
   let to_query x = x
@@ -127,6 +159,10 @@ module Arg = struct
 
   let descr (ty: 'a arg) = ty.descr
 
+  let ignore : unit arg =
+    let destruct _ = Ok () in
+    let construct () = "" in
+    make ~name:"unit" ~destruct ~construct ()
   let bool : bool arg =
     let bool_of_string s =
       match String.lowercase_ascii s with
@@ -245,8 +281,17 @@ module Query = struct
   type ('a, 'b, 'c) open_query =
     ('a, 'c) query_fields -> 'b * ('a, 'b) query_fields
 
-  let field ?descr fname ftype fdefault fget =
+  let field ?descr name ty default get : (_,_) query_field =
-    { fname; ftype; fdefault ; fget ; fdescription = descr }
+    Single { name; description = descr ; ty ; default ; get }
+
+  let opt_field ?descr name ty get : (_,_) query_field =
+    Opt { name; description = descr ; ty ; get }
+
+  let flag ?descr name get : (_,_) query_field =
+    Flag { name; description = descr ; get }
+
+  let multi_field ?descr name ty get : (_,_) query_field =
+    Multi { name; description = descr ; ty ; get }
 
   let query : 'b -> ('a, 'b, 'b) open_query =
     fun c fs -> c, fs
@@ -281,18 +326,45 @@ module Query = struct
     = fun map fs f ->
       match fs with
       | F0 -> f
-      | F1 (field, fs) ->
+      | F1 (Single field, fs) -> begin
-          let Parsed (field', v) = StringMap.find field.fname map in
+          match StringMap.find field.name map with
-          let Ty.Eq = Ty.eq field.ftype.id field'.ftype.id in
+          | Parsed (Single field', v) ->
-          let v = match v with None -> field.fdefault | Some v -> v in
+              let Ty.Eq = Ty.eq field.ty.id field'.ty.id in
-          rebuild map fs (f v)
+              let v = match v with None -> field.default | Some v -> v in
+              rebuild map fs (f v)
+          | Parsed _ -> assert false
+        end
+      | F1 (Opt field, fs) -> begin
+          match StringMap.find field.name map with
+          | Parsed (Opt field', v) ->
+              let Ty.Eq = Ty.eq field.ty.id field'.ty.id in
+              let v = match v with None -> None | Some v -> v in
+              rebuild map fs (f v)
+          | Parsed _ -> assert false
+        end
+      | F1 (Flag field, fs) -> begin
+          match StringMap.find field.name map with
+          | Parsed (Flag _, v) ->
+              let v = match v with None -> false | Some v -> v in
+              rebuild map fs (f v)
+          | Parsed _ -> assert false
+        end
+      | F1 (Multi field, fs) -> begin
+          match StringMap.find field.name map with
+          | Parsed (Multi field', v) ->
+              let Ty.Eq = Ty.eq field.ty.id field'.ty.id in
+              let v = match v with None -> [] | Some v -> v in
+              rebuild map fs (f v)
+          | Parsed _ -> assert false
+        end
 
   exception Invalid of string
   type untyped = (string * string) list
   let parse (Fields (fs, f)) =
     let fields =
       fold_fields
-        ~f:(fun map (Field f) -> StringMap.add f.fname (Parsed (f, None)) map)
+        ~f:(fun map (Field f) ->
+            StringMap.add (field_name f) (Parsed (f, None)) map)
         ~init:StringMap.empty
         fs in
     fun query ->
@@ -302,15 +374,46 @@ module Query = struct
           begin fun fields (name, value) ->
             match StringMap.find name fields with
             | exception Not_found -> fields
-            | (Parsed (f, Some _)) ->
+            | (Parsed (Single f, Some _)) ->
-                (* TODO add an option to parse multiple as list. *)
                 fail "Duplicate argument '%s' in query string." name
-            | (Parsed (f, None)) ->
+            | (Parsed (Opt f, Some _)) ->
-                match f.ftype.destruct value with
+                fail "Duplicate argument '%s' in query string." name
+            | (Parsed (Flag f, Some _)) ->
+                fail "Duplicate argument '%s' in query string." name
+            | (Parsed (Single f, None)) -> begin
+                match f.ty.destruct value with
                 | Error error ->
                     fail "Failed to parse argument '%s' (%S): %s"
                       name value error
-                | Ok v -> StringMap.add name (Parsed (f, Some v)) fields
+                | Ok v -> StringMap.add name (Parsed (Single f, Some v)) fields
+              end
+            | (Parsed (Opt f, None)) -> begin
+                match f.ty.destruct value with
+                | Error error ->
+                    fail "Failed to parse argument '%s' (%S): %s"
+                      name value error
+                | Ok v -> StringMap.add name (Parsed (Opt f, Some (Some v))) fields
+              end
+            | (Parsed (Flag f, None)) -> begin
+                let v =
+                  match String.lowercase_ascii value with
+                  | "no" | "false" -> false
+                  | _ -> true
+                in
+                StringMap.add name (Parsed (Flag f, Some v)) fields
+              end
+            | (Parsed (Multi f, previous)) -> begin
+                match f.ty.destruct value with
+                | Error error ->
+                    fail "Failed to parse argument '%s' (%S): %s"
+                      name value error
+                | Ok v ->
+                    let v =
+                      match previous with
+                      | None -> [v]
+                      | Some l -> v :: l in
+                    StringMap.add name (Parsed (Multi f, Some v)) fields
+              end
           end
           fields query in
       rebuild fields fs f
@@ -329,6 +432,12 @@ module Description = struct
     |+ field "recurse" Arg.bool false (fun t -> t.recurse)
     |> seal
 
+  type nonrec query_kind = query_kind =
+    | Single of Arg.descr
+    | Optional of Arg.descr
+    | Flag
+    | Multi of Arg.descr
+
   type 'schema service = {
     description: string option ;
     path: path_item list ;
@@ -347,6 +456,7 @@ module Description = struct
   and query_item = {
     name: string ;
     description: string option ;
+    kind: query_kind ;
   }
 
   type 'schema directory =
@@ -576,8 +686,27 @@ module MakeService(Encoding : ENCODING) = struct
     = fun (Fields (fields, _)) q ->
       let rec loop : type t. (q, t) query_fields -> _ = function
         | F0 -> []
-        | F1 ({ fname ; ftype ; fget ; _ }, fields) ->
+        | F1 (Single { name ; ty ; get ; _ }, fields) ->
-            (fname, ftype.construct (fget q)) :: loop fields in
+            (name, ty.construct (get q)) :: loop fields
+        | F1 (Opt { name ; ty ; get ; _ }, fields) -> begin
+            match get q with
+            | None -> loop fields
+            | Some v -> (name, ty.construct v) :: loop fields
+          end
+        | F1 (Flag { name ; get ; _ }, fields) -> begin
+            match get q with
+            | false -> loop fields
+            | true -> (name, "true") :: loop fields
+          end
+        | F1 (Multi { name ; ty ; get ; _ }, fields) -> begin
+            match get q with
+            | [] -> loop fields
+            | l ->
+                List.fold_right
+                  (fun v acc -> (name, ty.construct v) :: acc)
+                  l
+                  (loop fields)
+          end in
       loop fields
 
   let forge_request

vendors/ocplib-resto/lib_resto/resto.mli

@@ -104,8 +104,15 @@ module Description : sig
   and query_item = {
     name: string ;
     description: string option ;
+    kind: query_kind ;
   }
 
+  and query_kind =
+    | Single of Arg.descr
+    | Optional of Arg.descr
+    | Flag
+    | Multi of Arg.descr
+
   type 'schema directory =
     | Empty
     | Static of 'schema static_directory
@@ -137,6 +144,15 @@ module Query : sig
   val field:
     ?descr: string ->
     string -> 'a Arg.t -> 'a -> ('b -> 'a) -> ('b, 'a) field
+  val opt_field:
+    ?descr: string ->
+    string -> 'a Arg.t -> ('b -> 'a option) -> ('b, 'a option) field
+  val flag:
+    ?descr: string ->
+    string -> ('b -> bool) -> ('b, bool) field
+  val multi_field:
+    ?descr: string ->
+    string -> 'a Arg.t -> ('b -> 'a list) -> ('b, 'a list) field
 
   type ('a, 'b, 'c) open_query
   val query: 'b -> ('a, 'b, 'b) open_query
@@ -198,17 +214,31 @@ module Internal : sig
     | F1: ('a, 'b) query_field * ('a, 'c) query_fields ->
       ('a, 'b -> 'c) query_fields
 
-  and ('a, 'b) query_field = {
+  and ('a, 'b) query_field =
-    fname : string ;
+    | Single : {
-    ftype : 'b arg ;
+        name : string ; description : string option ;
-    fdefault : 'b ;
+        ty : 'b arg ; default : 'b ; get : 'a -> 'b ;
-    fget : 'a -> 'b ;
+      } -> ('a, 'b) query_field
-    fdescription : string option ;
+    | Opt : {
-  }
+        name : string ; description : string option ;
+        ty : 'b arg ; get : 'a -> 'b option ;
+      } -> ('a, 'b option) query_field
+    | Flag : {
+        name : string ; description : string option ;
+        get : 'a -> bool ;
+      } -> ('a, bool) query_field
+    | Multi : {
+        name : string ; description : string option ;
+        ty : 'b arg ; get : 'a -> 'b list ;
+      } -> ('a, 'b list) query_field
 
   val from_query : 'a query -> 'a Query.t
   val to_query : 'a Query.t -> 'a query
 
+  val field_name : ('a, 'b) query_field -> string
+  val field_description : ('a, 'b) query_field -> string option
+  val field_kind : ('a, 'b) query_field -> Description.query_kind
+
 end
 
 (**/**)