Merge branch 'wip-virtual-dir'

.github/workflows/main.yml

@@ -10,7 +10,7 @@ on:
 jobs:
   build:
     strategy:
-      fail-fast: false
+      fail-fast: true
       matrix:
         os:
           - macos-latest
@@ -25,6 +25,8 @@ jobs:
     steps:
       - name: Checkout code
         uses: actions/checkout@v2
+        with:
+          submodules: recursive
 
       - name: Use OCaml ${{ matrix.ocaml-compiler }}
         uses: ocaml/setup-ocaml@v2
@@ -34,7 +36,7 @@ jobs:
 
       - run: opam install . --deps-only --with-test
 
-      - run: opam exec -- dune build @install
+      - run: opam exec -- dune build @install -p tiny_httpd,tiny_httpd_camlzip,curly
 
-      - run: opam exec -- dune runtest
+      - run: opam exec -- dune build @src/runtest @examples/runtest
         if: ${{ matrix.os == 'ubuntu-latest' }}

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "vendor/curly"]
+	path = vendor/curly
+	url = https://github.com/rgrinberg/curly.git

README.md

@@ -1,7 +1,8 @@
 # Tiny_httpd [![build](https://github.com/c-cube/tiny_httpd/workflows/build/badge.svg)](https://github.com/c-cube/tiny_httpd/actions)
 
 Minimal HTTP server using good old threads, with stream abstractions,
