-
Notifications
You must be signed in to change notification settings - Fork 2
/
fileHandler.ml
100 lines (90 loc) · 2.58 KB
/
fileHandler.ml
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
open Unix
open Server
let check_dir d =
if (stat d).st_kind <> S_DIR
then raise (Unix_error (ENOTDIR,"check_dir",d))
let parent_regex =
Str.regexp (".*" ^ (Str.quote Filename.parent_dir_name))
let check_uri uri =
try
if String.get uri 0 <> '/' then raise Forbidden
else if Str.string_match parent_regex uri 0 then raise Forbidden
else String.sub uri 1 (String.length uri - 1)
with
Invalid_argument _ -> raise Forbidden
let default_content_type = "text/plain"
let content_type path =
try
let i = String.rindex path '.' + 1 in
let k = String.length path - i in
let ext = String.sub path i k in
match ext with
| "html" -> "text/html"
| "htm" -> "text/html"
| "txt" -> "text/plain"
| "png" -> "image/png"
| "gif" -> "image/gif"
| "jpg" -> "image/jpeg"
| "pdf" -> "application/pdf"
| _ -> default_content_type
with Not_found -> default_content_type
let headers req o (path, st) =
Printf.fprintf o
"HTTP/1.1 200 OK\r\n\
Server: MetaOCaml/%s\r\n\
Connection: %s\r\n\
Date: %s\r\n\
Last-modified: %s\r\n\
Content-type: %s\r\n\
Content-length: %d\r\n\r\n"
Sys.ocaml_version
(Request.keep_alive req)
(TimeStamp.now())
(TimeStamp.format st.st_mtime)
(content_type path)
st.st_size
let copy o' (path, st) =
flush o';
let o = descr_of_out_channel o' in
let i = openfile path [O_RDONLY] 0 in
let size = min st.st_size Server.bufsize in
let buf = String.create size in
while
match read i buf 0 size with
0 -> false
| n -> let m = write o buf 0 n in
if m <> n then failwith "FileHandler.copy: not all bytes written";
true
do()
done;
close i
let stat' path =
try stat path
with Unix_error(ENOENT,_,_) -> raise Not_found
let rec find path st =
match st.st_kind with
| S_DIR ->
let path = Filename.concat path "index.html"
in find path (stat' path)
| S_REG ->
if st.st_perm land 0o004 = 0 (* world-readable? *)
then raise Forbidden
else (path, st)
| _ -> raise Forbidden
open LogFile
let root d =
(check_dir d;
fun req o ->
match Request.meth req with
(Request.GET | Request.HEAD) ->
let uri = check_uri (Request.uri req) in
let path = Filename.concat d uri in
let r = find path (stat' path) in
(try
headers req o r;
if Request.meth req = Request.GET
then copy o r;
Status.Ok
with
Sys_error "Broken pipe" -> raise Exit)
| _ -> raise Not_implemented)