Add static handler

examples/01-hello/main.ml

@@ -2,10 +2,17 @@
 
 open Vif ;;
 
-let default req target _server () =
+let default req _server () =
   let* () = Response.with_string req "Hello World!\n" in
   Response.respond `OK
 ;;
 
+let routes =
+  let open Vif.U in
+  let open Vif.R in
+  let open Vif.Content_type in
+  [ get (rel /?? nil) --> default ]
+;;
+
 let () = Miou_unix.run @@ fun () ->
-  Vif.run ~default [] () ;;
+  Vif.run routes () ;;

examples/02-counter/main.ml

@@ -5,11 +5,18 @@ let counter = Atomic.make 0 ;;
 
 open Vif ;;
 
-let default req target _server () =
+let default req _server () =
   let v = Atomic.fetch_and_add counter 1 in
   let str = Fmt.str "%d request(s)\n" (succ v) in
   let* () = Response.with_string req str in
   Response.respond `OK
 ;;
 
-let () = Miou_unix.run @@ fun () -> Vif.run ~default [] () ;;
+let routes =
+  let open Vif.U in
+  let open Vif.R in
+  let open Vif.Content_type in
+  [ get (rel /?? nil) --> default ]
+
+let () = Miou_unix.run @@ fun () ->
+  Vif.run routes () ;;

examples/03-fail/main.ml

@@ -2,6 +2,19 @@
 
 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 () = Printexc.register_printer @@ function
+  | Foo -> Some "Foo"
+  | _ -> None ;;
+
+let default req server () = raise Foo ;;
+
+let routes =
+  let open Vif.U in
+  let open Vif.R in
+  let open Vif.Content_type in
+  [ get (rel /?? nil) --> default ]
+;;
+
+let () = Miou_unix.run @@ fun () ->
+  Vif.run routes ()
+;;

examples/04-device/main.ml

@@ -9,12 +9,19 @@ let foo =
 
 open Vif ;;
 
-let default req target server () =
+let default req server () =
   let Foo = Vif.S.device foo server in
   let* () = Response.with_string req "ok\n" in
   Response.respond `OK
 ;;
 
+let routes =
+  let open Vif.U in
+  let open Vif.R in
+  let open Vif.Content_type in
+  [ get (rel /?? nil) --> default ]
+
 let () =
-  Miou_unix.run @@ fun () -> Vif.run ~default ~devices:Vif.Ds.[ foo ] [] ()
+  Miou_unix.run @@ fun () ->
+  Vif.run ~devices:Vif.Ds.[ foo ] routes ()
 ;;

examples/05-json/main.ml

@@ -52,10 +52,4 @@ let routes =
   [ post (json_encoding foo) (rel /?? nil) --> deserialize ]
 ;;
 
-let default req target _server () =
-  let str = Fmt.str "%s not found\n" target in
-  let* () = Response.with_string req str in
-  Response.respond `Not_found
-;;
-
-let () = Miou_unix.run @@ fun () -> Vif.run ~default routes () ;;
+let () = Miou_unix.run @@ fun () -> Vif.run routes () ;;

examples/06-caqti/main.ml

@@ -53,12 +53,6 @@ let list req server _cfg =
     Response.respond `Internal_server_error
 ;;
 
-let default req target server _ =
-  let str = Fmt.str "%s not found\n" target in
-  let* () = Response.with_string req str in
-  Response.respond `Not_found 
-;;
-
 let routes =
   let open Vif.U in
   let open Vif.R in
@@ -71,5 +65,5 @@ let () =
   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
+  Vif.run ~devices:Vif.Ds.[ caqti ] routes cfg
 ;;

examples/07-deflate/main.ml

@@ -2,12 +2,19 @@
 
 open Vif ;;
 
-let default req target server () =
+let default req server () =
   let* () = Response.with_string ~compression:`DEFLATE req "Hello World!\n" in
   let field = "content-type" in
   let* () = Response.add ~field "text/plain; charset=utf-8" in
   Response.respond `OK
 ;;
 
+let routes =
+  let open Vif.U in
+  let open Vif.R in
+  let open Vif.Content_type in
+  [ get (rel /?? nil) --> default ]
+
 let () = Miou_unix.run @@ fun () ->
-  Vif.run ~default [] () ;;
+  Vif.run routes ()
+;;

examples/08-digest/main.ml

