Add caqti example

.ocamlformat-ignore

@@ -0,0 +1 @@
+examples/**/*

TODO.md

@@ -1,6 +1,24 @@
 - [x] be able to load *.cmx{,a} when we use "#require"
   `findlib`/`topfind` only loads directories, `ocamlnat` wants to load files.
   Let's use our work about `uniq` to solve dependencies and load artifacts
+  + [ ] lint the way we load dependencies
+  + [ ] compare to what `omod` can do (may be a better approach)
 - [x] do some tests with Miou and see if we can execute small applications
-- [ ] start to eval a file (and show the result?)
+- [x] start to eval a file (and show the result?)
-- [ ] start to make a nice intf for a HTTP server via `httpcats`
+  + [ ] do we need to show the result?
+- [x] start to make a nice intf for a HTTP server via `httpcats`
+  + [x] provide Request
+  + [x] provide Response
+  + [x] provide Method
+  + [x] provide Status
+- [ ] dispatch on method and content-type
+  + [x] recognize application/json
+  + [ ] recognize multipart/form
+    * [ ] provide an API to describe, by types, a multipart/form
+- [x] be able to extract the body of a request as a JSON value
+  + [x] cast a JSON value to an OCaml value via Json_encoding (or repr?)
+  + [ ] lint this function and errors
+- [ ] template engine with jingoo or eml?
+  + [ ] with jingoo, do something "à la printf" and provide a tool which generates
+        from a string something like `(_, _, _, _) format4`
+  + [ ] jingoo to GADT?

bin/vif.ml

@@ -150,7 +150,12 @@ let setup_logs = Term.(const setup_logs $ utf_8 $ renderer $ verbosity)
 
 let term =
   let open Term in
-  const run $ setup_logs $ Vif.setup_config $ Vif_meta.setup $ setup_stdlib $ main
+  const run
+  $ setup_logs
+  $ Vif.setup_config
+  $ Vif_meta.setup
+  $ setup_stdlib
+  $ main
 
 let cmd =
   let doc = "vif" in

examples/01-hello/main.ml

@@ -4,7 +4,4 @@ let default req target server () =
   Vif.Response.with_string server `OK "Hello World!\n"
 ;;
 
-let () =
+let () = Miou_unix.run @@ fun () -> Vif.run ~default [] () ;;
-  Miou_unix.run @@ fun () ->
-  Vif.run ~default [] ()
-;;

examples/02-counter/main.ml

@@ -8,7 +8,4 @@ let default req target server () =
   Vif.Response.with_string server `OK (Fmt.str "%d request(s)\n" (succ v))
 ;;
 
-let () =
+let () = Miou_unix.run @@ fun () -> Vif.run ~default [] () ;;
-  Miou_unix.run @@ fun () ->
-  Vif.run ~default [] ()
-;;

examples/03-fail/main.ml

@@ -1,15 +1,7 @@
 #require "vif" ;;
 
-exception Foo
+exception Foo ;;
-
-let () = Printexc.register_printer @@ function
-  | Foo -> Some "Foo"
-  | _ -> None
-;;
 
+let () = Printexc.register_printer @@ function Foo -> Some "Foo" | _ -> None ;;
 let default req target server () = raise Foo ;;
-
+let () = Miou_unix.run @@ fun () -> Vif.run ~default [] () ;;
-let () =
-  Miou_unix.run @@ fun () ->
-  Vif.run ~default [] ()
-;;

examples/04-device/main.ml

@@ -4,16 +4,14 @@
 let rng =
   let open Mirage_crypto_rng_miou_unix in
   let finally = kill in
-  Vif.D.device ~name:"rng" ~finally [] @@ fun () ->
+  Vif.D.device ~name:"rng" ~finally [] @@ fun () -> initialize (module Pfortuna)
-  initialize (module Pfortuna)
 ;;
 
 type foo = Foo ;;
 
 let foo =
   let finally Foo = () in
-  Vif.D.device ~name:"foo" ~finally [] @@ fun () ->
+  Vif.D.device ~name:"foo" ~finally [] @@ fun () -> Foo
-  Foo
 ;;
 
 let default req target server () =
@@ -23,6 +21,5 @@ let default req target server () =
 ;;
 
 let () =
