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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
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 path =
match String.index_opt path '?' with
| Some i -> String.sub path 0 i
| None -> path
in
let path =
match String.index_opt path '#' with
| Some i -> String.sub path 0 i
| None -> path
in
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"
| ".xml" | ".rss" | ".atom" | ".feed" -> "application/xml"
| _ -> "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
let error500 msg =
Format.asprintf
"<h1>500 Internal server error</h1><hr /><p>The build failed while \
refreshing the site.</p><pre>%s</pre>"
msg
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)