@@ -12,7 +12,7 @@ let sha1 =
   Sink { init; push; full; stop }
 ;;
 
-let default req target server () =
+let default req server () =
   let stream = Request.stream req in
   let hash = Stream.Stream.into sha1 stream in
   let field = "content-type" in
@@ -21,5 +21,12 @@ let default req target server () =
   Response.respond `OK
 ;;
 
+let routes =
+  let open Vif.U in
+  let open Vif.R in
+  let open Vif.Content_type in
+  [ post any (rel /?? nil) --> default ]
+
 let () = Miou_unix.run @@ fun () ->
-  Vif.run ~default [] () ;;
+  Vif.run routes ()
+;;

examples/09-jwt/main.ml

@@ -70,7 +70,7 @@ let login req server { secret }=
       Response.respond (`Code 422)
 ;;
 
-let default req target server _cfg =
+let default req server _cfg =
   match Request.get jwt req with
   | None ->
       let field = "content-type" in
@@ -89,9 +89,11 @@ let routes =
   let open Vif.U in
   let open Vif.R in
   let open Vif.Content_type in
-  [ post (json_encoding credential) (rel / "login" /?? nil) --> login ]
+  [ post (json_encoding credential) (rel / "login" /?? nil) --> login
+  ; get (rel /?? nil) --> default ]
 ;;
 
 let () = Miou_unix.run @@ fun () ->
   let secret = "deadbeef" in
-  Vif.run ~default ~middlewares:Ms.[ jwt ] routes { secret } ;;
+  Vif.run ~middlewares:Ms.[ jwt ] routes { secret }
+;;

examples/10-route/main.ml

@@ -0,0 +1,31 @@
+#require "vif" ;;
+
+open Vif ;;
+
+let hello req name server _ =
+  let str = Fmt.str "Hello, %S!\n" name in
+  let field = "content-type" in
+  let* () = Response.add ~field "text/plain; charset=utf-8" in
+  let* () = Response.with_string req str in
+  Response.respond `OK
+;;
+
+let default req server _cfg =
+  let str = Fmt.str "Hello World!\n" in
+  let field = "content-type" in
+  let* () = Response.add ~field "text/plain; charset=utf-8" in
+  let* () = Response.with_string req str in
+  Response.respond `OK
+;;
+
+let routes =
+  let open Vif.U in
+  let open Vif.R in
+  let open Vif.Content_type in
+  [ get (rel / "echo" /% string /?? nil) --> hello
+  ; get (rel /?? nil) --> default ]
+;;
+
+let () = Miou_unix.run @@ fun () ->
+  Vif.run routes ()
+;;

examples/11-stream/main.ml

@@ -0,0 +1,22 @@
+#require "vif" ;;
+
+open Vif ;;
+
+let cat req server _ =
+  let src = Request.stream req in
+  let field = "content-type" in
+  let* () = Response.add ~field "application/octet-stream" in
+  let* () = Response.with_stream req src in
+  Response.respond `OK
+;;
+
+let routes =
+  let open Vif.U in
+  let open Vif.R in
+  let open Vif.Content_type in
+  [ post any (rel /?? nil) --> cat ]
+;;
+
+let () = Miou_unix.run @@ fun () ->
+  Vif.run routes ()
+;;

examples/12-static/index.html

@@ -0,0 +1 @@
+<h1>Hello from Vif!</h1>

examples/12-static/main.ml

@@ -0,0 +1,7 @@
+#require "vif" ;;
+
+open Vif ;;
+
+let () = Miou_unix.run @@ fun () ->
+  Vif.run ~handlers:[ Handler.static ] [] ()
+;;

lib/vif/dune

@@ -9,6 +9,9 @@
   jsonm
   cmdliner
   hmap
+  fpath
+  conan-database.light
+  conan-unix
   decompress.zl
   decompress.gz
   mirage-crypto-rng-miou-unix

lib/vif/vif.ml

@@ -78,6 +78,7 @@ module Headers = Vif_headers
 module Request = Vif_request
 module Response = Vif_response
 module Cookie = Vif_cookie
+module Handler = Vif_handler
 
 type e = Response.e = Empty
 type f = Response.f = Filled
@@ -96,6 +97,8 @@ let content_type req0 =
   let c = Option.to_result ~none:`Not_found c in
   Result.bind c Multipart_form.Content_type.of_string
 
