Merge pull request #120 from maxtori/fix-register-bug

Revamp register of services

src/common/doc.ml

@@ -9,13 +9,12 @@
 (**************************************************************************)
 
 type t = {
-  doc_id : int; (* uniq service identifier *)
+  mutable doc_id : int; (* uniq service identifier *)
   doc_name : string option;
   doc_descr : string option;
   doc_path : string;
   doc_args : Arg.descr list;
   doc_params : Param.t list;
-  mutable doc_registered : bool;
   doc_section : section;
   doc_input : Json_schema.schema Lazy.t option;
   doc_output : Json_schema.schema Lazy.t option;
@@ -25,29 +24,24 @@ type t = {
   doc_security : Security.scheme list;
   doc_input_example : Json_repr.any option;
   doc_output_example : Json_repr.any option;
+  doc_hide : bool;
+  doc_register : bool;
 }
 
 and section = {
   section_name : string;
   mutable section_docs : t list;
 }
 
-let services = ref []
-let nservices = ref 0
 let default_section = { section_name = "Misc"; section_docs = [] }
 let sections = ref [ default_section ]
 
 let definitions_path = "/components/schemas/"
 
-let rec update_service_list services doc = match services with
-  | [] -> [ doc ]
-  | h :: t when h.doc_path = doc.doc_path -> doc :: t
-  | h :: t -> h :: (update_service_list t doc)
-
 let make :
-  type i. ?name:string -> ?descr:string -> ?register:bool -> ?section:section ->
+  type i. ?name:string -> ?descr:string -> ?register:bool -> ?hide:bool -> ?section:section ->
   ?input_example:i -> ?output_example:'o -> (_, i, 'o, _, _) Service.t -> t =
-  fun ?name ?descr ?(register=true) ?(section=default_section) ?input_example ?output_example s ->
+  fun ?name ?descr ?(register=true) ?(hide=false) ?(section=default_section) ?input_example ?output_example s ->
   let path = Service.path s in
   let input = Service.input s in
   let output = Service.output s in
@@ -67,29 +61,35 @@ let make :
   let doc_output_example = match output_example, output with
     | Some ex, Service.IO.Json enc -> Some (Json_repr.to_any @@ Json_encoding.construct enc ex)
     | _ -> None in
-  let doc_id = if register then (
-      let id = !nservices in
-      incr nservices;
-      id)
-    else -1 in
-  let doc = {
+  {
     doc_path = Path.to_string path;
     doc_args = Path.args path;
     doc_params = Service.params s;
-    doc_registered = false;
-    doc_name = name; doc_descr = descr; doc_id;
+    doc_name = name; doc_descr = descr; doc_id = -1;
     doc_section = section;
     doc_input; doc_mime;
     doc_output;
     doc_errors = Err.merge_errs_same_code ~definitions_path (Service.errors s);
     doc_meth = Service.meth s;
     doc_security = (Service.security s :> Security.scheme list);
-    doc_input_example; doc_output_example
-  } in
-  if register then (
-    section.section_docs <- update_service_list section.section_docs doc;
-    services := update_service_list !services doc);
-  doc
+    doc_input_example; doc_output_example;
+    doc_hide = hide;
+    doc_register = register
+  }
+
+let rec update_service_list services doc = match services with
+  | [] -> [ doc ]
+  | h :: t when h.doc_path = doc.doc_path -> doc :: t
+  | h :: t -> h :: (update_service_list t doc)
+
+let services = ref []
+let nservices = ref 0
+
+let register doc =
+  doc.doc_id <- !nservices;
+  incr nservices;
+  doc.doc_section.section_docs <- update_service_list doc.doc_section.section_docs doc;
+  services := update_service_list !services doc
 
 let section section_name =
   let s = { section_name; section_docs = [] } in
