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
132
133
134
135
136
137
module type DIR = sig
module IO : Types.IO
type path
val exists : path -> bool IO.t
val kind : path -> [ `Regular_file | `Directory | `Other ] IO.t
val read : path -> string list IO.t
val concat : path -> string -> path
val response_document : ?mime:Mime.t -> path -> Response.t IO.t
val pp_io_err : Format.formatter -> exn -> unit
end
module type S = sig
module IO : Types.IO
type addr
type handler = addr Handler.Make(IO).t
type dir_path
val static :
?handler:(dir_path -> handler) ->
?dir_listing:
(([ `Regular_file | `Directory | `Other ] * string) list -> handler) ->
?index:string ->
?show_hidden:bool ->
dir_path ->
handler
end
module Make (Dir : DIR) (Addr : Types.T) :
S
with module IO := Dir.IO
and type addr := Addr.t
and type dir_path := Dir.path = struct
type handler = Addr.t Handler.Make(Dir.IO).t
let src = Logs.Src.create "mehari.static"
module Log = (val Logs.src_log src)
let ( let* ) = Dir.IO.bind
let pp_kind fmt = function
| `Regular_file -> Format.pp_print_string fmt "\u{1F4C4}"
| `Directory -> Format.pp_print_string fmt "\u{1F4C1}"
| `Other -> Format.pp_print_string fmt "\u{2753}"
let default_handler path req =
let fname = Request.param req 1 in
let mime =
match Mime.from_filename fname with
| None when Filename.check_suffix fname ".gmi" -> Some (Mime.gemini ())
| (None | Some _) as m -> m
in
Dir.response_document ?mime path
let parent_path =
Re.(compile (seq [ Re.group (seq [ rep1 any; char '/' ]); rep1 any ]))
let default_listing files req =
let dirs =
List.map
(fun (kind, fname) ->
let name = Format.asprintf "%a %s" pp_kind kind fname in
Filename.concat (Request.target req) fname |> Gemtext.link ~name)
files
in
let title =
Request.param req 1 |> Printf.sprintf "Index: %s" |> Gemtext.heading `H1
in
let =
if Request.target req = "" then title :: dirs
else
match Request.uri req |> Uri.to_string |> Re.exec_opt parent_path with
| None -> title :: dirs
| Some grp ->
let name =
Format.asprintf "%a Parent directory" pp_kind `Directory
in
let link = Re.Group.get grp 1 |> Gemtext.link ~name in
title :: link :: Gemtext.newline :: dirs
in
menu |> Response.response_gemtext |> Dir.IO.return
let read_dir ~show_hidden ~index path =
let* files = Dir.read path in
List.fold_left
(fun acc fname ->
let* acc = acc in
if String.equal fname index then
`Index (Dir.concat path fname) |> Dir.IO.return
else
match acc with
| `Index _ -> Dir.IO.return acc
| `Filenames fnames ->
if (not show_hidden) && String.starts_with ~prefix:"." fname then
`Filenames fnames |> Dir.IO.return
else
let* kind = Dir.concat path fname |> Dir.kind in
`Filenames ((kind, fname) :: fnames) |> Dir.IO.return)
(`Filenames [] |> Dir.IO.return)
files
let reference_parent path =
String.fold_left
(fun (acc, dot) -> function
| '.' when dot -> (true, dot)
| '.' -> (acc, true)
| _ -> (acc, dot))
(false, false) path
|> fst
let not_found = Response.(response Status.not_found "") |> Dir.IO.return
let static ?(handler = default_handler) ?(dir_listing = default_listing)
?(index = "index.gmi") ?(show_hidden = false) base_path req =
let req_path = Request.param req 1 |> Uri.pct_decode in
if reference_parent req_path then not_found
else
let path = Dir.concat base_path req_path in
try
let* is_exists = Dir.exists path in
if is_exists then
let* kind = Dir.kind path in
match kind with
| `Regular_file -> handler path req
| `Directory ->
Dir.IO.bind (read_dir ~show_hidden ~index path) (function
| `Filenames fnames -> dir_listing fnames req
| `Index index_path -> handler index_path req)
| `Other -> not_found
else not_found
with io ->
Log.warn (fun log -> log "%a" Dir.pp_io_err io);
not_found
end