+[@@@warning "-8"]
+
 let recognize_request ~env req0 =
   let extract : type c a.
          Vif_method.t option
@@ -190,9 +193,11 @@ let rec user's_functions daemon =
   let fn (User's_task (req0, fn)) =
     let _prm =
       Miou.call ~orphans:daemon.orphans @@ fun () ->
-      let response = fn daemon.server daemon.user's_value in
-      match Vif_response.(run req0 empty) response with
+      match
+        Vif_response.(run req0 empty) (fn daemon.server daemon.user's_value)
+      with
       | Vif_response.Sent, () -> Vif_request0.close req0
+      | exception exn -> Vif_request0.report_exn req0 exn
     in
     ()
   in
@@ -240,8 +245,40 @@ let store_pid = function
       output_string oc (string_of_int (Unix.getpid ()));
       close_out oc
 
+let default req target _server _user's_value =
+  let pp_field ppf (k, v) =
+    let v = String.split_on_char ' ' v in
+    let v = List.map (String.split_on_char '\t') v in
+    let v = List.flatten v in
+    let v = List.filter_map (function "" -> None | v -> Some v) v in
+    Fmt.pf ppf "%s: @[<hov>%a@]%!" k Fmt.(list ~sep:(any "@ ") string) v
+  in
+  let str =
+    Fmt.str "Unspecified destination %s (%a):\n%a\n" target Vif_method.pp
+      (Vif_request.meth req)
+      Fmt.(list ~sep:(any "\n") pp_field)
+      (Vif_request.headers req)
+  in
+  let len = String.length str in
+  let field = "content-type" in
+  let* () = Vif_response.add ~field "text/plain; charset=utf-8" in
+  let field = "content-length" in
+  let* () = Vif_response.add ~field (string_of_int len) in
+  let* () = Vif_response.with_string req str in
+  Vif_response.respond `Not_found
+
+let default_from_handlers handlers req target server user's_value =
+  let fn acc handler =
+    match acc with
+    | Some _ as acc -> acc
+    | None -> handler req target server user's_value
+  in
+  match List.fold_left fn None handlers with
+  | Some p -> p
+  | None -> default req target server user's_value
+
 let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[])
-    ?(middlewares = Ms.[]) ~default routes user's_value =
+    ?(middlewares = Ms.[]) ?(handlers = []) routes user's_value =
   let rng = Mirage_crypto_rng_miou_unix.(initialize (module Pfortuna)) in
   let finally () = Mirage_crypto_rng_miou_unix.kill rng in
   Fun.protect ~finally @@ fun () ->
@@ -275,6 +312,7 @@ let run ?(cfg = Vif_options.config_from_globals ()) ?(devices = Ds.[])
     ; server
     }
   in
+  let default = default_from_handlers handlers in
   let user's_tasks = Miou.call @@ fun () -> user's_functions daemon in
   let fn0 = handler cfg ~default ~middlewares routes daemon in
   let prm0 = Miou.async @@ fun () -> handle stop cfg fn0 in

lib/vif/vif.mli

@@ -1,5 +1,11 @@
 module U : sig
   type 'a atom = 'a Tyre.t
+
+  val int : int atom
+  val string : string atom
+  val option : 'a atom -> 'a option atom
+  val conv : ('a -> 'b) -> ('b -> 'a) -> 'a atom -> 'b atom
+
   type ('f, 'r) path
 
   val rel : ('r, 'r) path
@@ -300,6 +306,17 @@ module Cookie : sig
     -> ('p, 'p, unit) Response.t
 end
 
+module Handler : sig
+  type ('c, 'value) t =
+       ('c, string) Request.t
+    -> string
+    -> S.t
+    -> 'value
+    -> (Response.e, Response.s, unit) Response.t option
+
+  val static : ?top:Fpath.t -> ('c, 'value) t
+end
+
 type config
 type e = Response.e
 type f = Response.f
@@ -328,12 +345,7 @@ val run :
      ?cfg:config
   -> ?devices:'value Ds.t
   -> ?middlewares:'value Ms.t
-  -> default:
-       (   ('c, string) Request.t
-        -> string
-        -> S.t
-        -> 'value
-        -> (e, s, unit) Response.t)
+  -> ?handlers:('c, 'value) Handler.t list
   -> (S.t -> 'value -> (e, s, unit) Response.t) R.route list
   -> 'value
   -> unit

lib/vif/vif_content_type.ml

@@ -1,9 +1,13 @@
 type null = Null
-and json = Json
+type json = Json
+type multipart_form = Multipart_form
+type stream = string Stream.source Multipart_form.elt Stream.source
 
 type ('c, 'a) t =
   | Null : (null, unit) t
   | Json_encoding : 'a Json_encoding.encoding -> (json, 'a) t
+  | Multipart_form_encoding : 'a Multipart_form.t -> (multipart_form, 'a) t
+  | Multipart_form : (multipart_form, stream) t
   | Json : (json, Json.t) t
   | Any : ('c, string) t
 
@@ -11,3 +15,41 @@ let null = Null
 let json_encoding e = Json_encoding e
 let json = Json
 let any = Any
+
+module Witness = struct
+  type (_, _) eq = Refl : ('a, 'a) eq
+  type _ equality = ..
+
+  module type Inst = sig
+    type t
+    type _ equality += Eq : t equality
+  end
+
+  type 'a t = (module Inst with type t = 'a)
+
+  let make : type a. unit -> a t =
+   fun () ->
+    let module Inst = struct
+      type t = a
+      type _ equality += Eq : t equality
+    end in
+    (module Inst)
+
+  let _eq : type a b. a t -> b t -> (a, b) eq option =
+   fun (module A) (module B) -> match A.Eq with B.Eq -> Some Refl | _ -> None
+end
+
+module Multipart = struct
+  type 'a t = { rwit: 'a Witness.t; rfields: 'a fields_and_constr }
+
+  and 'a fields_and_constr =
+    | Fields : ('a, 'b) fields * 'b -> 'a fields_and_constr
+
+  and ('a, 'b) fields =
+    | F0 : ('a, 'a) fields
+    | F1 : ('a, 'b) field * ('a, 'c) fields -> ('a, 'b -> 'c) fields
+
+  and ('a, 'b) field = { name: string; ftype: 'b ty; fget: 'a -> 'b }
+  and 'a ty = Primary : 'a primary -> 'a ty | Record : 'a t -> 'a ty
+  and 'a primary = String : string primary
+end

lib/vif/vif_handler.ml

@@ -0,0 +1,84 @@
+type ('c, 'value) t =
+     ('c, string) Vif_request.t
+  -> string
+  -> Vif_s.t
+  -> 'value
+  -> (Vif_response.e, Vif_response.s, unit) Vif_response.t option
+
+let pwd = Fpath.v (Unix.getcwd ())
+let tree = Conan_light.tree
+
+let sha256sum path =
+  let path = Fpath.to_string path in
+  if Sys.file_exists path = false || Sys.is_directory path then
+    invalid_arg "sha256sum";
+  let fd = Unix.openfile path Unix.[ O_RDONLY ] 0o644 in
+  let finally () = Unix.close fd in
+  Fun.protect ~finally @@ fun () ->
+  let stat = Unix.fstat fd in
+  let ba =
+    Unix.map_file fd Bigarray.char Bigarray.c_layout false
+      [| stat.Unix.st_size |]
+  in
+  let ba = Bigarray.array1_of_genarray ba in
+  let hash = Digestif.SHA256.digest_bigstring ba in
+  Digestif.SHA256.to_hex hash
+
+let mime_type path =
+  match Conan_unix.run_with_tree Conan_light.tree (Fpath.to_string path) with
+  | Ok m ->
+      Option.value ~default:"application/octet-stream" (Conan.Metadata.mime m)
+  | Error _ -> "application/octet-stream"
+  | exception _ -> "application/octet-stream"
+
+let cache req target =
+  let hdrs = Vif_request.headers req in
+  let hash = sha256sum target in
+  match Vif_headers.get hdrs "if-none-match" with
+  | Some hash' -> String.equal hash hash'
+  | None -> false
+
+let valid ~top target =
+  Fpath.is_prefix top target
+  && Sys.file_exists (Fpath.to_string target)
+  && Sys.is_directory (Fpath.to_string target) = false
+
+let pp_msg ppf (`Msg msg) = Fmt.string ppf msg
+
+let trim lst =
+  let lst = List.drop_while (( = ) "") lst in
+  let lst = List.drop_while (( = ) "") (List.rev lst) in
+  List.rev lst
+
+let static ?(top = pwd) req target _server _ =
+  let target = String.split_on_char '/' target in
+  let target = trim target in
+  let target = String.concat "/" target in
+  let abs_path =
+    let ( let* ) = Result.bind in
+    let* x = Fpath.of_string target in
+    Ok Fpath.(normalize (top // x))
+  in
+  match (Vif_request.meth req, abs_path) with
+  | `GET, Ok abs_path when valid ~top abs_path -> begin
+      let ( let* ) = Vif_response.bind in
+      let process =
+        if cache req abs_path then
+          let* () = Vif_response.with_string req "" in
+          Vif_response.respond `Not_modified
+        else
+          let src = Stream.Source.file (Fpath.to_string abs_path) in
+          let src = Stream.Stream.from src in
+          let field = "content-type" in
+          let* () = Vif_response.add ~field (mime_type abs_path) in
+          let stat = Unix.stat (Fpath.to_string abs_path) in
+          let field = "content-length" in
+          let* () = Vif_response.add ~field (string_of_int stat.Unix.st_size) in
+          let field = "etag" in
+          let* () = Vif_response.add ~field (sha256sum abs_path) in
+          let* () = Vif_response.with_stream req src in
+          Vif_response.respond `OK
+      in
+      Some process
+    end
+  | _ -> None

lib/vif/vif_method.ml

@@ -8,3 +8,14 @@ type t =
   | `PUT
   | `TRACE
   | `Other of string ]
+
+let pp ppf = function
+  | `CONNECT -> Fmt.string ppf "CONNECT"
+  | `DELETE -> Fmt.string ppf "DELETE"
+  | `GET -> Fmt.string ppf "GET"
+  | `HEAD -> Fmt.string ppf "HEAD"
+  | `OPTIONS -> Fmt.string ppf "OPTIONS"
+  | `POST -> Fmt.string ppf "POST"
+  | `PUT -> Fmt.string ppf "PUT"
+  | `TRACE -> Fmt.string ppf "TRACE"
+  | `Other str -> Fmt.string ppf (String.uppercase_ascii str)

lib/vif/vif_r.ml

@@ -261,7 +261,7 @@ let dispatch : type r c.
         default request target
     | Some subs -> begin
         try find_and_trigger ~original:target ~request subs wl
-        with exn ->
+        with Not_found as exn ->
           Log.debug (fun m ->
               m "Fallback to the default route (exn: %s)"
                 (Printexc.to_string exn));

lib/vif/vif_request0.ml

@@ -81,6 +81,11 @@ let request_body { reqd; _ } =
   | `V1 reqd -> `V1 (H1.Reqd.request_body reqd)
   | `V2 reqd -> `V2 (H2.Reqd.request_body reqd)
 
+let report_exn { reqd; _ } exn =
+  match reqd with
+  | `V1 reqd -> H1.Reqd.report_exn reqd exn
+  | `V2 reqd -> H2.Reqd.report_exn reqd exn
+
 let version { request; _ } = match request with V1 _ -> 1 | V2 _ -> 2
 let tls { tls; _ } = tls
 let on_localhost { on_localhost; _ } = on_localhost

lib/vif/vif_response.ml

@@ -162,8 +162,8 @@ let run : type a p q. Vif_request0.t -> p state -> (p, q, a) t -> q state * a =
         (state, ())
     | Empty, Stream stream -> (Filled stream, ())
     | Empty, String str ->
-        if Vif_request0.version req = 1
-        then headers := Vif_headers.add_unless_exists !headers "connection" "close";
+        if Vif_request0.version req = 1 then
+          headers := Vif_headers.add_unless_exists !headers "connection" "close";
         (Filled (Stream.Stream.singleton str), ())
     | Filled stream, Respond status ->
         let headers = !headers in

lib/vif/vif_u.ml

@@ -61,6 +61,11 @@ let ( /% ) = Path.add_atom
 let ( /? ) path query = Url.make ~slash:No_slash path query
 let ( //? ) path query = Url.make ~slash:Slash path query
 let ( /?? ) path query = Url.make ~slash:Maybe_slash path query
+let int = Tyre.int
+let string = Tyre.(regex Re.(rep1 @@ compl [ char '/' ]))
+let bool = Tyre.bool
+let option = Tyre.opt
+let conv = Tyre.conv
 let eval_atom p x = Tyre.(eval (Internal.to_t p) x)
 
 let eval_top_atom : type a. a Tyre.Internal.raw -> a -> string list = function