balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Resto: allow optional/multi argument in query string

Browse Source
This commit is contained in:
Grégoire Henry 2017-12-08 16:53:24 +01:00 committed by Benjamin Canou
parent 26d1c463f9
commit 02fd021aa9
5 changed files with 242 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
lib_node_services/RPC.ml
View File

@ -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) -> {name ; description})
(obj2 (req "name" string) (opt "description" string))
(fun { name ; description ; kind } -> (name, description, kind))
(fun (name, description, kind) -> { name ; description ; kind })
(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))

5
vendors/ocplib-resto/lib_resto-directory/resto_directory.ml vendored
View File

@ -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 = f.fdescription } :: loop fs in
{ Description.name = field_name f ;
description = field_description f ;
kind = field_kind f } :: loop fs in
loop fields

30
vendors/ocplib-resto/lib_resto-json/resto_json.ml vendored
View File

@ -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) -> {name ; description})
(obj2 (req "name" string) (opt "description" string))
(fun {name ; description ; kind} -> (name, description, kind))
(fun (name, description, kind) -> {name ; description ; kind})
(obj3
(req "name" string)
(opt "description" string)
(req "kind" query_kind_encoding))
let service_descr_encoding =
let open Json_encoding in

173
vendors/ocplib-resto/lib_resto/resto.ml vendored
View File

@ -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 = {
fname : string ;
ftype : 'b arg ;
fdefault : 'b ;
fget : 'a -> 'b ;
fdescription : string option ;
}
and ('a, 'b) query_field =
| Single : {
name : string ; description : string option ;
ty : 'b arg ; default : 'b ; get : 'a -> 'b ;
} -> ('a, 'b) query_field
| 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 =
{ fname; ftype; fdefault ; fget ; fdescription = descr }
let field ?descr name ty default get : (_,_) query_field =
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) ->
let Parsed (field', v) = StringMap.find field.fname map in
let Ty.Eq = Ty.eq field.ftype.id field'.ftype.id in
let v = match v with None -> field.fdefault | Some v -> v in
rebuild map fs (f v)
| F1 (Single field, fs) -> begin
match StringMap.find field.name map with
| Parsed (Single field', v) ->
let Ty.Eq = Ty.eq field.ty.id field'.ty.id in
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 _)) ->
(* TODO add an option to parse multiple as list. *)
| (Parsed (Single f, Some _)) ->
fail "Duplicate argument '%s' in query string." name
| (Parsed (f, None)) ->
match f.ftype.destruct value with
| (Parsed (Opt f, Some _)) ->
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) ->
(fname, ftype.construct (fget q)) :: loop fields in
| F1 (Single { name ; ty ; get ; _ }, fields) ->
(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

44
vendors/ocplib-resto/lib_resto/resto.mli vendored
View File

@ -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 = {
fname : string ;
ftype : 'b arg ;
fdefault : 'b ;
fget : 'a -> 'b ;
fdescription : string option ;
}
and ('a, 'b) query_field =
| Single : {
name : string ; description : string option ;
ty : 'b arg ; default : 'b ; get : 'a -> 'b ;
} -> ('a, 'b) query_field
| 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
(**/**)