diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml
index 6a7f4629..1c002c17 100644
--- a/.github/workflows/main.yml
+++ b/.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' }}
diff --git a/.gitmodules b/.gitmodules
new file mode 100644
index 00000000..f5f716b3
--- /dev/null
+++ b/.gitmodules
@@ -0,0 +1,3 @@
+[submodule "vendor/curly"]
+ path = vendor/curly
+ url = https://github.com/rgrinberg/curly.git
diff --git a/README.md b/README.md
index 81a8bf07..27e8968d 100644
--- a/README.md
+++ b/README.md
@@ -1,7 +1,8 @@
# Tiny_httpd [](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
diff --git a/examples/dune b/examples/dune
index 83b0aa84..92c22b90 100644
--- a/examples/dune
+++ b/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")))))
diff --git a/examples/echo.ml b/examples/echo.ml
index f77bbe72..d2ae7b16 100644
--- a/examples/echo.ml
+++ b/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 = "
\n\
welcome!\n
endpoints are:\n
\
/hello/'name' (GET)
\n\
- /echo/ (GET) echoes back query
\n\
+ /echo/ (GET) echoes back query
\n\
/upload/'path' (PUT) to upload a file
\n\
/zcat/'path' (GET) to download a file (compressed)
\n\
/stats/ (GET) to access statistics
\n\
+ /vfs/ (GET) to access statistics
\n\
"
in
S.Response.make_string ~headers:["content-type", "text/html"] @@ Ok s);
diff --git a/examples/files/a.txt b/examples/files/a.txt
new file mode 100644
index 00000000..94954abd
--- /dev/null
+++ b/examples/files/a.txt
@@ -0,0 +1,2 @@
+hello
+world
diff --git a/examples/files/foo.html b/examples/files/foo.html
new file mode 100644
index 00000000..2f00ada8
--- /dev/null
+++ b/examples/files/foo.html
@@ -0,0 +1,18 @@
+
+
+
+
+
+
+ hello!
+
+ - item 1
+ - item 2
+ - item 3
+ - item 4
+
+
+ escape from this file
+
+
+
diff --git a/examples/files/sub/b.txt b/examples/files/sub/b.txt
new file mode 100644
index 00000000..8493a14a
--- /dev/null
+++ b/examples/files/sub/b.txt
@@ -0,0 +1 @@
+lorem ipsum etc.
diff --git a/examples/files/sub/yolo.html b/examples/files/sub/yolo.html
new file mode 100644
index 00000000..c7ecbf5e
--- /dev/null
+++ b/examples/files/sub/yolo.html
@@ -0,0 +1,18 @@
+
+
+
+
+
+
+ funky:
+
+
+
+
diff --git a/src/Tiny_httpd_dir.ml b/src/Tiny_httpd_dir.ml
index 3aadfdc6..6fe9a6ac 100644
--- a/src/Tiny_httpd_dir.ml
+++ b/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 {| http_of_dir %S
+ Printf.bprintf body {| list directory %S
Index of %S
- |} top d;
+ |} VFS.descr d;
begin match parent with
| None -> ()
| Some p ->
Printf.bprintf body " (parent directory) \n"
- (encode_path p);
+ (encode_path (prefix // p));
end;
Printf.bprintf body "\n";
let hidden_stop = ref 0 in
@@ -74,16 +127,18 @@ let html_list_dir ~top ~parent d : string =
Printf.bprintf body "\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 " - %s [invalid file]
\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 " - %s %s%s
\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
+
diff --git a/src/Tiny_httpd_dir.mli b/src/Tiny_httpd_dir.mli
index fbd457d9..16c1491a 100644
--- a/src/Tiny_httpd_dir.mli
+++ b/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
diff --git a/src/bin/dune b/src/bin/dune
index 31303a70..36eb79c5 100644
--- a/src/bin/dune
+++ b/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))
diff --git a/src/bin/http_of_dir.ml b/src/bin/http_of_dir.ml
index 395efe26..e532ac19 100644
--- a/src/bin/http_of_dir.ml
+++ b/src/bin/http_of_dir.ml
@@ -20,8 +20,9 @@ let parse_size s : int =
with _ -> raise (Arg.Bad "invalid size (expected [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
diff --git a/src/bin/vfs_pack.ml b/src/bin/vfs_pack.ml
new file mode 100644
index 00000000..ba5e0156
--- /dev/null
+++ b/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, " adds name=file to the VFS";
+ "--url", Arg.String add_url, " adds name=url to the VFS";
+ "--mirror", Arg.String add_mirror, " copies directory dir into the VFS under prefix";
+ "-F", Arg.String add_source, " 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
+
diff --git a/tiny_httpd.opam b/tiny_httpd.opam
index 1e50a45c..631e5d79 100644
--- a/tiny_httpd.opam
+++ b/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}
diff --git a/vendor/curly b/vendor/curly
new file mode 160000
index 00000000..9417bd97
--- /dev/null
+++ b/vendor/curly
@@ -0,0 +1 @@
+Subproject commit 9417bd97fdf293f469c38e726c169583638d5aa1
diff --git a/vfs_path.sh b/vfs_path.sh
new file mode 100755
index 00000000..0ffdbe90
--- /dev/null
+++ b/vfs_path.sh
@@ -0,0 +1,2 @@
+#!/bin/sh
+exec dune exec --display=quiet src/bin/vfs_pack.exe --profile=release -- $@