@@ -98,7 +98,7 @@ let section section_name =
 
 let all_services_registered () =
   let s = List.fold_left (fun acc doc ->
-      if not doc.doc_registered then
+      if doc.doc_id = -1 && doc.doc_register then
         Printf.sprintf "%s%s is not registered\n" acc doc.doc_path
       else acc
     ) "" !services in

src/common/ezAPI.ml

@@ -108,18 +108,18 @@ let forge2 url s arg1 arg2 params =  forge url s ((Req.dummy, arg1), arg2) param
 let raw_service :
   type i. ?section:Doc.section -> ?name:string -> ?descr:string -> ?meth:Meth.t ->
   input:i io -> output:'o io -> ?errors:'e Err.case list -> ?params:Param.t list ->
-  ?security:'s list -> ?access_control:(string * string) list -> ?register:bool -> 
-  ?input_example:i -> ?output_example:'o -> (Req.t, 'a) Path.t -> 
+  ?security:'s list -> ?access_control:(string * string) list -> ?register:bool -> ?hide:bool ->
+  ?input_example:i -> ?output_example:'o -> (Req.t, 'a) Path.t ->
   ('a, i, 'o, 'e, 's) service =
   fun ?section ?name ?descr ?meth ~input ~output ?(errors=[]) ?(params=[])
-    ?(security=[]) ?access_control ?register ?input_example ?output_example path ->
+    ?(security=[]) ?access_control ?register ?hide ?input_example ?output_example path ->
   let meth = match meth, input with
     | None, Empty -> `GET
     | None, _ -> `POST
     | Some m, _ -> m in
   let s = Service.make ~meth ~input ~output
       ~errors ~params ~security ?access_control path in
-  let doc = Doc.make ?name ?descr ?register ?section ?input_example ?output_example s in
+  let doc = Doc.make ?name ?descr ?section ?input_example ?output_example ?hide ?register s in
   { s; doc }
 
 let post_service ?section ?name ?descr ?(meth=`POST)
@@ -140,7 +140,7 @@ let ws_service ?section ?name ?descr ~input ~output ?errors ?params
     ?errors ~meth:`GET ?params ?security ?access_control ?register ?output_example path
 
 let register service =
-  service.doc.Doc.doc_registered <- true;
+  Doc.register service.doc;
   service.s
 
 let id s = s.doc.Doc.doc_id

src/ppx/ppx_common.ml

@@ -37,6 +37,7 @@ type options = {
   descr : expression;
   security : expression;
   register : expression;
+  hide : expression;
   input_example : expression;
   output_example : expression;
   error_type : core_type;
@@ -63,7 +64,7 @@ let options ?register loc =
   path = pexp_ident ~loc (llid ~loc "EzAPI.Path.root");
   input = empty ~loc; output = empty ~loc; errors = enone ~loc; params = enone ~loc;
   section = enone ~loc; name = enone ~loc; descr = enone ~loc;
-  security = enone ~loc; register; input_example = enone ~loc;
+  security = enone ~loc; register; input_example = enone ~loc; hide = enone ~loc;
   output_example = enone ~loc; error_type = ptyp_constr ~loc (llid ~loc "exn") [];
   security_type = ptyp_constr ~loc (llid ~loc "EzAPI.no_security") [];
   debug = false; directory = None; service = None
@@ -134,6 +135,7 @@ let get_options ~loc ?name ?(client=false) a =
         | "descr" -> name, { acc with descr = esome e }
         | "security" -> name, { acc with security = esome e; security_type = ptyp_any ~loc }
         | "register" -> name, { acc with register = e }
+        | "hide" -> name, { acc with hide = e }
         | "input_example" -> name, { acc with input_example = esome e }
         | "output_example" -> name, { acc with output_example = esome e }
         | "debug" -> name, { acc with debug = true }

src/server/ezAPIServerUtils.ml

@@ -63,16 +63,18 @@ let register_res service handler dir =
   let security = Service.security service.s in
   let path = Service.path service.s in
   let handler args input =
-    let t0 = (Path.get_root path args).Req.req_time in
-    let add_timing_wrap b =
-      let t1 = GMTime.time () in
-      Timings.add_timing (EzAPI.id service) b t0 (t1-.t0) in
-    Lwt.catch
-      (function () ->
-         handler args security input >>= fun res ->
-         add_timing_wrap true;
-         Lwt.return res)
-      (fun exn -> add_timing_wrap true; Lwt.fail exn) in
+    if !Timings.enabled then
+      let t0 = (Path.get_root path args).Req.req_time in
+      let add_timing_wrap b =
+        let t1 = GMTime.time () in
+        Timings.add_timing (EzAPI.id service) b t0 (t1-.t0) in
+      Lwt.catch
+        (function () ->
+           handler args security input >>= fun res ->
+           add_timing_wrap true;
+           Lwt.return res)
+        (fun exn -> add_timing_wrap true; Lwt.fail exn)
+    else handler args security input in
   let service = register service in
   Directory.register_http dir service handler
 
@@ -152,7 +154,7 @@ let handle ?meth ?content_type ?ws s r path body =
 (* Default access control headers *)
 let default_access_control_headers = [
   "access-control-allow-origin", "*";
-  "access-control-allow-headers", "accept, content-type" 
+  "access-control-allow-headers", "accept, content-type"
 ]
 
 (* merge headers correctly with default one *)
@@ -165,7 +167,7 @@ let merge_headers_with_default headers : (string * string) list =
          | Some _ when hn = "access-control-allow-origin" ->
            h::acc
          | Some v when hn = "access-control-allow-headers" ->
-           (hn, hv ^ "," ^ v)::acc 
+           (hn, hv ^ "," ^ v)::acc
          | _ -> acc)
       []
       headers
@@ -174,5 +176,5 @@ let merge_headers_with_default headers : (string * string) list =
   List.fold_left (fun acc ((hn,_) as h) ->
       match List.assoc_opt hn l with
       | None -> h::acc
-      | _ -> acc    
-    ) l default_access_control_headers
+      | _ -> acc
+    ) l default_access_control_headers

