Skip to content

Commit 94e7900

Browse files
stilschersim642
stilscher
authored and
sim642
committed
serve files from run directory
1 parent eea537a commit 94e7900

File tree

2 files changed

+96
-7
lines changed

2 files changed

+96
-7
lines changed

‎goblint-http-server/dune‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
cohttp
77
cohttp-lwt
88
cohttp-lwt-unix
9+
cohttp-server-lwt-unix
910
conduit-lwt-unix
1011
jsonrpc
1112
lwt.unix

‎goblint-http-server/goblint_http.ml‎

Lines changed: 95 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -5,13 +5,17 @@ open Lwt.Infix
55

66
module Yojson_conv = Ppx_yojson_conv_lib.Yojson_conv
77

8+
let docroot = ref "run"
9+
let index = ref "index.html"
810
let addr = ref "127.0.0.1"
911
let port = ref 8080
1012
let goblint = ref "goblint"
1113
let rest = ref []
1214

1315
let specs =
1416
[
17+
("-docroot", Arg.Set_string docroot, "Serving directory");
18+
("-index", Arg.Set_string index, "Name of index file in directory");
1519
("-addr", Arg.Set_string addr, "Listen address");
1620
("-port", Arg.Set_int port, "Listen port");
1721
("-with-goblint", Arg.Set_string goblint, "Path to the Goblint executable");
@@ -41,11 +45,95 @@ let process state name body =
4145
>>= fun body -> Server.respond_string ~status:`OK ~body ())
4246
(fun exn -> Server.respond_error ~status:`Bad_request ~body:(Printexc.to_string exn) ())
4347

44-
let forward (state: State.t) path = match state.save_run with
45-
| Some save_run ->
46-
let fname = Filename.concat save_run path in
47-
Server.respond_file ~fname ()
48-
| None -> Server.respond_not_found ()
48+
(* The serving of files is implemented similar as in the binary https://github.com/mirage/ocaml-cohttp/blob/master/cohttp-lwt-unix/bin/cohttp_server_lwt.ml *)
49+
let serve_file ~docroot ~uri =
50+
let fname = Cohttp.Path.resolve_local_file ~docroot ~uri in
51+
Server.respond_file ~fname ()
52+
53+
let sort lst =
54+
let compare_kind = function
55+
| Some Unix.S_DIR, Some Unix.S_DIR -> 0
56+
| Some Unix.S_DIR, _ -> -1
57+
| _, Some Unix.S_DIR -> 1
58+
| Some Unix.S_REG, Some Unix.S_REG -> 0
59+
| Some Unix.S_REG, _ -> 1
60+
| _, Some Unix.S_REG -> -1
61+
| _, _ -> 0 in
62+
List.sort
63+
(fun (ka, a) (kb, b) ->
64+
let c = compare_kind (ka, kb) in
65+
if c <> 0 then c
66+
else String.compare (String.lowercase_ascii a) (String.lowercase_ascii b))
67+
lst
68+
69+
let html_of_listing uri path listing =
70+
let li l =
71+
Printf.sprintf "<li><a href=\"%s\">%s</a></li>" (Uri.to_string l) in
72+
let html =
73+
List.map
74+
(fun (kind, f) ->
75+
let encoded_f = Uri.pct_encode f in
76+
match kind with
77+
| Some Unix.S_DIR ->
78+
let link = Uri.with_path uri (Filename.concat path (Filename.concat encoded_f "")) in
79+
li link (Printf.sprintf "<i>%s/</i>" f)
80+
| Some Unix.S_REG ->
81+
let link = Uri.with_path uri (Filename.concat path encoded_f) in
82+
li link f
83+
| Some _ ->
84+
Printf.sprintf "<li><s>%s</s></li>" f
85+
| None -> Printf.sprintf "<li>Error with file: %s</li>" f)
86+
listing
87+
in
88+
let contents = String.concat "\n" html in
89+
Printf.sprintf
90+
"<html><body><h2>Directory Listing for <em>%s</em></h2><ul>%s</ul><hr \
91+
/></body></html>"
92+
(Uri.pct_decode path) contents
93+
94+
let serve uri path =
95+
let file_name = Cohttp.Path.resolve_local_file ~docroot:!docroot ~uri in
96+
Lwt.catch
97+
(fun () ->
98+
Lwt_unix.lstat file_name >>= fun stat -> (* for symbolic links lstat returns S_LNK, which will result in a
99+
forbidden error in this implementation. Use stat instead if symbolic links to folders or files should be handled
100+
just like folders or files respectively *)
101+
match stat.Unix.st_kind with
102+
| Unix.S_DIR -> (
103+
let path_len = String.length path in
104+
if path_len <> 0 && path.[path_len - 1] <> '/' then (
105+
Server.respond_redirect ~uri:(Uri.with_path uri (path ^ "/")) ())
106+
else (
107+
match Sys.file_exists (Filename.concat file_name !index) with
108+
| true -> (
109+
let uri = Uri.with_path uri (Filename.concat path !index) in
110+
serve_file ~docroot:!docroot ~uri)
111+
| false ->
112+
let%lwt files = Lwt_stream.to_list
113+
(Lwt_stream.filter (fun s -> s <> "." && s <> "..") (Lwt_unix.files_of_directory file_name)) in
114+
let%lwt listing = Lwt_list.map_s (fun f ->
115+
let file_name = Filename.concat file_name f in
116+
Lwt.try_bind
117+
(fun () -> Lwt_unix.LargeFile.stat file_name)
118+
(fun stat ->
119+
Lwt.return
120+
( Some
121+
stat.Unix.LargeFile.st_kind,
122+
f ))
123+
(fun _exn -> Lwt.return (None, f))) files in
124+
let body = html_of_listing uri path (sort listing) in
125+
Server.respond_string ~status:`OK ~body ()))
126+
| Unix.S_REG -> serve_file ~docroot:!docroot ~uri
127+
| _ -> (
128+
let body = Printf.sprintf "<html><body><h2>Forbidden</h2><p><b>%s</b> is not a normal file or \
129+
directory</p><hr/></body></html>" path in
130+
Server.respond_string ~status:`OK ~body ()))
131+
(function
132+
| Unix.Unix_error (Unix.ENOENT, "stat", p) as e ->
133+
if p = file_name then (
134+
Server.respond_not_found ())
135+
else Lwt.fail e
136+
| e -> Lwt.fail e)
49137

50138
let callback state _ req body =
51139
let uri = Request.uri req in
@@ -54,7 +142,7 @@ let callback state _ req body =
54142
let meth = Request.meth req in
55143
match meth, parts with
56144
| `POST, ["api"; name] -> process state name body
57-
| `GET, _ -> forward state path
145+
| `GET, _ -> serve uri path
58146
| _ -> Server.respond_not_found ()
59147

60148
let main () =
@@ -65,6 +153,6 @@ let main () =
65153

66154
let () =
67155
let program = Sys.argv.(0) in
68-
let usage = Printf.sprintf "%s [-addr ADDR] [-port PORT] ... path [path ...]" program in
156+
let usage = Printf.sprintf "%s [-docroot DOCROOT] [-index INDEX] [-addr ADDR] [-port PORT] ... path [path ...]" program in
69157
Arg.parse specs (fun s -> paths := s :: !paths) usage;
70158
Lwt_main.run (main ())

0 commit comments

Comments
 (0)