1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
module Kind = struct
type t = Directory of string | File of string
let from_path ~is_directory ~concat base_path element =
let fpath = concat base_path element in
if is_directory fpath then Directory element else File element
end
module Request_path = struct
type 'a t = File of 'a * string | Dir of 'a * string list | Error404
let from_path ~is_file ~is_directory ~concat ~native htdoc ~path =
let lpath =
path
|> String.split_on_char '/'
|> List.filter (fun s -> not String.(equal s empty))
in
let spath = String.concat "/" lpath in
if String.equal spath "" then Dir (htdoc, lpath)
else
let path = concat htdoc spath in
let pstr = native path in
if is_directory path then Dir (path, lpath)
else if is_file path then File (path, pstr)
else Error404
let content_type file =
match Filename.extension file with
| ".html" -> "text/html"
| ".jpg" | ".jpeg" -> "image/jpeg"
| ".png" -> "image/png"
| ".gif" -> "image/gif"
| ".svg" -> "image/svg+xml"
| ".css" -> "text/css"
| ".js" -> "text/javascript"
| ".json" -> "application/json"
| _ -> "text/plain"
end
module Pages = struct
let error404 htdoc =
Format.asprintf
"<h1>Error 404</h1><hr /><p>You can generate a <code>404.html</code> \
page at the root (<code>%s</code>) of your target as a fallback.</p>"
htdoc
let expand path =
let a =
List.fold_left
(fun acc path ->
match acc with
| [] -> [ [ path ] ]
| x :: xs -> (path :: x) :: List.rev x :: xs)
[] path
|> function
| x :: xs -> List.rev (List.rev x :: xs)
| [] -> []
in
("root", "") :: List.map2 (fun x y -> (x, String.concat "/" y)) path a
let directory path children =
let full_path =
match path with [] -> "" | path -> "/" ^ String.concat "/" path
in
let top =
path
|> expand
|> List.map (fun (n, u) -> Format.asprintf {|<a href="/%s">%s</a>|} u n)
|> String.concat "/"
in
let children =
List.sort
(fun a b ->
match (a, b) with
| Kind.File _, Directory _ -> 1
| Directory _, File _ -> -1
| File a, File b | Directory a, Directory b -> String.compare a b)
children
in
let listing =
List.map
(fun x ->
let char, value =
match x with Kind.Directory x -> ("📁", x) | File x -> ("🖹", x)
in
Format.asprintf {|<li>%s <a href="%s">%s</a></li>|} char
(full_path ^ "/" ^ value)
value)
children
|> String.concat ""
in
Format.asprintf "<nav><h1>%s</h1></nav><ul>%s</ul>" top listing
end
let prompt port =
Logs.info (fun f -> f "Launching server <http://localhost:%04d>" port)
let exn_handler pp exn = Logs.warn (fun fmt -> fmt "%a" pp exn)