Skip to content
This repository
Newer
Older
100644 379 lines (340 sloc) 17.193 kb
fccc6851 » MLstate
2011-06-21 Initial open-source release
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (* httpServerCommon.ml
19 *
20 *)
21 module List = Base.List
22 module String = Base.String
23 module Char = Base.Char
24
25 module Rc = Rcontent
26 module HSCp = HttpServerCore_parse
27 module HST = HttpServerTypes
28 module HSC = HttpServerCore
29 module HT = HttpTools
30
31 #<Debugvar:HTTP_DEBUG>
32
33 let make_server_info addr port secure =
34 let ip_or_name =
35 match Unix.string_of_inet_addr addr with
36 | "0.0.0.0" -> Unix.gethostname ()
37 | ip -> ip
38 in
39 let portstr = if port = 80 then "" else Printf.sprintf ":%d" port in
40 let server_url = Printf.sprintf "http%s://%s%s" (if secure then "s" else "") ip_or_name portstr in
41 { HST.server_url=server_url; HST.server_id=0; HST.server_ip_or_name=ip_or_name;
42 HST.server_port=port; HST.server_secured=secure; }
43
44 (* Protection against DNS-rebinding attacks *)
45 let set_allowed_hosts li = HSC.allowed_hosts := li
46 let check_host headers =
47 match List.find_opt (function HSCp.Host _ -> true | _ -> false) headers with
48 Some (HSCp.Host host) ->
49 if !(HSC.allowed_hosts) <> [] && not (List.mem host !(HSC.allowed_hosts))
50 then (Logger.error "Host is unknown: %s" host;
51 failwith "error, aborting")
52 else #<If$minlevel 10>Logger.debug "check_host %s OK.\n%!" ("["^(String.concat "," (!(HSC.allowed_hosts)))^"]")#<End>
53 | None -> ()
54 | _ -> assert false
55
56 (* Cookies:
57 cookies2In: decides whether to call Cookie2 or CookieLong, or no cookies at all.
58 cookies2Out: installs Set_Cookie in headers.
59 *)
60
61 let get_version version = if version = 1 then Printf.sprintf "; version=%d" version else ""
62
63 let get_expires delcookies expires =
64 if delcookies
65 then "; expires=Thu, 01-Jan-1970 00:00:01 GMT"
66 else if Time.is_positive expires
67 then "; expires="^(Date.rfc1123 (Time.gmtime (Time.add (Time.now()) expires)))
68 else ""
69
70 let get_max_age delcookies expires =
71 if delcookies
72 then "; max-age=0"
73 else if Time.is_positive expires
74 then "; max-age="^(string_of_int (truncate (Time.in_seconds expires)))
75 else ""
76
77 let get_object quotes name obj_opt =
78 let q = if quotes then "\"" else "" in
79 Option.default_map "" (fun obj -> if obj <> "" then "; "^name^"="^q^obj^q else "") obj_opt
80
81 let get_path quotes path_opt = get_object quotes "path" path_opt
82 let get_domain quotes domain_opt = get_object quotes "domain" domain_opt
83 let get_comment comment_opt = get_object true "comment" comment_opt
84 let get_commenturl commenturl_opt = get_object true "commenturl" commenturl_opt
85
86 let get_secure secure = if secure then "; secure" else ""
87 let get_discard discard = if discard then "; discard" else ""
88
89 let portstr num =
90 if num >= 0 && num < 65535
91 then string_of_int num
92 else raise (Failure (Printf.sprintf "Cookie port num ouit of range %d" num))
93
94 let get_ports = function
95 Some [] -> "; Port"
96 | Some ports -> "; Port=\""^(String.concat "," (List.map portstr ports))^"\""
97 | None -> ""
98
99 let use_long_cookies = ref true
100
101 let cookieless_uris = ref StringSet.empty
102 let add_cookieless_uri uri = cookieless_uris := StringSet.add uri !cookieless_uris
103 let _ = List.iter add_cookieless_uri ["/favicon.ico"; "/favicon.gif"]
104
105 let cookies2In (hr:HST.handle_request) (uri:string) =
106 if StringSet.mem uri !cookieless_uris
107 then hr
108 else
109 if !use_long_cookies
110 then CookieLong.get_internal hr
111 else
112 let (_c2type_opt,(hr,_found,(_ec,_ic))) = Cookie2.get_internal hr in
113 hr
114
115 let cookies2Out (hr:HST.handle_request) uri delcookies _headers =
116 if StringSet.mem uri !cookieless_uris
117 then []
118 else
119 match
120 if delcookies
121 then false, Time.zero, "ec=Null", "ic=Null"
de6e027e » Aqua-Ye
2011-11-14 [enhance] httpServer: switched http server response to full cps
122 else
fccc6851 » MLstate
2011-06-21 Initial open-source release
123 (match hr.HST.hr_ec, hr.HST.hr_ic with
124 | "", _
125 | _, "" ->
126 true, Time.zero, "", ""
127 | _ec, ic ->
128 if !use_long_cookies
129 then
130 let max_age, ecstr, icstr = CookieLong.get_external hr in
131 (true, max_age, ecstr, icstr)
132 else
133 let max_age, ecstr, icstr = Cookie2.get_external ic in
134 (false, max_age, ecstr, icstr))
135 with
136 | _, _, "", "" -> []
137 | expiry_changed, max_age, ecstr, icstr ->
138 (let pathstr = get_path false (Some "/") in
139 let expirestr = if expiry_changed then get_expires delcookies max_age else "" in
140 let str = expirestr^pathstr in
141 [ HSCp.Set_Cookie (ecstr^str); HSCp.Set_Cookie (icstr^str) ])
142
143 (* Compression *)
144
145 let is_gzip_deflate headers =
146 match List.find_opt (function HSCp.Accept_Encoding _ -> true | _ -> false) headers with
147 Some (HSCp.Accept_Encoding s) ->
148 ((String.is_contained "gzip" s) && not (String.is_contained "gzip;q=0" s),
149 (String.is_contained "deflate" s) && not (String.is_contained "deflate;q=0" s))
150 | _ -> (false,false)
151
152 type compression_limits =
153 CL_Never | CL_Always | CL_Bounded of (int * int)
154
155 let (defMin,defMax) = (2048,2*1024*1024)
156
157 (* Always compress these *)
158 let always = [ "text/plain"; "text/javascript"; "text/css"; "text/html";
159 "application/x-javascript"; "application/wsdl+xml"; "application/xhtml+xml"; ]
160
161 (* Never compress these *)
162 let never = [ "image/x-xbitmap"; "image/x-xpixmap"; "image/x-xwindowdump"; "image/x-cmu-raster"; "image/x-portable-anymap";
163 "image/x-portable-bitmap"; "image/x-portable-graymap"; "image/x-rgb"; "image/gif"; "image/jpeg"; "image/tiff";
164 "audio/basic"; "audio/x-wav";
165 "video/mpeg"; "video/quicktime"; "video/x-sgi-movie";
166 "application/zip"; "application/x-bcpio"; "application/x-cpio"; "application/x-shar"; "application/x-tar";
167 "application/x-dvi"; "application/x-hdf"; "application/x-x509-ca-cert"; "multipart/x-zip";]
168
169 (* Compress these between given limits *)
170 let bounded = [ "application/octet-stream"; "application/postscript"; "application/pdf"; "application/java";
171 "application/x-csh"; "application/x-sh"; "application/x-tcl"; "application/x-tex";
172 "application/x-latex"; "application/x-texinfo"; "application/xml"; "unknown/unknown"; ]
173
174 let comp_lim_map =
175 let clm = StringMap.empty in
176 let clm = List.fold_left (fun clm mt -> StringMap.add mt CL_Always clm) clm always in
177 let clm = List.fold_left (fun clm mt -> StringMap.add mt CL_Never clm) clm never in
178 let clm = List.fold_left (fun clm mt -> StringMap.add mt (CL_Bounded (defMin,defMax)) clm) clm bounded in
179 clm
180
181 let get_compression_limit mime_type =
182 (* We find that the mime_type value actually includes the charset. It's
183 not supposed to but we can't do anything about that. We'll just have to
184 strip it out here. *)
461365b0 » Louis Gesbert
2011-06-23 [cleanup] Base.String: changed String.split to a much simpler String.…
185 match String.slice ';' mime_type with
fccc6851 » MLstate
2011-06-21 Initial open-source release
186 | [] -> CL_Never
187 | mt::_ ->
188 (match StringMap.find_opt (String.trim mt) comp_lim_map with
189 | Some cl -> cl
190 | None -> ((* This was supposed to signal an unknown mime type which should then
191 have been added to the above lists. *)
192 (*Logger.warning "get_compression_limit: Unknown mime type \"%s\"" mime_type;*)
193 CL_Never))
194
195 let needs_compressed mime_type content_len =
196 match get_compression_limit mime_type with
197 | CL_Always -> true
198 | CL_Never -> false
199 | CL_Bounded(mn,mx) -> content_len > mn && content_len < mx
200
201 (* Caching *)
202
203 let is_valid get_md5 mtime_opt hs =
204 let rec aux = function
205 | (HSCp.If_None_Match md5in)::t ->
206 let eq = md5in = (get_md5()) in
207 #<If$minlevel 10>Logger.debug "is_valid: md5 match %b\n%!" eq#<End>;
208 eq || aux t
209 | (HSCp.If_Modified_Since mtimein)::t ->
210 (match mtime_opt with
211 Some mtime ->
212 let ge = Date.of_string mtimein >= Time.round_to_sec mtime in
213 #<If$minlevel 10>Logger.debug "is_valid: mod since %b\n%!" ge#<End>;
214 ge || aux t
215 | None -> aux t)
216 | (HSCp.If_Unmodified_Since mtimein)::t ->
217 (match mtime_opt with
218 Some mtime ->
219 let lt = Date.of_string mtimein < Time.round_to_sec mtime in
220 #<If$minlevel 10>Logger.debug "is_valid: unmod since %b\n%!" lt#<End>;
221 lt || aux t
222 | None -> aux t)
223 | (HSCp.Cache_Control "no-cache")::_ -> false
224 (*| (HSCp.Cache_Control "max=age=0")::t -> false (don't use this) *)
225 | (HSCp.Pragma "no-cache")::_ -> false
226 | _::t -> aux t
227 | [] -> false
228 in aux hs
229
65c62f3e » Thomas Refis
2011-08-10 [enhance] Stdlib: response headers now really used
230 let process_content_with_headers sched hr_opt ?(modified_since=None) ?(compression_level=6) ?(cache_response=true)
de6e027e » Aqua-Ye
2011-11-14 [enhance] httpServer: switched http server response to full cps
231 ?(_delcookies=false) ?(use_etag=false) ?(use_md5=false) ?(_type="text/plain")
232 _uri content headers_in headers_out include_body cont =
65c62f3e » Thomas Refis
2011-08-10 [enhance] Stdlib: response headers now really used
233 #<If$minlevel 10>Logger.debug "process_content: modified_since=%s\n%!"
de6e027e » Aqua-Ye
2011-11-14 [enhance] httpServer: switched http server response to full cps
234 (Option.to_string (fun d -> (Date.rfc1123 (Time.gmtime d))) modified_since)#<End>;
65c62f3e » Thomas Refis
2011-08-10 [enhance] Stdlib: response headers now really used
235 #<If>Logger.debug "process_content: _type=%s\n%!" _type#<End>;
236 let md5 = ref (false,"") in
237 let get_md5 () =
238 if fst !md5
239 then snd !md5
240 else (let _md5 = Rc.content_md5 content in md5 := (true,_md5); _md5)
241 in
242 if is_valid get_md5 modified_since headers_in
243 then (#<If>Logger.debug "not modified\n%!"#<End>;
de6e027e » Aqua-Ye
2011-11-14 [enhance] httpServer: switched http server response to full cps
244 cont None)
65c62f3e » Thomas Refis
2011-08-10 [enhance] Stdlib: response headers now really used
245 else
246 let time = match hr_opt with Some hr -> hr.HST.hr_timestamp | None -> Time.now () in
247 let time_now = Time.gmtime time in
248 let content_len = Rc.content_length content in
249 let gzip, deflate = is_gzip_deflate headers_in in
250 let compression_level = if Base.is_windows then 0 else compression_level in
251 #<If$minlevel 20>Logger.debug "process_content: compressing(%s)\n%!"
de6e027e » Aqua-Ye
2011-11-14 [enhance] httpServer: switched http server response to full cps
252 (Rc.string_of_content_type (Rc.get_content_type content))#<End>;
253 let f cont = cont (false, content) in
254 (if compression_level > 0 && (needs_compressed _type content_len)
255 then (HT.content_compress sched gzip deflate compression_level cache_response content content_len)
256 else f)
257 (function (compressed, content) ->
258 #<If$minlevel 20>Logger.debug "process_content: compressed=%b\n%!" compressed#<End>;
259 let content_out = if include_body then content else Rc.ContentNone in
260 let cs = if String.is_contained "charset" _type then "" else "; charset=utf-8" in
261 let typeval = (_type^cs,[]) in
262 #<If$minlevel 10>Logger.debug "process_content: md5=%s" (get_md5())#<End>;
263 let headers =
264 [(HSCp.Date (Date.rfc1123 time_now));(HSCp.Server HSC.server_name)]
265 @(if use_etag then [HSCp.ETag (get_md5())] else [])
266 @(if use_md5 then [HSCp.Content_MD5 (get_md5())] else [])
267 @([HSCp.Content_Type typeval])
268 @ headers_out
269 in
270 #<If$minlevel 10>Logger.debug "process_content: headers=%s\n%!"
271 (String.concat "" (List.map HSC.string_of_msg headers))#<End>;
272 let content_encoding = if deflate then "deflate" else if gzip then "gzip" else "identity" in
273 let res =
274 Some (if compressed
275 then (#<If$minlevel 10>Logger.debug "content compressed\n%!"#<End>;
276 (headers@[HSCp.Content_Encoding content_encoding],
277 content_out, Int64.of_int (Rc.content_length content)))
278 else (headers, content_out, Int64.of_int content_len))
279 in
280 #<If$minlevel 20>Logger.debug "process_content: returning\n%!"#<End>;
281 cont res)
65c62f3e » Thomas Refis
2011-08-10 [enhance] Stdlib: response headers now really used
282
fccc6851 » MLstate
2011-06-21 Initial open-source release
283 let process_content sched hr_opt ?(modified_since=None) ?(compression_level=6) ?(cache_response=true) ?(expires=Time.zero)
de6e027e » Aqua-Ye
2011-11-14 [enhance] httpServer: switched http server response to full cps
284 ?(cache=true) ?(_delcookies=false) ?(use_etag=false) ?(use_md5=false) ?(_type="text/plain") ?content_dispo
285 _uri content headers_in include_body cont =
fccc6851 » MLstate
2011-06-21 Initial open-source release
286 #<If$minlevel 10>Logger.debug "process_content: modified_since=%s\n%!"
de6e027e » Aqua-Ye
2011-11-14 [enhance] httpServer: switched http server response to full cps
287 (Option.to_string (fun d -> (Date.rfc1123 (Time.gmtime d))) modified_since)#<End>;
fccc6851 » MLstate
2011-06-21 Initial open-source release
288 #<If>Logger.debug "process_content: _type=%s\n%!" _type#<End>;
289 let md5 = ref (false,"") in
290 let get_md5 () =
291 if fst !md5
292 then snd !md5
293 else (let _md5 = Rc.content_md5 content in md5 := (true,_md5); _md5)
294 in
295 if is_valid get_md5 modified_since headers_in
296 then (#<If>Logger.debug "not modified\n%!"#<End>;
de6e027e » Aqua-Ye
2011-11-14 [enhance] httpServer: switched http server response to full cps
297 cont None)
fccc6851 » MLstate
2011-06-21 Initial open-source release
298 else
299 let time = match hr_opt with Some hr -> hr.HST.hr_timestamp | None -> Time.now () in
300 let time_now = Time.gmtime time in
301 let content_len = Rc.content_length content in
302 let gzip, deflate = is_gzip_deflate headers_in in
303 let compression_level = if Base.is_windows then 0 else compression_level in
304 #<If$minlevel 20>Logger.debug "process_content: compressing(%s)\n%!"
de6e027e » Aqua-Ye
2011-11-14 [enhance] httpServer: switched http server response to full cps
305 (Rc.string_of_content_type (Rc.get_content_type content))#<End>;
306 let f cont = cont (false, content) in
307 (if compression_level > 0 && (needs_compressed _type content_len)
308 then (HT.content_compress sched gzip deflate compression_level cache_response content content_len)
309 else f)
310 (function (compressed, content) ->
311 #<If$minlevel 20>Logger.debug "process_content: compressed=%b\n%!" compressed#<End>;
312 let content_out = if include_body then content else Rc.ContentNone in
313 let cs = if String.is_contained "charset" _type then "" else "; charset=utf-8" in
314 let typeval = (_type^cs,[]) in
315 #<If$minlevel 10>Logger.debug "process_content: md5=%s" (get_md5())#<End>;
316 let headers =
317 [(HSCp.Date (Date.rfc1123 time_now));(HSCp.Server HSC.server_name)]
318 @(if use_etag then [HSCp.ETag (get_md5())] else [])
319 @(match modified_since with
320 Some date -> [ HSCp.Cache_Control "public"; HSCp.Last_Modified (Date.rfc1123 (Time.gmtime date)) ]
321 | None -> [])
322 @(if use_md5 then [HSCp.Content_MD5 (get_md5())] else [])
323 @([HSCp.Content_Type typeval])
324 @([HSCp.Expires (Date.rfc1123 (if Time.is_infinite expires then { time_now with Unix.tm_year = time_now.Unix.tm_year + 1 }
325 else if Time.is_positive expires then Time.gmtime (Time.add time expires)
326 else time_now))])
327 @(if not cache then [ (HSCp.Cache_Control "no-cache") ; (HSCp.Pragma "no-cache") ] else [])
328 @(match content_dispo with Some s -> [HSCp.Content_Disposition ("attachment",["filename="^s])] | _ -> [])
329 in
330 #<If$minlevel 10>Logger.debug "process_content: headers=%s\n%!"
331 (String.concat "" (List.map HSC.string_of_msg headers))#<End>;
332 let content_encoding = if deflate then "deflate" else if gzip then "gzip" else "identity" in
333 let res =
334 Some (if compressed
335 then (#<If$minlevel 10>Logger.debug "content compressed\n%!"#<End>;
336 (headers@[HSCp.Content_Encoding content_encoding],
337 content_out, Int64.of_int (Rc.content_length content)))
338 else (headers, content_out, Int64.of_int content_len))
339 in
340 #<If$minlevel 20>Logger.debug "process_content: returning\n%!"#<End>;
341 cont res)
fccc6851 » MLstate
2011-06-21 Initial open-source release
342
343 let get_body sched hr ?(compression_level=6) ?(cache_response=true) ?(use_etag=false) uri _type headers include_body =
344 let stat = Unix.stat uri in
345 #<If$minlevel 10>Logger.debug "get_body: uri=%s size=%d\n%!" uri stat.Unix.st_size#<End>;
346 let content =
347 if stat.Unix.st_size > (1024*1024)
348 then Rc.ContentFile (uri,None,None,Some stat,false)
349 else Rc.ContentString (File.content uri) in
350 process_content sched (Some hr) ~modified_since:(Some (Time.of_unix_time stat.Unix.st_mtime))
351 ~_type ~compression_level ~cache_response ~use_etag
352 uri content headers include_body
353
354 let get_body_from_value sched hr ?(compression_level=6) ?(cache_response=true) ?(use_etag=false)
de6e027e » Aqua-Ye
2011-11-14 [enhance] httpServer: switched http server response to full cps
355 ((_,content,ms,mt):HSC.body_value) headers include_body cont =
fccc6851 » MLstate
2011-06-21 Initial open-source release
356 #<If$minlevel 10>Logger.debug "get_body_from_value: size=%d\n%!" (Rc.content_length content)#<End>;
357 process_content sched (Some hr) ~modified_since:(Some ms) ~_type:mt ~compression_level ~cache_response ~use_etag
de6e027e » Aqua-Ye
2011-11-14 [enhance] httpServer: switched http server response to full cps
358 "" content headers include_body cont
fccc6851 » MLstate
2011-06-21 Initial open-source release
359
360 let init_logger () =
361 #<If:TESTING> () #<Else>
362 let access_logger =
363 String.concat ", " (Logger.get_access_logger_destinations())
364 in
365 let error_logger =
366 String.concat ", " (Logger.get_error_logger_destinations())
367 in
368 Logger.notice "Accesses logged to %s" access_logger;
369 Logger.notice "Messages logged to %s" error_logger
370 #<End>;
371 Logger.debug "#run"
372
373 let banner runtime server_info =
374 let name = String.capitalize runtime.HSC.rt_server.HSC.rt_server_name in
375 let version = HSC.server_name in
376 let url = server_info.HST.server_url in
377 #<If:TESTING> () #<Else>
378 Logger.notice "%s (%s) serving on %s" name version url
379 #<End>
Something went wrong with that request. Please try again.