-  Miou_unix.run @@ fun () ->
+  Miou_unix.run @@ fun () -> Vif.run ~default ~devices:Vif.Ds.[ rng; foo ] [] ()
-    Vif.run ~default ~devices:Vif.Ds.[ rng; foo ] [] ()
 ;;

examples/05-json/main.ml

@@ -14,20 +14,29 @@ let foo =
   let age = opt "age" int in
   let address = opt "address" string in
   let foo = obj4 username password age address in
-  let prj { username; password; age; address } = (username, password, age, address) in
+  let prj { username; password; age; address } =
-  let inj (username, password, age, address) = { username; password; age; address } in
+    (username, password, age, address)
+  in
+  let inj (username, password, age, address) =
+    { username; password; age; address }
+  in
   conv prj inj foo
 ;;
 
 let deserialize req server () =
   match Vif.Request.to_json req with
   | Ok (foo : foo) ->
-      let str = Fmt.str "username: %s, password: %s, age: %a, address: %a\n"
+      let str =
-        foo.username foo.password Fmt.(Dump.option int) foo.age
+        Fmt.str "username: %s, password: %s, age: %a, address: %a\n"
-        Fmt.(Dump.option string) foo.address in
+          foo.username foo.password
+          Fmt.(Dump.option int)
+          foo.age
+          Fmt.(Dump.option string)
+          foo.address
+      in
       Vif.Response.with_string server `OK str
-  | Error (`Msg msg) ->
+  | Error (`Msg msg) -> Vif.Response.with_string server (`Code 422) msg
-      Vif.Response.with_string server (`Code 422) msg
+;;
 
 let routes =
   let open Vif.U in
@@ -41,7 +50,4 @@ let default req target server () =
   Vif.Response.with_string server `Not_found str
 ;;
 
-let () =
+let () = Miou_unix.run @@ fun () -> Vif.run ~default routes () ;;
-  Miou_unix.run @@ fun () ->
-  Vif.run ~default routes ()
-;;

examples/06-caqti/main.ml

@@ -0,0 +1,64 @@
+#require "caqti-miou" ;;
+#require "caqti-miou.unix" ;;
+#require "caqti-driver-sqlite3" ;;
+#require "vif" ;;
+
+type cfg =
+  { sw : Caqti_miou.Switch.t
+  ; uri : Uri.t }
+;;
+
+let caqti =
+  let finally (module Conn : Caqti_miou.CONNECTION) = Conn.disconnect () in
+  Vif.D.device ~name:"caqti" ~finally [] @@ fun { sw; uri } ->
+  match Caqti_miou_unix.connect ~sw uri with
+  | Ok conn -> conn
+  | Error err ->
+      Logs.err (fun m -> m "%a" Caqti_error.pp err);
+      Fmt.failwith "%a" Caqti_error.pp err
+;;
+
+open Caqti_request.Infix ;;
+
+let add req n server _cfg =
+  let (module Conn) = Vif.S.device caqti server in
+  let req = Caqti_type.(int ->. unit) ("INSERT INTO t (f) VALUES (?)") in
+  match Conn.exec req n with
+  | Ok () ->
+    Vif.Response.with_string server `OK (Fmt.str "%d Added\n" n)
+  | Error err ->
+    let str = Fmt.str "SQL error: %a" Caqti_error.pp err in
+    Vif.Response.with_string server `Internal_server_error str
+;;
+
+let list req server _cfg =
+  let (module Conn) = Vif.S.device caqti server in
+  let req = Caqti_type.(unit ->* int) ("SELECT f FROM t") in
+  match Conn.collect_list req () with
+  | Ok lst ->
+    let str = Fmt.str "%a" Fmt.(Dump.list int) lst in
+    Vif.Response.with_string server `OK str
+  | Error err ->
+    let str = Fmt.str "SQL error: %a" Caqti_error.pp err in
+    Vif.Response.with_string server `Internal_server_error str
+;;
+
+let default req target server _ =
+  let str = Fmt.str "%s not found\n" target in
+  Vif.Response.with_string server `Not_found str
+;;
+
+let routes =
+  let open Vif.U in
+  let open Vif.R in
+  let open Vif.Content_type in
+  [ post any (rel / "add" /% Tyre.int /?? nil) --> add
+  ; get (rel /?? nil) --> list ]
+
+let () =
+  Miou_unix.run @@ fun () ->
+  Caqti_miou.Switch.run @@ fun sw ->
+  let uri = Uri.of_string "sqlite3:foo.sqlite?create=false" in
+  let cfg = { sw; uri } in
+  Vif.run ~default ~devices:Vif.Ds.[ caqti ] routes cfg
+;;

lib/meta/objinfo.ml

@@ -1,4 +1,4 @@
-let src = Logs.Src.create "uniq.info"
+let src = Logs.Src.create "vif.top.info"
 
 module Log = (val Logs.src_log src : Logs.LOG)
 

lib/meta/vif_meta.ml

@@ -85,10 +85,28 @@ let compile ~predicates t ks =
     in
     List.exists one ps
   in
-  let rec go acc t = function
+  let find_directory contents =
+    let rec go result = function
+      | [] -> result
+      | Add { name= "directory"; predicates= []; value } :: rest ->
+          if Option.is_none result then go (Some value) rest else go result rest
+      | Add { name= "directory"; predicates; value } :: rest ->
+          if incl predicates && Option.is_none result then go (Some value) rest
+          else go result rest
+      | Set { name= "directory"; predicates= []; value } :: rest ->
+          go (Some value) rest
+      | Set { name= "directory"; predicates; value } :: rest ->
+          if incl predicates then go (Some value) rest else go result rest
+      | _ :: rest -> go result rest
+    in
+    go None contents
+  in
+  let rec go ~directory acc t = function
     | [] ->
         let rec go acc = function
-          | [] -> acc
+          | [] ->
+              let acc = List.remove_assoc "directory" acc in
+              ("directory", [ directory ]) :: acc
           | Node _ :: rest -> go acc rest
           | Add { name; predicates= []; value } :: rest ->
               go (Assoc.add name value acc) rest
@@ -102,14 +120,21 @@ let compile ~predicates t ks =
               else go acc rest
         in
         go acc t
-    | k :: ks -> (
+    | k :: ks -> begin
         match t with
         | [] -> acc
         | Node { name= "package"; value; contents } :: rest ->
-            if k = value then go acc contents ks else go acc rest (k :: ks)
+            let directory' =
-        | _ :: rest -> go acc rest (k :: ks))
+              match find_directory contents with
+              | Some v -> Filename.concat directory v
+              | None -> directory
             in
-  go [] t ks
+            if k = value then go ~directory:directory' acc contents ks
+            else go ~directory acc rest (k :: ks)
+        | _ :: rest -> go ~directory acc rest (k :: ks)
+      end
+  in
+  go ~directory:"" [] t ks
 
 exception Parser_error of string
 
@@ -328,7 +353,11 @@ let search ~roots ?(predicates = [ "native"; "byte" ]) meta_path =
       diff meta_path meta_path' >>= fun ks ->
       parser path >>| fun meta -> compile ~predicates meta ks
     with
-    | Ok descr -> Map.add (root / Filename.dirname rel) descr acc
+    | Ok descr ->
+        Log.debug (fun m -> m "add %s" (root / Filename.dirname rel));
+        Log.debug (fun m ->
+            m "%a" Fmt.(Dump.list (Dump.pair string (Dump.list string))) descr);
+        Map.add (root / Filename.dirname rel) descr acc
     | Error (`Msg msg) ->
         Log.warn (fun m ->
             m "Impossible to extract the META file of %s: %s" path msg);