-simple routing, URL encoding/decoding, and optional compression with camlzip.
+simple routing, URL encoding/decoding, static asset serving,
+and optional compression with camlzip.
 It also supports [server-sent events](https://developer.mozilla.org/en-US/docs/Web/API/Server-sent_events/Using_server-sent_events)
 ([w3c](https://html.spec.whatwg.org/multipage/server-sent-events.html#event-stream-interpretation))
 
@@ -67,6 +68,43 @@ $ curl -X GET http://localhost:8080
 
 ```
 
+## Static assets and files
+
+The program `http_of_dir` relies on the module `Tiny_httpd_dir`, which
+can serve directories, as well as _virtual file systems_.
+
+In 'examples/dune', we produce an OCaml module `vfs.ml` using
+the program `tiny-httpd-vfs-pack`.  This module contains a VFS (virtual file
+system) which can be served as if it were an actual directory.
+
+The dune rule:
+
+```lisp
+(rule
+  (targets vfs.ml)
+  (deps (source_tree files) (:out test_output.txt.expected))
+  (enabled_if (= %{system} "linux"))
+  (action (run ../src/bin/vfs_pack.exe -o %{targets}
+               --mirror=files/
+               --file=test_out.txt,%{out}
+               --url=example_dot_com,http://example.com)))
+```
+
+The code to serve the VFS from `vfs.ml` is as follows:
+
+```ocaml
+  …
+  Tiny_httpd_dir.add_vfs server
+    ~config:(Tiny_httpd_dir.config ~download:true
+               ~dir_behavior:Tiny_httpd_dir.Index_or_lists ())
+    ~vfs:Vfs.vfs ~prefix:"vfs";
+  …
+```
+
+it allows downloading the files, and listing directories.
+If a directory contains `index.html` then this will be served
+instead of listing the content.
+
 ## Socket activation
 
 Since version 0.10, socket activation is supported indirectly, by allowing a

examples/dune

@@ -12,7 +12,7 @@
 (executable
   (name echo)
   (flags :standard -warn-error -a+8)
-  (modules echo)
+  (modules echo vfs)
   (libraries tiny_httpd tiny_httpd_camlzip))
 
 (rule
@@ -30,3 +30,23 @@
   (deps test_output.txt)
   (action
     (diff test_output.txt.expected test_output.txt)))
+
+; produce an embedded FS
+(rule
+  (targets vfs.ml)
+  (deps (source_tree files) (:out test_output.txt.expected))
+  (enabled_if (= %{system} "linux"))
+  (action (run ../src/bin/vfs_pack.exe -o %{targets}
+               --mirror=files/
+               --file=test_out.txt,%{out}
+               --url=example_dot_com,http://example.com)))
+
+(rule
+  (targets vfs.ml)
+  (enabled_if (<> %{system} "linux"))
+  (action
+    (with-stdout-to
+      %{targets}
+      (progn
+        (echo "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:0. ()")
+        (echo "let vfs = Tiny_httpd_dir.Embedded_fs.to_vfs embedded_fs")))))

examples/echo.ml

@@ -107,16 +107,23 @@ let () =
        S.Response.make_string @@ Ok stats
     );
 
+  (* VFS *)
+  Tiny_httpd_dir.add_vfs server
+    ~config:(Tiny_httpd_dir.config ~download:true
+               ~dir_behavior:Tiny_httpd_dir.Index_or_lists ())
+    ~vfs:Vfs.vfs ~prefix:"vfs";
+
   (* main page *)
   S.add_route_handler server S.Route.(return)
     (fun _req ->
        let s = "<head></head><body>\n\
                 <p><b>welcome!</b>\n<p>endpoints are:\n<ul>\
                 <li><pre>/hello/'name' (GET)</pre></li>\n\
-                <li><pre>/echo/ (GET) echoes back query</pre></li>\n\
+                <li><pre><a href=\"/echo/\">/echo/</a> (GET) echoes back query</pre></li>\n\
                 <li><pre>/upload/'path' (PUT) to upload a file</pre></li>\n\
                 <li><pre>/zcat/'path' (GET) to download a file (compressed)</pre></li>\n\
                 <li><pre>/stats/ (GET) to access statistics</pre></li>\n\
+                <li><pre><a href=\"/vfs/\">/vfs/</a> (GET) to access statistics</pre></li>\n\
                 </ul></body>"
        in
        S.Response.make_string ~headers:["content-type", "text/html"] @@ Ok s);

examples/files/a.txt

@@ -0,0 +1,2 @@
+hello
+world

examples/files/foo.html

@@ -0,0 +1,18 @@
+<html>
+<head>
+
+</head>
+<body>
+
+  <h1> hello! </h1>
+  <ul>
+    <li> item 1 </li>
+    <li> item 2 </li>
+    <li> item 3 </li>
+    <li> item 4 </li>
+  </ul>
+
+  <a href="."> escape from this file </a>
+
+</body>
+</html>

examples/files/sub/b.txt

@@ -0,0 +1 @@
+lorem ipsum etc.

examples/files/sub/yolo.html

@@ -0,0 +1,18 @@
+
+<html>
+<head>
+
+</head>
+<body>
+  <h2> funky: </h2>
+
+  <ul>
+    <li>
+      <a href="../"> go up!! </a>
+    </li>
+    <li>
+      <a href="../foo.html"> up/foo </a>
+    </li>
+  </ul>
+</body>
+</html>

src/Tiny_httpd_dir.ml

@@ -5,22 +5,36 @@ module Pf = Printf
 type dir_behavior =
   | Index | Lists | Index_or_lists | Forbidden
 
+type hidden = unit
 type config = {
   mutable download: bool;
   mutable dir_behavior: dir_behavior;
   mutable delete: bool;
   mutable upload: bool;
   mutable max_upload_size: int;
+  _rest: hidden
 }
 
-let default_config () : config =
+let default_config_ : config =
   { download=true;
     dir_behavior=Forbidden;
     delete=false;
     upload=false;
     max_upload_size = 10 * 1024 * 1024;
+    _rest=();
   }
 
+let default_config () = default_config_
+let config
+    ?(download=default_config_.download)
+    ?(dir_behavior=default_config_.dir_behavior)
+    ?(delete=default_config_.delete)
+    ?(upload=default_config_.upload)
+    ?(max_upload_size=default_config_.max_upload_size)
+    () : config =
+  { download; dir_behavior; delete; upload; max_upload_size;
+    _rest=()}
+
 let contains_dot_dot s =
   try
     String.iteri
@@ -45,20 +59,59 @@ let _decode_path s = match U.percent_decode s with Some s->s | None -> s
 
 let is_hidden s = String.length s>0 && s.[0] = '.'
 
-let html_list_dir ~top ~parent d : string =
-  let entries = Sys.readdir @@ (top // d) in
+module type VFS = sig
+  val descr : string
+  val is_directory : string -> bool
+  val contains : string -> bool
+  val list_dir : string -> string array
+  val delete : string -> unit
+  val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
+  val read_file_content : string -> Tiny_httpd.Byte_stream.t
+  val file_size : string -> int option
+  val file_mtime : string -> float option
+end
+
+type vfs = (module VFS)
+
+let vfs_of_dir (top:string) : vfs =
+  let module M = struct
+    let descr = top
+    let (//) = Filename.concat
+    let is_directory f = Sys.is_directory (top // f)
+    let contains f = Sys.file_exists (top // f)
+    let list_dir f = Sys.readdir (top // f)
+    let read_file_content f =
+      let ic = open_in_bin (top // f) in
+      S.Byte_stream.of_chan ic
+    let create f =
+      let oc = open_out_bin (top // f) in
+      let write = output oc in
+      let close() = close_out oc in
+      write, close
+    let delete f = Sys.remove (top // f)
+    let file_size f =
+      try Some (Unix.stat (top // f)).Unix.st_size
+      with _ -> None
+    let file_mtime f =
+      try Some (Unix.stat (top // f)).Unix.st_mtime
+      with _ -> None
+  end in
+  (module M)
+
+let html_list_dir (module VFS:VFS) ~prefix ~parent d : string =
+  let entries = VFS.list_dir d in
   Array.sort compare entries;
   let body = Buffer.create 256 in
   (* TODO: breadcrumbs for the path, each element a link to the given ancestor dir *)
-  Printf.bprintf body {|<head><title> http_of_dir %S</title><meta charset="utf-8">
+  Printf.bprintf body {|<head><title> list directory %S</title><meta charset="utf-8">
   </head><body>
     <h2> Index of %S</h2>
-  |} top d;
+  |} VFS.descr d;
   begin match parent with
     | None -> ()
     | Some p ->
       Printf.bprintf body "<a href=\"/%s\"> (parent directory) </a>\n"
-        (encode_path p);
+        (encode_path (prefix // p));
   end;
   Printf.bprintf body "<ul>\n";
   let hidden_stop = ref 0 in
@@ -74,16 +127,18 @@ let html_list_dir ~top ~parent d : string =
          Printf.bprintf body "</details/>\n";
        );
        if not @@ contains_dot_dot (d // f) then (
-         let fpath = top // d // f in
-         if not @@ Sys.file_exists fpath then (
+         let fpath = d // f in
+         if not @@ VFS.contains fpath then (
            Printf.bprintf body "  <li> %s [invalid file]</li>\n" f
          ) else (
            let size =
-             try Printf.sprintf " (%s)" @@ human_size (Unix.stat fpath).Unix.st_size
-             with _ -> ""
+             match VFS.file_size fpath with
+             | Some f -> Printf.sprintf " (%s)" @@ human_size f
+             | None -> ""
            in
            Printf.bprintf body "  <li> <a href=\"/%s\"> %s </a> %s%s </li>\n"
-             (encode_path (d // f)) f (if Sys.is_directory fpath then "[dir]" else "") size
+             (encode_path (prefix // fpath)) f
+             (if VFS.is_directory fpath then "[dir]" else "") size
          );
        )
     )
@@ -100,30 +155,32 @@ let finally_ ~h x f =
     h x;
     raise e
 
-let add_dir_path ~config ~dir ~prefix server =
+(* @param on_fs: if true, we assume the file exists on the FS *)
+let add_vfs_ ~on_fs ~top ~config ~vfs:((module VFS:VFS) as vfs) ~prefix server : unit=
 
+  let route () =
+    if prefix="" then S.Route.rest_of_path_urlencoded
+    else S.Route.exact_path prefix S.Route.rest_of_path_urlencoded
+  in
   if config.delete then (
-    S.add_route_handler server ~meth:`DELETE
-      S.Route.(exact_path prefix (rest_of_path_urlencoded))
+    S.add_route_handler server ~meth:`DELETE (route())
       (fun path _req ->
          if contains_dot_dot path then (
            S.Response.fail_raise ~code:403 "invalid path in delete"
          ) else (
            S.Response.make_string
              (try
-                Sys.remove (dir // path); Ok "file deleted successfully"
+                VFS.delete path; Ok "file deleted successfully"
               with e -> Error (500, Printexc.to_string e))
          )
       );
   ) else (
-    S.add_route_handler server ~meth:`DELETE
-      S.Route.(exact_path prefix (S.Route.(string @/ return)))
+    S.add_route_handler server ~meth:`DELETE (route())
       (fun _ _  -> S.Response.make_raw ~code:405 "delete not allowed");
   );
 
   if config.upload then (
-    S.add_route_handler_stream server ~meth:`PUT
-      S.Route.(exact_path prefix (rest_of_path_urlencoded))
+    S.add_route_handler_stream server ~meth:`PUT (route())
       ~accept:(fun req ->
           match S.Request.get_header_int req "Content-Length" with
           | Some n when n > config.max_upload_size ->
@@ -133,56 +190,52 @@ let add_dir_path ~config ~dir ~prefix server =
           | _ -> Ok ()
         )
       (fun path req ->
-         let fpath = dir // path in
-         let oc =
-           try open_out fpath
+         let write, close =
+           try VFS.create path
            with e ->
              S.Response.fail_raise ~code:403 "cannot upload to %S: %s"
                path (Printexc.to_string e)
          in
          let req = S.Request.limit_body_size ~max_size:config.max_upload_size req in
-         S.Byte_stream.to_chan oc req.S.Request.body;
-         flush oc;
-         close_out oc;
+         S.Byte_stream.iter write req.S.Request.body;
+         close ();
          S._debug (fun k->k "done uploading");
          S.Response.make_raw ~code:201 "upload successful"
       )
   ) else (
-    S.add_route_handler server ~meth:`PUT
-      S.Route.(exact_path prefix (string @/ return))
+    S.add_route_handler server ~meth:`PUT (route())
       (fun _ _  -> S.Response.make_raw ~code:405 "upload not allowed");
   );
 
   if config.download then (
-    S.add_route_handler server ~meth:`GET
-      S.Route.(exact_path prefix (rest_of_path_urlencoded))
+    S.add_route_handler server ~meth:`GET (route())
       (fun path req ->
-         let full_path = dir // path in
+         S._debug (fun k->k "path=%S" path);
          let mtime = lazy (
-           try Printf.sprintf "mtime: %f" (Unix.stat full_path).Unix.st_mtime
-           with _ -> S.Response.fail_raise ~code:403 "Cannot access file"
+           match VFS.file_mtime path with
+           | None -> S.Response.fail_raise ~code:403 "Cannot access file"
+           | Some t -> Printf.sprintf "mtime: %.4f" t
          ) in
-         if contains_dot_dot full_path then (
+         if contains_dot_dot path then (
            S.Response.fail ~code:403 "Path is forbidden";
-         ) else if not (Sys.file_exists full_path) then (
+         ) else if not (VFS.contains path) then (
            S.Response.fail ~code:404 "File not found";
          ) else if S.Request.get_header req "If-None-Match" = Some (Lazy.force mtime) then (
            S._debug (fun k->k "cached object %S (etag: %S)" path (Lazy.force mtime));
            S.Response.make_raw ~code:304 ""
-         ) else if Sys.is_directory full_path then (
-           S._debug (fun k->k "list dir %S (topdir %S)"  full_path dir);
+         ) else if VFS.is_directory path then (
+           S._debug (fun k->k "list dir %S (topdir %S)" path VFS.descr);
            let parent = Filename.(dirname path) in
-           let parent = if parent <> path then Some parent else None in
+           let parent = if parent <> "." && parent <> path then Some parent else None in
            match config.dir_behavior with
-           | Index | Index_or_lists when
-               Sys.file_exists (full_path // "index.html") ->
+           | Index | Index_or_lists when VFS.contains (path // "index.html") ->
              (* redirect using path, not full path *)
              let new_path = "/" // path // "index.html" in
              S._debug (fun k->k "redirect to `%s`" new_path);
              S.Response.make_raw ~code:301 ""
                ~headers:S.Headers.(empty |> set "location" new_path)
            | Lists | Index_or_lists ->
-             let body = html_list_dir ~top:dir path ~parent in
+             let body = html_list_dir ~prefix vfs path ~parent in
              S.Response.make_string
                ~headers:[header_html; "ETag", Lazy.force mtime]
                (Ok body)
@@ -190,28 +243,142 @@ let add_dir_path ~config ~dir ~prefix server =
              S.Response.make_raw ~code:405 "listing dir not allowed"
          ) else (
            try
-             let ic = open_in full_path in
              let mime_type =
-               if Filename.extension full_path = ".css" then (
+               if Filename.extension path = ".css" then (
                  ["Content-Type", "text/css"]
-               ) else if Filename.extension full_path = ".js" then (
+               ) else if Filename.extension path = ".js" then (
                  ["Content-Type", "text/javascript"]
-               ) else try
-                   let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" full_path) in
+               ) else if on_fs then (
+                 (* call "file" util *)
+                 try
+                   let p = Unix.open_process_in (Printf.sprintf "file -i -b %S" (top // path)) in
                    finally_ ~h:(fun p->ignore @@ Unix.close_process_in p) p
                      (fun p ->
                         try ["Content-Type", String.trim (input_line p)]
                         with _ -> [])
                  with _ -> []
+               ) else []
              in
+             let stream = VFS.read_file_content path in
              S.Response.make_raw_stream
                ~headers:(mime_type@["Etag", Lazy.force mtime])
-               ~code:200 (S.Byte_stream.of_chan ic)
+               ~code:200 stream
            with e ->
              S.Response.fail ~code:500 "error while reading file: %s" (Printexc.to_string e))
       )
   ) else (
-    S.add_route_handler server ~meth:`GET
-      S.Route.(exact_path prefix (string @/ return))
+    S.add_route_handler server ~meth:`GET (route())
       (fun _ _  -> S.Response.make_raw ~code:405 "download not allowed");
   );
+  ()
+
+let add_vfs ~config ~vfs ~prefix server : unit =
+  add_vfs_ ~on_fs:false ~top:"." ~config ~prefix ~vfs server
+
+let add_dir_path ~config ~dir ~prefix server : unit =
+  add_vfs_ ~on_fs:true ~top:dir ~config ~prefix ~vfs:(vfs_of_dir dir) server
+
+module Embedded_fs = struct
+  module Str_map = Map.Make(String)
+
+  type t = {
+    mtime: float;
+    mutable entries: entry Str_map.t
+  }
+
+  and entry =
+    | File of {
+        content: string;
+        mtime: float;
+      }
+    | Dir of t
+
+  let create ?(mtime=Unix.gettimeofday()) () : t = {
+    mtime;
+    entries=Str_map.empty;
+  }
+
+  let split_path_ (path:string) : string list * string =
+    let basename = Filename.basename path in
+    let dirname =
+      Filename.dirname path
+      |> String.split_on_char '/'
+      |> List.filter (function "" | "." -> false | _ -> true) in
+    dirname, basename
+
+  let add_file ?mtime (self:t) ~path content : unit =
+    let mtime = match mtime with Some t -> t | None -> self.mtime in
+    let dir_path, basename = split_path_ path in
+    if List.mem ".." dir_path then (
+      invalid_arg "add_file: '..' is not allowed";
+    );
+
+    let rec loop self dir = match dir with
+      | [] ->
+        self.entries <- Str_map.add basename (File {mtime; content}) self.entries
+      | d :: ds ->
+        let sub =
+          match Str_map.find d self.entries with
+          | Dir sub -> sub
+          | File _ ->
+            invalid_arg
+              (Printf.sprintf "in path %S, %S is a file, not a directory" path d)
+          | exception Not_found ->
+            let sub = create ~mtime:self.mtime () in
+            self.entries <- Str_map.add d (Dir sub) self.entries;
+            sub
+        in
+        loop sub ds
+    in
+    loop self dir_path
+
+  (* find entry *)
+  let find_ self path : entry option =
+    let dir_path, basename = split_path_ path in
+    let rec loop self dir_name = match dir_name with
+      | [] -> (try Some (Str_map.find basename self.entries) with _ -> None)
+      | d :: ds ->
+        match Str_map.find d self.entries with
+        | exception Not_found -> None
+        | File _ -> None
+        | Dir sub -> loop sub ds
+    in
+    if path="" then Some (Dir self)
+    else loop self dir_path
+
+  let to_vfs self : vfs =
+    let module M = struct
+      let descr = "Embedded_fs"
+      let file_mtime p = match find_ self p with
+        | Some (File {mtime;_}) -> Some mtime
+        | Some (Dir _) -> Some self.mtime
+        | _ -> None
+
+      let file_size p = match find_ self p with
+        | Some (File {content;_}) -> Some (String.length content)
+        | _ -> None
+
+      let contains p = S._debug (fun k->k "contains %S" p); match find_ self p with
+        | Some _ -> true
+        | None -> false
+
+      let is_directory p = match find_ self p with
+        | Some (Dir _) -> true
+        | _ -> false
+
+      let read_file_content p = match find_ self p with
+        | Some (File {content;_}) -> Tiny_httpd.Byte_stream.of_string content
+        | _ -> failwith (Printf.sprintf "no such file: %S" p)
+
+      let list_dir p = S._debug (fun k->k "list dir %S" p); match find_ self p with
+        | Some (Dir sub) ->
+          Str_map.fold (fun sub _ acc -> sub::acc) sub.entries [] |> Array.of_list
+        | _ -> failwith (Printf.sprintf "no such directory: %S" p)
+
+      let create _ = failwith "Embedded_fs is read-only"
+      let delete _ = failwith "Embedded_fs is read-only"
+
+    end in (module M)
+
+end
+

src/Tiny_httpd_dir.mli

@@ -23,7 +23,12 @@ type dir_behavior =
   | Forbidden
   (** Forbid access to directory. This is suited for serving assets, for example. *)
 
-(** configuration for static file handlers *)
+type hidden
+(** Type used to prevent users from building a config directly.
+    Use {!default_config} or {!config} instead. *)
+
+(** configuration for static file handlers. This might get
+    more fields over time. *)
 type config = {
   mutable download: bool;
   (** Is downloading files allowed? *)
@@ -40,6 +45,9 @@ type config = {
   mutable max_upload_size: int;
   (** If {!upload} is true, this is the maximum size in bytes for
       uploaded files. *)
+
+  _rest: hidden;
+  (** Just ignore this field. *)
 }
 
 (** default configuration: [
@@ -51,6 +59,17 @@ type config = {
   }] *)
 val default_config : unit -> config
 
+val config :
+  ?download:bool ->
+  ?dir_behavior:dir_behavior ->
+  ?delete:bool ->
+  ?upload:bool ->
+  ?max_upload_size:int ->
+  unit ->
+  config
+(** Build a config from {!default_config}.
+    @since NEXT_RELEASE *)
+
 (** [add_dirpath ~config ~dir ~prefix server] adds route handle to the
     [server] to serve static files in [dir] when url starts with [prefix],
     using the given configuration [config]. *)
@@ -59,3 +78,74 @@ val add_dir_path :
   dir:string ->
   prefix:string ->
   Tiny_httpd.t -> unit
+
+(** Virtual file system.
+
+    This is used to emulate a file system from pure OCaml functions and data,
+    e.g. for resources bundled inside the web server.
+    @since NEXT_RELEASE
+*)
+module type VFS = sig
+  val descr : string
+  (** Description of the VFS *)
+
+  val is_directory : string -> bool
+
+  val contains : string -> bool
+  (** [file_exists vfs path] returns [true] if [path] points to a file
+      or directory inside [vfs]. *)
+
+  val list_dir : string -> string array
+  (** List directory. This only returns basenames, the files need
+      to be put in the directory path using {!Filename.concat}. *)
+
+  val delete : string -> unit
+  (** Delete path *)
+
+  val create : string -> (bytes -> int -> int -> unit) * (unit -> unit)
+  (** Create a file and obtain a pair [write, close] *)
+
+  val read_file_content : string -> Tiny_httpd.Byte_stream.t
+  (** Read content of a file *)
+
+  val file_size : string -> int option
+  (** File size, e.g. using "stat" *)
+
+  val file_mtime : string -> float option
+  (** File modification time, e.g. using "stat" *)
+end
+
+val vfs_of_dir : string -> (module VFS)
+(** [vfs_of_dir dir] makes a virtual file system that reads from the
+    disk.
+    @since NEXT_RELEASE
+*)
+
+val add_vfs :
+  config:config ->
+  vfs:(module VFS) ->
+  prefix:string ->
+  Tiny_httpd.t -> unit
+(** Similar to {!add_dir_path} but using a virtual file system instead.
+    @since NEXT_RELEASE
+*)
+
+(** An embedded file system, as a list of files with (relative) paths.
+    This is useful in combination with the "tiny-httpd-mkfs" tool,
+    which embeds the files it's given into a OCaml module.
+
+    @since NEXT_RELEASE
+*)
+module Embedded_fs : sig
+  type t
+  (** The pseudo-filesystem *)
+
+  val create : ?mtime:float -> unit -> t
+
+  val add_file : ?mtime:float -> t -> path:string -> string -> unit
+  (** Add file to the virtual file system.
+      @raise Invalid_argument if the path contains '..' or if it tries to
+      make a directory out of an existing path that is a file. *)
+
+  val to_vfs : t -> (module VFS)
+end

src/bin/dune

@@ -3,5 +3,14 @@
   (name http_of_dir)
   (public_name http_of_dir)
   (package tiny_httpd)
+  (modules http_of_dir)
   (flags :standard -warn-error -3)
   (libraries tiny_httpd))
+
+(executable
+  (name vfs_pack)
+  (public_name tiny-httpd-vfs-pack)
+  (package tiny_httpd)
+  (modules vfs_pack)
+  (libraries curly unix)
+  (flags :standard -warn-error -3))

src/bin/http_of_dir.ml

@@ -20,8 +20,9 @@ let parse_size s : int =
   with _ -> raise (Arg.Bad "invalid size (expected <int>[kM]?)")
 
 let main () =
-  let config = D.default_config() in
-  config.dir_behavior <- Index_or_lists; (* keep old behavior *)
+  let config =
+    D.config ~dir_behavior:Index_or_lists ()
+  in
   let dir_ = ref "." in
   let addr = ref "127.0.0.1" in
   let port = ref 8080 in

src/bin/vfs_pack.ml

@@ -0,0 +1,162 @@
+
+let spf = Printf.sprintf
+let fpf = Printf.fprintf
+let now_ = Unix.gettimeofday()
+let verbose = ref false
+
+type entry =
+  | File of string * string
+  | Url of string * string
+  | Mirror of string * string
+  | Source_file of string
+
+let read_file filename =
+  let ic = open_in_bin filename in
+  let buf = Buffer.create 32 in
+  let b = Bytes.create 1024 in
+  while
+    let n=input ic b 0 (Bytes.length b) in
+    Buffer.add_subbytes buf b 0 n;
+    n > 0
+  do () done;
+  close_in ic;
+  Buffer.contents buf
+
+let split_comma s = Scanf.sscanf s "%s@,%s" (fun x y -> x,y)
+
+let is_url s =
+  let is_prefix pre s =
+    String.length s > String.length pre &&
+    String.sub s 0 (String.length pre) = pre
+  in
+  is_prefix "http://" s || is_prefix "https://" s
+
+let emit oc (l:entry list) : unit =
+  fpf oc "let embedded_fs = Tiny_httpd_dir.Embedded_fs.create ~mtime:%f ()\n" now_;
+
+  let add_vfs ~mtime vfs_path content =
+    fpf oc
+      "let () = Tiny_httpd_dir.Embedded_fs.add_file embedded_fs \n  \
+       ~mtime:%h ~path:%S\n  \
+       %S\n"
+      mtime vfs_path content
+  in
+
+  let rec add_entry = function
+    | File (vfs_path, actual_path) ->
+      if !verbose then Printf.eprintf "add file %S = %S\n%!" vfs_path actual_path;
+
+      let content = read_file actual_path in
+      let mtime = (Unix.stat actual_path).Unix.st_mtime in
+      add_vfs ~mtime vfs_path content
+
+    | Url (vfs_path, url) ->
+      if !verbose then Printf.eprintf "add url %S = %S\n%!" vfs_path url;
+
+      begin match Curly.get url with
+        | Ok b ->
+          let code = b.Curly.Response.code in
+          if code >= 200 && code < 300 then (
+            add_vfs ~mtime:now_ vfs_path b.Curly.Response.body
+          ) else (
+            failwith (Printf.sprintf "download of %S failed with code: %d" url code)
+          )
+        | Error err ->
+          failwith (Format.asprintf "download of %S failed: %a" url Curly.Error.pp err)
+      end
+
+    | Mirror (vfs_path, dir) ->
+      if !verbose then Printf.eprintf "mirror directory %S as %S\n%!" dir vfs_path;
+
+      let rec traverse rpath =
+        let real_path = Filename.concat dir rpath in
+        if Sys.is_directory real_path then (
+          let arr = Sys.readdir real_path in
+          Array.iter (fun e -> traverse (Filename.concat rpath e)) arr
+        ) else (
+          add_entry (File (Filename.concat vfs_path rpath, real_path))
+        )
+      in
+      traverse "."
+
+    | Source_file f ->
+      if !verbose then Printf.eprintf "read source file %S\n%!" f;
+
+      let lines =
+        read_file f |> String.split_on_char '\n'
+        |> List.map String.trim
+        |> List.filter ((<>) "")
+      in
+
+      let process_line line =
+        let vfs_path, path = split_comma line in
+        if is_url path then add_entry (Url(vfs_path, path))
+        else add_entry (File (vfs_path, path))
+      in
+
+      List.iter process_line lines
+  in
+  List.iter add_entry l;
+
+  fpf oc "let vfs = Tiny_httpd_dir.Embedded_fs.to_vfs embedded_fs\n";
+  ()
+
+
+let help = {|vfs-pack [opt]+
+
+Builds an OCaml module containing a `Tiny_httpd_dir.Embedded_fs.t`
+virtual file system. This is useful to pack assets into an OCaml binary,
+for example.
+
+Each entry in the VFS can be added from the command line using:
+
+--file=foo/bar,actual/path/to/file to add an entry foo/bar in the VFS
+  with the content of actual/path/to/file. The mtime of the file is preserved.
+
+--url=foo/bar,https://something.com/ to add an entry foo/bar in the VFS
+  with the content of the URL (downloaded using curl).
+
+-F=file reads lines from file. Each line is a pair vfs_path,actual_path
+and is processed as previously. If actual_path looks like an http(s) URL
+it is treated as such.
+|}
+
+
+let () =
+  let entries = ref [] in
+  let out = ref "" in
+
+  let add_entry e = entries := e :: !entries in
+
+  let add_file s =
+    let vfs_path, path = split_comma s in
+    add_entry (File (vfs_path, path))
+  and add_mirror s =
+    let vfs_path, path = split_comma s in
+    let vfs_path, path = if path="" then "", vfs_path else vfs_path, path in
+    add_entry (Mirror (vfs_path, path))
+  and add_source f = add_entry (Source_file f)
+  and add_url s =
+    let vfs_path, path = split_comma s in
+    if is_url path then add_entry (Url(vfs_path, path))
+    else invalid_arg (spf "--url: invalid URL %S" path)
+  in
+
+  let opts = [
+    "-v", Arg.Set verbose, " verbose mode";
+    "-o", Arg.Set_string out, " set output file";
+    "--file", Arg.String add_file, " <name,file> adds name=file to the VFS";
+    "--url", Arg.String add_url, " <name,url> adds name=url to the VFS";
+    "--mirror", Arg.String add_mirror, " <prefix,dir> copies directory dir into the VFS under prefix";
+    "-F", Arg.String add_source, " <file> reads entries from the file, on per line";
+  ] |> Arg.align in
+  Arg.parse opts (fun _ -> raise (Arg.Help "no positional arg")) help;
+
+  let out, close =
+    if !out="" then stdout,ignore
+    else open_out !out, close_out
+  in
+  emit out !entries;
+  close out;
+  exit 0
+

tiny_httpd.opam

@@ -12,6 +12,7 @@ build: [
 depends: [
   "dune" { >= "2.0" }
   "base-threads"
+  "result"
   "ocaml" { >= "4.04.0" }
   "odoc" {with-doc}
   "qtest" { >= "2.9" & with-test}

vendor/curly

@@ -0,0 +1 @@
+Subproject commit 9417bd97fdf293f469c38e726c169583638d5aa1

vfs_path.sh

@@ -0,0 +1,2 @@
+#!/bin/sh
+exec dune exec --display=quiet src/bin/vfs_pack.exe --profile=release -- $@