diff --git a/README.md b/README.md new file mode 100644 index 0000000..e41c6c7 --- /dev/null +++ b/README.md @@ -0,0 +1,40 @@ +# Vif, a small framework for building a web server from an OCaml script + +**disclaimer**: Please note that this is an experimental project. It's also an +opportunity to build something that can be satisfying for web development. +However, we do not recommend using this project in production. + +Vif is a small program that runs an OCaml script and launches a Web server from +it. The main idea is to be able to set up a typed Web server as quickly as +possible (note that we use [hurl][hurl], an HTTP client in OCaml) +```ocaml +$ opam pin add -y https://github.com/robur-coop/vif +$ opam pin add -y https://github.com/robur-coop/hurl +$ opam install vif hurl +$ cat >main.ml < + Vif.run ~default [] () +;; +EOF +$ vif --pid vif.pid main.ml & +$ hurl http://localhost:8080/ +HTTP/1.1 200 OK + +connection: close +content-length: 13 +content-type: text/html + +Hello World! + +$ kill -SIGINT $(cat vid.pid) +``` + +[hurl]: https://github.com/robur-coop/hurl diff --git a/lib/vif/vif.ml b/lib/vif/vif.ml index f7be52c..6f2885c 100644 --- a/lib/vif/vif.ml +++ b/lib/vif/vif.ml @@ -158,10 +158,18 @@ 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 store_pid = function + | None -> () + | Some v -> + let oc = open_out (Fpath.to_string v) in + output_string oc (string_of_int (Unix.getpid ())); + close_out oc + 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 + store_pid cfg.pid; let stop = match interactive with | true -> diff --git a/lib/vif/vif.mli b/lib/vif/vif.mli index 7a2731b..b07ad71 100644 --- a/lib/vif/vif.mli +++ b/lib/vif/vif.mli @@ -240,7 +240,8 @@ end type config val config : - ?http: + ?pid:Fpath.t + -> ?http: [ `H1 of H1.Config.t | `H2 of H2.Config.t | `Both of H1.Config.t * H2.Config.t ] diff --git a/lib/vif/vif_config.ml b/lib/vif/vif_config.ml index 70830e5..c7b7bc8 100644 --- a/lib/vif/vif_config.ml +++ b/lib/vif/vif_config.ml @@ -7,9 +7,10 @@ type config = { ; tls: Tls.Config.server option ; backlog: int ; sockaddr: Unix.sockaddr + ; pid: Fpath.t option } -let config ?http ?tls ?(backlog = 64) sockaddr = +let config ?pid ?http ?tls ?(backlog = 64) sockaddr = let http = match http with | Some (`H1 cfg) -> Some (`HTTP_1_1 cfg) @@ -17,4 +18,4 @@ let config ?http ?tls ?(backlog = 64) sockaddr = | Some (`Both (h1, h2)) -> Some (`Both (h1, h2)) | None -> None in - { http; tls; backlog; sockaddr } + { http; tls; backlog; sockaddr; pid } diff --git a/lib/vif/vif_options.ml b/lib/vif/vif_options.ml index c9415a3..0eaa7c2 100644 --- a/lib/vif/vif_options.ml +++ b/lib/vif/vif_options.ml @@ -2,15 +2,17 @@ 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 +let pid = ref None -let setup_config port' inet_addr' backlog' = +let setup_config port' inet_addr' backlog' pid' = port := port'; inet_addr := inet_addr'; - backlog := backlog' + backlog := backlog'; + pid := pid' let config_from_globals () = let sockaddr = Unix.(ADDR_INET (!inet_addr, !port)) in - Vif_config.config ~backlog:!backlog sockaddr + Vif_config.config ?pid:!pid ~backlog:!backlog sockaddr open Cmdliner @@ -32,6 +34,22 @@ let inet_addr = & opt inet_addr Unix.inet_addr_loopback & info [ "i"; "inet-addr" ] ~doc ~docv:"INET_ADDR" +let pid = + let doc = "Specify a file to record its process-id in." in + let non_existing_file = + let parser str = + match Fpath.of_string str with + | Ok _ as v when Sys.file_exists str = false -> v + | Ok v -> error_msgf "%a already exists" Fpath.pp v + | Error _ as err -> err + in + Arg.conv (parser, Fpath.pp) + in + let open Arg in + value + & opt (some non_existing_file) None + & info [ "pid-file" ] ~doc ~docv:"PATH" + let backlog = let doc = "The limit of outstanding connections in the socket's listen queue." @@ -41,4 +59,4 @@ let backlog = let setup_config = let open Term in - const setup_config $ port $ inet_addr $ backlog + const setup_config $ port $ inet_addr $ backlog $ pid diff --git a/main.ml b/main.ml deleted file mode 100644 index 67e41d5..0000000 --- a/main.ml +++ /dev/null @@ -1,93 +0,0 @@ -#require "miou.unix" - -#require "mirage-crypto-rng-miou-unix" - -#require "vif" - -#require "digestif.c" - -#require "base64" - -type cfg = Config - -let index _req server Config = - Vif.Response.with_string server `OK "Hello from an OCaml script!" - -let hex _req arg server Config = - Vif.Response.with_string server `OK (Fmt.str "%02x\n%!" arg) - -let digest req server Config = - let ic = Vif.Request.to_stream req in - let rec go ctx = - match Vif.Stream.get ic with - | Some str -> go (Digestif.SHA1.feed_string ctx str) - | None -> Digestif.SHA1.get ctx - in - let hash = go Digestif.SHA1.empty in - let hash = Digestif.SHA1.to_hex hash in - Vif.Response.with_string server `OK hash - -let random req len server Config = - let buf = Bytes.create 0x7ff in - Vif.Response.with_stream server `OK @@ fun oc -> - let rec go rem = - if rem > 0 then begin - let len = Int.min rem (Bytes.length buf) in - Mirage_crypto_rng.generate_into buf len; - let str = Bytes.sub_string buf 0 len in - let str = Base64.encode_exn str in - Vif.Stream.put oc str; - go (rem - len) - end - in - go len - -type foo = { username: string; password: string; age: int option } - -let foo = - let open Json_encoding in - let username = req "username" string in - let password = req "password" string in - let age = opt "age" int in - let foo = obj3 username password age in - let inj (username, password, age) = { username; password; age } in - let prj { username; password; age } = (username, password, age) in - conv prj inj foo - -let login req server Config = - match Vif.Request.to_json req with - | Ok (foo : foo) -> - Logs.debug (fun m -> m "username: %s" foo.username); - Logs.debug (fun m -> m "password: %s" foo.password); - Vif.Response.with_string server `OK "Foo" - | Error (`Msg err) -> - Logs.err (fun m -> m "Invalid JSON: %s" err); - Vif.Response.with_string server `Not_acceptable err - -let routes = - let open Vif.U in - let open Vif.R in - let open Vif.Content_type in - [ - get (rel /?? nil) --> index - ; get (rel / "random" /% Tyre.int /?? nil) --> random - ; get (rel / "hex" /% Tyre.int /?? nil) --> hex - ; post any (rel / "digest" /?? nil) --> digest - ; post (json_encoding foo) (rel / "json" /?? nil) --> login - ] - -let default req target server Config = - Logs.debug (fun m -> m "We are into the default case"); - Vif.Response.with_string server `Not_found (Fmt.str "%S not found\n%!" target) - -let rng = - let open Mirage_crypto_rng_miou_unix in - let finally = kill in - Vif.D.device ~name:"rng" ~finally [] @@ fun Config -> - initialize (module Pfortuna) - -let () = - Miou_unix.run @@ fun () -> - let sockaddr = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in - let cfg = Vif.config sockaddr in - Vif.run ~cfg ~default ~devices:Vif.Ds.[ rng ] routes Config