lib/top/vif_top.ml

@@ -157,7 +157,8 @@ let load cfg str =
       let fn artifact =
         let dir = Filename.dirname artifact in
         Topdirs.dir_directory dir;
-        try Topdirs.dir_load null artifact with _ -> ()
+        try Topdirs.dir_load null artifact
+        with exn -> Log.err (fun m -> m "exn: %s" (Printexc.to_string exn))
       in
       List.iter fn artifacts
   | Error (`Msg msg) -> Log.err (fun m -> m "Impossible to load %S: %s" str msg)

lib/vif/vif.ml

@@ -9,11 +9,11 @@ module R = struct
   open Vif_content_type
 
   type ('fu, 'return) t =
-    | Handler : ('f, 'x) body * ('x, 'r) Vif_u.t -> ('f, 'r) t
+    | Handler : ('f, 'x) Vif_r.req * ('x, 'r) Vif_u.t -> ('f, 'r) t
 
-  let get t = Handler (Body Null, t)
+  let get t = Handler (Request (Some `GET, Null), t)
-  let post body t = Handler (Body body, t)
+  let post c t = Handler (Request (Some `POST, c), t)
-  let route (Handler (body, t)) f = Route (body, t, f)
+  let route (Handler (req, t)) f = Route (req, t, f)
   let ( --> ) = route
 end
 
@@ -55,62 +55,78 @@ module Response = Vif_response
 let is_application_json { Multipart_form.Content_type.ty; subty; _ } =
   match (ty, subty) with `Application, `Iana_token "json" -> true | _ -> false
 
+let content_type server =
+  let headers =
+    match server.S.reqd with
+    | `V1 reqd ->
+        let request = H1.Reqd.request reqd in
+        H1.Headers.to_list request.H1.Request.headers
+    | `V2 reqd ->
+        let request = H2.Reqd.request reqd in
+        H2.Headers.to_list request.H2.Request.headers
+  in
+  let c = List.assoc_opt "content-type" headers in
+  let c = Option.map (fun c -> c ^ "\r\n") c in
+  let c = Option.to_result ~none:`Not_found c in
+  Result.bind c Multipart_form.Content_type.of_string
+
+let method_of_request server =
+  match server.S.reqd with
+  | `V1 reqd -> ((H1.Reqd.request reqd).H1.Request.meth :> H2.Method.t)
+  | `V2 reqd -> ((H2.Reqd.request reqd).H2.Request.meth :> H2.Method.t)
+
 let request server =
   let extract : type c a.
-      (c, a) Vif_content_type.t -> (c, a) Vif_request.t option = function
+         Vif_method.t option
-    | Vif_content_type.Any as encoding ->
+      -> (c, a) Vif_content_type.t
+      -> (c, a) Vif_request.t option =
+   fun meth c ->
+    let meth' = method_of_request server in
+    match (meth, meth', c) with
+    | None, _, (Vif_content_type.Any as encoding) ->
         Some (Vif_request.of_reqd ~encoding server.S.reqd)
-    | Null as encoding -> Some (Vif_request.of_reqd ~encoding server.S.reqd)
+    | Some a, b, (Vif_content_type.Any as encoding) ->
-    | Json_encoding _ as encoding ->
+        if a = b then Some (Vif_request.of_reqd ~encoding server.S.reqd)
-        let headers =
+        else None
-          match server.S.reqd with
+    | None, _, (Null as encoding) ->
-          | `V1 reqd ->
-              let request = H1.Reqd.request reqd in
-              H1.Headers.to_list request.H1.Request.headers
-          | `V2 reqd ->
-              let request = H2.Reqd.request reqd in
-              H2.Headers.to_list request.H2.Request.headers
-        in
-        let c = List.assoc_opt "content-type" headers in
-        let c = Option.map (fun c -> c ^ "\r\n") c in
-        let c = Option.to_result ~none:`Not_found c in
-        let c = Result.bind c Multipart_form.Content_type.of_string in
-        begin
-          match c with
-          | Ok c when is_application_json c ->
         Some (Vif_request.of_reqd ~encoding server.S.reqd)
-          | _ -> None
+    | Some a, b, (Null as encoding) ->
-        end
+        if a = b then Some (Vif_request.of_reqd ~encoding server.S.reqd)
-    | Json as encoding ->
+        else None
-        let headers =
+    | None, _, (Json_encoding _ as encoding) ->
-          match server.S.reqd with
+        let c = content_type server in
-          | `V1 reqd ->
+        let application_json = Result.map is_application_json c in
-              let request = H1.Reqd.request reqd in
+        let application_json = Result.value ~default:false application_json in
-              H1.Headers.to_list request.H1.Request.headers
+        if application_json then
-          | `V2 reqd ->
-              let request = H2.Reqd.request reqd in
-              H2.Headers.to_list request.H2.Request.headers
-        in
-        let c = List.assoc_opt "content-type" headers in
-        let c = Option.map (fun c -> c ^ "\r\n") c in
-        let c = Option.to_result ~none:`Not_found c in
-        let c = Result.bind c Multipart_form.Content_type.of_string in
-        Log.debug (fun m ->
-            m "content-type: %a"
-              Fmt.(
-                Dump.result ~ok:Multipart_form.Content_type.pp
-                  ~error:(any "#errored"))
-              c);
-        begin
-          match c with
-          | Ok c when is_application_json c ->
           Some (Vif_request.of_reqd ~encoding server.S.reqd)
-          | _ -> None
+        else None
-        end
+    | Some a, b, (Json_encoding _ as encoding) ->
+        let c = content_type server in
+        let application_json = Result.map is_application_json c in
+        let application_json = Result.value ~default:false application_json in
+        if application_json && a = b then
+          Some (Vif_request.of_reqd ~encoding server.S.reqd)
+        else None
+    | None, _, (Json as encoding) ->
+        let c = content_type server in
+        let application_json = Result.map is_application_json c in
+        let application_json = Result.value ~default:false application_json in
+        if application_json then
+          Some (Vif_request.of_reqd ~encoding server.S.reqd)
+        else None
+    | Some a, b, (Json as encoding) ->
+        let c = content_type server in
+        let application_json = Result.map is_application_json c in
+        let application_json = Result.value ~default:false application_json in
+        if application_json && a = b then
+          Some (Vif_request.of_reqd ~encoding server.S.reqd)
+        else None
   in
   { Vif_r.extract }
 
-let handler ~default routes devices user's_value = (); fun socket reqd ->
+let handler ~default routes devices user's_value =
+  ();
+  fun socket reqd ->
     let target =
       match reqd with
       | `V1 reqd -> (H1.Reqd.request reqd).H1.Request.target
@@ -132,8 +148,8 @@ let handle stop cfg fn =
       m "new HTTP server on [%d]" (Stdlib.Domain.self () :> int));
   match (cfg.Vif_config.http, cfg.Vif_config.tls) with
   | config, Some tls ->
-      Httpcats.Server.with_tls ?stop ?config ~backlog:cfg.backlog tls ~handler:fn
+      Httpcats.Server.with_tls ?stop ?config ~backlog:cfg.backlog tls
-        cfg.sockaddr
+        ~handler:fn cfg.sockaddr
   | Some (`H2 _), None ->
       failwith "Impossible to launch an h2 server without TLS."
   | Some (`Both (config, _) | `HTTP_1_1 config), None ->
@@ -142,7 +158,8 @@ let handle stop cfg fn =
       Log.debug (fun m -> m "Start a non-tweaked HTTP/1.1 server");
       Httpcats.Server.clear ?stop ~handler:fn cfg.sockaddr
 
-let run ?(cfg= Vif_options.config_from_globals ()) ?(devices = Ds.[]) ~default routes user's_value =
+let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[]) ~default
+    routes user's_value =
   let interactive = !Sys.interactive in
   let domains = Miou.Domain.available () in
   let stop =
@@ -162,8 +179,12 @@ let run ?(cfg= Vif_options.config_from_globals ()) ?(devices = Ds.[]) ~default r
   Logs.debug (fun m -> m "devices launched");
   let fn0 = handler ~default routes devices user's_value in
   let prm = Miou.async @@ fun () -> handle stop cfg fn0 in
-  let tasks = List.init domains (fun _ -> handler ~default routes devices user's_value) in
+  let tasks =
-  let tasks = if domains > 0 then Miou.parallel (handle stop cfg) tasks else [] in
+    List.init domains (fun _ -> handler ~default routes devices user's_value)
+  in
+  let tasks =
+    if domains > 0 then Miou.parallel (handle stop cfg) tasks else []
+  in
   Miou.await_exn prm;
   List.iter (function Ok () -> () | Error exn -> raise exn) tasks;
   Ds.finally (Vif_d.Devices devices);

lib/vif/vif_options.ml

@@ -1,5 +1,4 @@
 let error_msgf fmt = Fmt.kstr (fun msg -> Error (`Msg msg)) fmt
-
 let port = ref 8080
 let inet_addr = ref Unix.inet_addr_loopback
 let backlog = ref 64
@@ -24,14 +23,19 @@ let inet_addr =
   let doc = "The address to bind the HTTP server." in
   let parser str =
     try Ok (Unix.inet_addr_of_string str)
-    with _ -> error_msgf "Invalid inet-addr: %S" str in
+    with _ -> error_msgf "Invalid inet-addr: %S" str
+  in
   let pp ppf inet_addr = Fmt.string ppf (Unix.string_of_inet_addr inet_addr) in
   let inet_addr = Arg.conv (parser, pp) in
   let open Arg in
-  value & opt inet_addr Unix.inet_addr_loopback & info [ "i"; "inet-addr" ] ~doc ~docv:"INET_ADDR"
+  value
+  & opt inet_addr Unix.inet_addr_loopback
+  & info [ "i"; "inet-addr" ] ~doc ~docv:"INET_ADDR"
 
 let backlog =
-  let doc = "The limit of outstanding connections in the socket's listen queue." in
+  let doc =
+    "The limit of outstanding connections in the socket's listen queue."
+  in
   let open Arg in
   value & opt int 64 & info [ "backlog" ] ~doc ~docv:"NUMBER"
 

lib/vif/vif_r.ml

@@ -206,36 +206,40 @@ let extract t =
     extract ~original:target url subs f
 *)
 
-type ('fu, 'return) body =
+type ('fu, 'return) req =
-  | Body :
+  | Request :
-      ('c, 'a) Vif_content_type.t
+      Vif_method.t option * ('c, 'a) Vif_content_type.t
-      -> (('c, 'a) Vif_request.t -> 'r, 'r) body
+      -> (('c, 'a) Vif_request.t -> 'r, 'r) req
 
-type 'r route = Route : ('f, 'x) body * ('x, 'r) Vif_u.t * 'f -> 'r route
+type 'r route = Route : ('f, 'x) req * ('x, 'r) Vif_u.t * 'f -> 'r route
 
-let route body t f = Route (body, t, f)
+let route req t f = Route (req, t, f)
 
-type 'r re = Re : ('f, 'x) body * 'f * Re.Mark.t * ('x, 'r) t -> 'r re
+type 'r re = Re : ('f, 'x) req * 'f * Re.Mark.t * ('x, 'r) t -> 'r re
 
 let rec build_info_list idx = function
   | [] -> ([], [])
-  | Route (b, t, f) :: l ->
+  | Route (req, t, f) :: l ->
       let idx, ret, re = url idx t in
       let rel, wl = build_info_list idx l in
       let id, re = Re.mark re in
-      (re :: rel, Re (b, f, id, ret) :: wl)
+      (re :: rel, Re (req, f, id, ret) :: wl)
 
 type request = {
-    extract: 'c 'a. ('c, 'a) Vif_content_type.t -> ('c, 'a) Vif_request.t option
+    extract:
+      'c 'a.
+         Vif_method.t option
+      -> ('c, 'a) Vif_content_type.t
+      -> ('c, 'a) Vif_request.t option
 }
 
 let rec find_and_trigger : type r.
     original:string -> request:request -> Re.Group.t -> r re list -> r =
  fun ~original ~request subs -> function
   | [] -> raise Not_found
-  | Re (Body body, f, id, ret) :: l ->
+  | Re (Request (meth, c), f, id, ret) :: l ->
       if Re.Mark.test subs id then
-        match request.extract body with
+        match request.extract meth c with
         | Some request -> extract ~original ret subs (f request)
         | None -> find_and_trigger ~original ~request subs l
       else find_and_trigger ~original ~request subs l
@@ -253,7 +257,7 @@ let dispatch : type r c.
     match Re.exec_opt re target with
     | None ->
         Log.debug (fun m -> m "Fallback to the default route");
-        let[@warning "-8"] (Some request) = request.extract Any in
+        let[@warning "-8"] (Some request) = request.extract None Any in
         default request target
     | Some subs -> begin
         try find_and_trigger ~original:target ~request subs wl
@@ -261,6 +265,6 @@ let dispatch : type r c.
           Log.debug (fun m ->
               m "Fallback to the default route (exn: %s)"
                 (Printexc.to_string exn));
-          let[@warning "-8"] (Some request) = request.extract Any in
+          let[@warning "-8"] (Some request) = request.extract None Any in
           default request target
       end