-
Notifications
You must be signed in to change notification settings - Fork 125
/
httpServerCommon.ml
326 lines (288 loc) · 13.8 KB
/
httpServerCommon.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
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
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* httpServerCommon.ml
*
*)
module List = Base.List
module String = Base.String
module Char = Base.Char
module Rc = Rcontent
module HSCp = HttpServerCore_parse
module HST = HttpServerTypes
module HSC = HttpServerCore
module HT = HttpTools
#<Debugvar:HTTP_DEBUG>
let make_server_info addr port secure =
let ip_or_name =
match Unix.string_of_inet_addr addr with
| "0.0.0.0" -> Unix.gethostname ()
| ip -> ip
in
let portstr = if port = 80 then "" else Printf.sprintf ":%d" port in
let server_url = Printf.sprintf "http%s://%s%s" (if secure then "s" else "") ip_or_name portstr in
{ HST.server_url=server_url; HST.server_id=0; HST.server_ip_or_name=ip_or_name;
HST.server_port=port; HST.server_secured=secure; }
(* Protection against DNS-rebinding attacks *)
let set_allowed_hosts li = HSC.allowed_hosts := li
let check_host headers =
match List.find_opt (function HSCp.Host _ -> true | _ -> false) headers with
Some (HSCp.Host host) ->
if !(HSC.allowed_hosts) <> [] && not (List.mem host !(HSC.allowed_hosts))
then (Logger.error "Host is unknown: %s" host;
failwith "error, aborting")
else #<If$minlevel 10>Logger.debug "check_host %s OK.\n%!" ("["^(String.concat "," (!(HSC.allowed_hosts)))^"]")#<End>
| None -> ()
| _ -> assert false
(* Cookies:
cookies2In: decides whether to call Cookie2 or CookieLong, or no cookies at all.
cookies2Out: installs Set_Cookie in headers.
*)
let get_version version = if version = 1 then Printf.sprintf "; version=%d" version else ""
let get_expires delcookies expires =
if delcookies
then "; expires=Thu, 01-Jan-1970 00:00:01 GMT"
else if Time.is_positive expires
then "; expires="^(Date.rfc1123 (Time.gmtime (Time.add (Time.now()) expires)))
else ""
let get_max_age delcookies expires =
if delcookies
then "; max-age=0"
else if Time.is_positive expires
then "; max-age="^(string_of_int (truncate (Time.in_seconds expires)))
else ""
let get_object quotes name obj_opt =
let q = if quotes then "\"" else "" in
Option.default_map "" (fun obj -> if obj <> "" then "; "^name^"="^q^obj^q else "") obj_opt
let get_path quotes path_opt = get_object quotes "path" path_opt
let get_domain quotes domain_opt = get_object quotes "domain" domain_opt
let get_comment comment_opt = get_object true "comment" comment_opt
let get_commenturl commenturl_opt = get_object true "commenturl" commenturl_opt
let get_secure secure = if secure then "; secure" else ""
let get_discard discard = if discard then "; discard" else ""
let portstr num =
if num >= 0 && num < 65535
then string_of_int num
else raise (Failure (Printf.sprintf "Cookie port num ouit of range %d" num))
let get_ports = function
Some [] -> "; Port"
| Some ports -> "; Port=\""^(String.concat "," (List.map portstr ports))^"\""
| None -> ""
let use_long_cookies = ref true
let cookieless_uris = ref StringSet.empty
let add_cookieless_uri uri = cookieless_uris := StringSet.add uri !cookieless_uris
let _ = List.iter add_cookieless_uri ["/favicon.ico"; "/favicon.gif"]
let cookies2In (hr:HST.handle_request) (uri:string) =
if StringSet.mem uri !cookieless_uris
then hr
else
if !use_long_cookies
then CookieLong.get_internal hr
else
let (_c2type_opt,(hr,_found,(_ec,_ic))) = Cookie2.get_internal hr in
hr
let cookies2Out (hr:HST.handle_request) uri delcookies _headers =
if StringSet.mem uri !cookieless_uris
then []
else
match
if delcookies
then false, Time.zero, "ec=Null", "ic=Null"
else
(match hr.HST.hr_ec, hr.HST.hr_ic with
| "", _
| _, "" ->
true, Time.zero, "", ""
| _ec, ic ->
if !use_long_cookies
then
let max_age, ecstr, icstr = CookieLong.get_external hr in
(true, max_age, ecstr, icstr)
else
let max_age, ecstr, icstr = Cookie2.get_external ic in
(false, max_age, ecstr, icstr))
with
| _, _, "", "" -> []
| expiry_changed, max_age, ecstr, icstr ->
(let pathstr = get_path false (Some "/") in
let expirestr = if expiry_changed then get_expires delcookies max_age else "" in
let str = expirestr^pathstr in
[ HSCp.Set_Cookie (ecstr^str); HSCp.Set_Cookie (icstr^str) ])
(* Compression *)
let is_gzip_deflate headers =
match List.find_opt (function HSCp.Accept_Encoding _ -> true | _ -> false) headers with
Some (HSCp.Accept_Encoding s) ->
((String.is_contained "gzip" s) && not (String.is_contained "gzip;q=0" s),
(String.is_contained "deflate" s) && not (String.is_contained "deflate;q=0" s))
| _ -> (false,false)
type compression_limits =
CL_Never | CL_Always | CL_Bounded of (int * int)
let (defMin,defMax) = (2048,2*1024*1024)
(* Always compress these *)
let always = [ "text/plain"; "text/javascript"; "text/css"; "text/html";
"application/x-javascript"; "application/wsdl+xml"; "application/xhtml+xml"; ]
(* Never compress these *)
let never = [ "image/x-xbitmap"; "image/x-xpixmap"; "image/x-xwindowdump"; "image/x-cmu-raster"; "image/x-portable-anymap";
"image/x-portable-bitmap"; "image/x-portable-graymap"; "image/x-rgb"; "image/gif"; "image/jpeg"; "image/tiff";
"audio/basic"; "audio/x-wav";
"video/mpeg"; "video/quicktime"; "video/x-sgi-movie";
"application/zip"; "application/x-bcpio"; "application/x-cpio"; "application/x-shar"; "application/x-tar";
"application/x-dvi"; "application/x-hdf"; "application/x-x509-ca-cert"; "multipart/x-zip";]
(* Compress these between given limits *)
let bounded = [ "application/octet-stream"; "application/postscript"; "application/pdf"; "application/java";
"application/x-csh"; "application/x-sh"; "application/x-tcl"; "application/x-tex";
"application/x-latex"; "application/x-texinfo"; "application/xml"; "unknown/unknown"; ]
let comp_lim_map =
let clm = StringMap.empty in
let clm = List.fold_left (fun clm mt -> StringMap.add mt CL_Always clm) clm always in
let clm = List.fold_left (fun clm mt -> StringMap.add mt CL_Never clm) clm never in
let clm = List.fold_left (fun clm mt -> StringMap.add mt (CL_Bounded (defMin,defMax)) clm) clm bounded in
clm
let get_compression_limit mime_type =
(* We find that the mime_type value actually includes the charset. It's
not supposed to but we can't do anything about that. We'll just have to
strip it out here. *)
match String.slice ';' mime_type with
| [] -> CL_Never
| mt::_ ->
(match StringMap.find_opt (String.trim mt) comp_lim_map with
| Some cl -> cl
| None -> ((* This was supposed to signal an unknown mime type which should then
have been added to the above lists. *)
(*Logger.warning "get_compression_limit: Unknown mime type \"%s\"" mime_type;*)
CL_Never))
let needs_compressed mime_type content_len =
match get_compression_limit mime_type with
| CL_Always -> true
| CL_Never -> false
| CL_Bounded(mn,mx) -> content_len > mn && content_len < mx
(* Caching *)
let is_valid get_md5 mtime_opt hs =
let rec aux = function
| (HSCp.If_None_Match md5in)::t ->
let eq = md5in = (get_md5()) in
#<If$minlevel 10>Logger.debug "is_valid: md5 match %b\n%!" eq#<End>;
eq || aux t
| (HSCp.If_Modified_Since mtimein)::t ->
(match mtime_opt with
Some mtime ->
let ge = Date.of_string mtimein >= Time.round_to_sec mtime in
#<If$minlevel 10>Logger.debug "is_valid: mod since %b\n%!" ge#<End>;
ge || aux t
| None -> aux t)
| (HSCp.If_Unmodified_Since mtimein)::t ->
(match mtime_opt with
Some mtime ->
let lt = Date.of_string mtimein < Time.round_to_sec mtime in
#<If$minlevel 10>Logger.debug "is_valid: unmod since %b\n%!" lt#<End>;
lt || aux t
| None -> aux t)
| (HSCp.Cache_Control "no-cache")::_ -> false
(*| (HSCp.Cache_Control "max=age=0")::t -> false (don't use this) *)
| (HSCp.Pragma "no-cache")::_ -> false
| _::t -> aux t
| [] -> false
in aux hs
let process_content sched hr_opt ?(modified_since=None) ?(compression_level=6) ?(cache_response=true) ?(expires=Time.zero)
?(cache=true) ?(_delcookies=false) ?(use_etag=false) ?(use_md5=false) ?(_type="text/plain") ?content_dispo
_uri content headers_in include_body =
#<If$minlevel 10>Logger.debug "process_content: modified_since=%s\n%!"
(Option.to_string (fun d -> (Date.rfc1123 (Time.gmtime d))) modified_since)#<End>;
#<If>Logger.debug "process_content: _type=%s\n%!" _type#<End>;
let md5 = ref (false,"") in
let get_md5 () =
if fst !md5
then snd !md5
else (let _md5 = Rc.content_md5 content in md5 := (true,_md5); _md5)
in
if is_valid get_md5 modified_since headers_in
then (#<If>Logger.debug "not modified\n%!"#<End>;
None)
else
let time = match hr_opt with Some hr -> hr.HST.hr_timestamp | None -> Time.now () in
let time_now = Time.gmtime time in
let content_len = Rc.content_length content in
let gzip, deflate = is_gzip_deflate headers_in in
let compression_level = if Base.is_windows then 0 else compression_level in
#<If$minlevel 20>Logger.debug "process_content: compressing(%s)\n%!"
(Rc.string_of_content_type (Rc.get_content_type content))#<End>;
let compressed, content =
if compression_level > 0 && (needs_compressed _type content_len)
then HT.content_compress sched gzip deflate compression_level cache_response content content_len
else false, content
in
#<If$minlevel 20>Logger.debug "process_content: compressed=%b\n%!" compressed#<End>;
let content_out = if include_body then content else Rc.ContentNone in
let cs = if String.is_contained "charset" _type then "" else "; charset=utf-8" in
let typeval = (_type^cs,[]) in
#<If$minlevel 10>Logger.debug "process_content: md5=%s" (get_md5())#<End>;
let headers =
[(HSCp.Date (Date.rfc1123 time_now));(HSCp.Server HSC.server_name)]
@(if use_etag then [HSCp.ETag (get_md5())] else [])
@(match modified_since with
Some date -> [ HSCp.Cache_Control "public"; HSCp.Last_Modified (Date.rfc1123 (Time.gmtime date)) ]
| None -> [])
@(if use_md5 then [HSCp.Content_MD5 (get_md5())] else [])
@([HSCp.Content_Type typeval])
@([HSCp.Expires (Date.rfc1123 (if Time.is_infinite expires then { time_now with Unix.tm_year = time_now.Unix.tm_year + 1 }
else if Time.is_positive expires then Time.gmtime (Time.add time expires)
else time_now))])
@(if not cache then [ (HSCp.Cache_Control "no-cache") ; (HSCp.Pragma "no-cache") ] else [])
@(match content_dispo with Some s -> [HSCp.Content_Disposition ("attachment",["filename="^s])] | _ -> [])
in
#<If$minlevel 10>Logger.debug "process_content: headers=%s\n%!"
(String.concat "" (List.map HSC.string_of_msg headers))#<End>;
let content_encoding = if deflate then "deflate" else if gzip then "gzip" else "identity" in
let res =
Some (if compressed
then (#<If$minlevel 10>Logger.debug "content compressed\n%!"#<End>;
(headers@[HSCp.Content_Encoding content_encoding],
content_out, Int64.of_int (Rc.content_length content)))
else (headers, content_out, Int64.of_int content_len))
in
#<If$minlevel 20>Logger.debug "process_content: returning\n%!"#<End>;
res
let get_body sched hr ?(compression_level=6) ?(cache_response=true) ?(use_etag=false) uri _type headers include_body =
let stat = Unix.stat uri in
#<If$minlevel 10>Logger.debug "get_body: uri=%s size=%d\n%!" uri stat.Unix.st_size#<End>;
let content =
if stat.Unix.st_size > (1024*1024)
then Rc.ContentFile (uri,None,None,Some stat,false)
else Rc.ContentString (File.content uri) in
process_content sched (Some hr) ~modified_since:(Some (Time.of_unix_time stat.Unix.st_mtime))
~_type ~compression_level ~cache_response ~use_etag
uri content headers include_body
let get_body_from_value sched hr ?(compression_level=6) ?(cache_response=true) ?(use_etag=false)
((_,content,ms,mt):HSC.body_value) headers include_body =
#<If$minlevel 10>Logger.debug "get_body_from_value: size=%d\n%!" (Rc.content_length content)#<End>;
process_content sched (Some hr) ~modified_since:(Some ms) ~_type:mt ~compression_level ~cache_response ~use_etag
"" content headers include_body
let init_logger () =
#<If:TESTING> () #<Else>
let access_logger =
String.concat ", " (Logger.get_access_logger_destinations())
in
let error_logger =
String.concat ", " (Logger.get_error_logger_destinations())
in
Logger.notice "Accesses logged to %s" access_logger;
Logger.notice "Messages logged to %s" error_logger
#<End>;
Logger.debug "#run"
let banner runtime server_info =
let name = String.capitalize runtime.HSC.rt_server.HSC.rt_server_name in
let version = HSC.server_name in
let url = server_info.HST.server_url in
#<If:TESTING> () #<Else>
Logger.notice "%s (%s) serving on %s" name version url
#<End>