robur/vif
4
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Add caqti example

Browse source
This commit is contained in:
Calascibetta Romain 2025-02-02 13:29:07 +01:00
parent 6da50520de
commit da3156fc5e
17 changed files with 277 additions and 141 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.ocamlformat-ignore Normal file
View file

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

22
TODO.md
View file

@ -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?)
- [ ] start to make a nice intf for a HTTP server via `httpcats`
- [x] start to eval a file (and show the result?)
+ [ ] 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?

7
bin/vif.ml
View file

@ -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

5
examples/01-hello/main.ml
View file

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

5
examples/02-counter/main.ml
View file

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

14
examples/03-fail/main.ml
View file

@ -1,15 +1,7 @@
#require "vif" ;;
exception Foo
let () = Printexc.register_printer @@ function
| Foo -> Some "Foo"
| _ -> None
;;
exception Foo ;;
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 [] () ;;

9
examples/04-device/main.ml
View file

@ -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 () ->
initialize (module Pfortuna)
Vif.D.device ~name:"rng" ~finally [] @@ fun () -> initialize (module Pfortuna)
;;
type foo = Foo ;;
let foo =
let finally Foo = () in
Vif.D.device ~name:"foo" ~finally [] @@ fun () ->
Foo
Vif.D.device ~name:"foo" ~finally [] @@ fun () -> Foo
;;
let default req target server () =
@ -23,6 +21,5 @@ let default req target server () =
;;
let () =
Miou_unix.run @@ fun () ->
Vif.run ~default ~devices:Vif.Ds.[ rng; foo ] [] ()
Miou_unix.run @@ fun () -> Vif.run ~default ~devices:Vif.Ds.[ rng; foo ] [] ()
;;

36
examples/05-json/main.ml
View file

@ -1,10 +1,10 @@
#require "vif" ;;
type foo =
{ username : string
; password : string
; age : int option
; address : string option }
{ username: string
; password: string
; age: int option
; address: string option }
;;
let foo =
@ -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 inj (username, password, age, address) = { username; password; age; address } in
let prj { username; password; age; address } =
(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"
foo.username foo.password Fmt.(Dump.option int) foo.age
Fmt.(Dump.option string) foo.address in
let str =
Fmt.str "username: %s, password: %s, age: %a, address: %a\n"
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) ->
Vif.Response.with_string server (`Code 422) msg
| Error (`Msg 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 () =
Miou_unix.run @@ fun () ->
Vif.run ~default routes ()
;;
let () = Miou_unix.run @@ fun () -> Vif.run ~default routes () ;;

BIN
examples/06-caqti/foo.sqlite Normal file
View file

Binary file not shown.

64
examples/06-caqti/main.ml Normal file
View file

@ -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
;;

2
lib/meta/objinfo.ml
View file

@ -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)

43
lib/meta/vif_meta.ml
View file

@ -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)
| _ :: rest -> go acc rest (k :: ks))
let directory' =
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);

3
lib/top/vif_top.ml
View file

@ -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)

135
lib/vif/vif.ml
View file

@ -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 post body t = Handler (Body body, t)
let route (Handler (body, t)) f = Route (body, t, f)
let get t = Handler (Request (Some `GET, Null), t)
let post c t = Handler (Request (Some `POST, c), t)
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_content_type.Any as encoding ->
Vif_method.t option
-> (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)
| Json_encoding _ as encoding ->
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
let c = Result.bind c Multipart_form.Content_type.of_string in
begin
match c with
| Ok c when is_application_json c ->
| Some a, b, (Vif_content_type.Any as encoding) ->
if a = b then Some (Vif_request.of_reqd ~encoding server.S.reqd)
else None
| None, _, (Null as encoding) ->
Some (Vif_request.of_reqd ~encoding server.S.reqd)
| _ -> None
end
| Json as encoding ->
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
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 a, b, (Null as encoding) ->
if a = b then Some (Vif_request.of_reqd ~encoding server.S.reqd)
else None
| None, _, (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 then
Some (Vif_request.of_reqd ~encoding server.S.reqd)
| _ -> None
end
else None
| 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
cfg.sockaddr
Httpcats.Server.with_tls ?stop ?config ~backlog:cfg.backlog tls
~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 = if domains > 0 then Miou.parallel (handle stop cfg) tasks else [] in
let tasks =
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);

12
lib/vif/vif_options.ml
View file

@ -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"

32
lib/vif/vif_r.ml
View file

@ -206,36 +206,40 @@ let extract t =
extract ~original:target url subs f
*)
type ('fu, 'return) body =
| Body :
('c, 'a) Vif_content_type.t
-> (('c, 'a) Vif_request.t -> 'r, 'r) body
type ('fu, 'return) req =
| Request :
Vif_method.t option * ('c, 'a) Vif_content_type.t
-> (('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