src/server/ezOpenAPI.ml

@@ -672,8 +672,10 @@ let make ?descr ?terms ?contact ?license ?(version="0.1") ?servers ?(docs=[])
       List.fold_left (fun acc s -> if List.mem s acc then acc else s :: acc) acc sd.Doc.doc_security)
       [] sds in
   let paths, definitions = List.fold_left (fun (paths, definitions) sd ->
-      let path, definitions = make_path ~definitions ~docs sd in
-      path :: paths, definitions) ([], Json_schema.any) sds in
+      if sd.Doc.doc_hide then (paths, definitions)
+      else
+        let path, definitions = make_path ~definitions ~docs sd in
+        path :: paths, definitions) ([], Json_schema.any) sds in
   let schemas = definitions_schemas definitions in
   let oa = Makers.mk_openapi ?servers ~info
       ~components:(Makers.mk_components ~security ?schemas ())

src/server/timings.ml

@@ -8,6 +8,10 @@
 (*                                                                        *)
 (**************************************************************************)
 
+let enabled = ref false
+let enable () = enabled := true
+let disable () = enabled := false
+
 type period = {
   name : string;
   mutable prev : int;
@@ -125,11 +129,9 @@ let timings = {
 }
 
 let add_timing n ok t dt =
-  if ok then add timings.timings_ok.(n) t dt
-  else add timings.timings_fail.(n) t dt
+  if ok then try add timings.timings_ok.(n) t dt with _ -> ()
+  else try add timings.timings_fail.(n) t dt with _ -> ()
 
 let init t0 nservices =
-  timings.timings_ok <-Array.init nservices
-      (fun _ -> create t0);
-  timings.timings_fail <- Array.init nservices
-      (fun _ -> create t0)
+  timings.timings_ok <- Array.init nservices (fun _ -> create t0);
+  timings.timings_fail <- Array.init nservices (fun _ -> create t0)