Skip to content
This repository
Newer
Older
100644 932 lines (804 sloc) 40.906 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 let (<|) f a = f a
19 let (|>) a f = f a
20 let ( @* ) g f x = g(f(x))
21 module List = Base.List
22 module String = Base.String
23
24 module Rd = Requestdef
25 module Rc = Rcontent
26 module HSCp = HttpServerCore_parse
27 module HST = HttpServerTypes
28 module HSC = HttpServerCore
29 module HT = HttpTools
30 module HSCm = HttpServerCommon
31 module Mp = Mlstate_platform
32 module HD = HttpDialog
33
34 let sprintf = Printf.sprintf
35
36 #<Debugvar:HTTP_DEBUG>
37
38 type request = HST.request
39
40 let make_status = HSC.make_status
41
42 (* Private tools *)
43
44 let get_content_length req = Int64.to_int (Option.default 0L (HSC.get_Content_Length req.HST.request_header))
45
46 (* TODO: generate Map from DSL type generation code *)
47
48 let remove_header_first h request_header =
49 let rec aux = function
50 | [] -> []
51 | h2::t ->
52 if HSC.compare_msg (h,h2)
53 then t
54 else h2::aux t in
55 aux request_header
56
57 let remove_header h request_header = List.filter (fun h2 -> not (HSC.compare_msg (h,h2))) request_header
58
59 let replace_header h request_header = h::(remove_header h request_header)
60
61 let replace_header_first h request_header = h::(remove_header_first h request_header)
62
63 let replace_request_header h req = {req with HST.request_header=replace_header h req.HST.request_header}
64
65 let string_of_request { HST.request_scheduler=_;
66 HST.request_line = rl; HST.request_header = rh; HST.request_message_body = rmb;
67 HST.request_post_body = _; HST.server_info = _; HST.is_multipart = _; HST.handle_request = _; } =
68 (HSC.string_of_msg rl.HST._method)^(List.fold_left (fun s h -> s^(HSC.string_of_msg h)) "" rh)^"\r\n"^(Rc.get_content rmb)
69
70 let get_method req =
71 match req.HST.request_line.HST._method with
72 | HSCp.Opts (_,_) -> "OPTIONS"
73 | HSCp.Get (_,_) -> "GET"
74 | HSCp.Head (_,_) -> "HEAD"
75 | HSCp.Post (_,_) -> "POST"
76 | HSCp.Put (_,_) -> "PUT"
77 | HSCp.Del (_,_) -> "DELETE"
78 | HSCp.Trace (_,_) -> "TRACE"
79 | HSCp.Conn (_,_) -> "CONNECT"
80 | _ -> "UNKNOWN"
81
82 let get_header_names req = List.map HSC.get_msg_name req.HST.request_header
83
84 (* FIXME: improve this function *)
85 let get_header_string_value h name =
86 (* FIXME: we assume the length of the name is the same as the length of the header name. *)
87 let str = HSC.string_of_msg h in
88 let strlen = String.length str in
89 let rmv = min (String.length name) strlen in
90 let str = String.sub str rmv (strlen-rmv) in
91 String.trim (String.remove_suffix_if_possible "\r\n" (String.remove_prefix_if_possible ":" str))
92
93 let get_header_by_name_ rh name =
94 match List.find_opt (fun h -> (HSC.get_msg_name h) = name) rh with
95 | Some h -> Some (get_header_string_value h name)
96 | None -> None
97 let get_header_by_name req = get_header_by_name_ req.HST.request_header
98
99 (* BSL-tools *)
100
101 let get_server_url req =
102 match req.HST.server_info with
103 | {HST.server_url=su; HST.server_id=_; HST.server_ip_or_name=_; HST.server_port=_; HST.server_secured=_; } -> su
104
105 let get_uri req = req.HST.request_line.HST.request_uri
106
107 let is_multipart req = req.HST.is_multipart
108
109 let get_multipart_name msglst name =
110 let res =
111 match List.find_opt (function HSCp.Content_Disposition _ -> true | _ -> false) msglst with
112 Some (HSCp.Content_Disposition (s,l)) ->
113 let al = HSC.parse_content_disposition (HSCp.Content_Disposition (s,l)) in
114 #<If>Logger.debug "get_multipart_name: al=%s"
115 (String.concat ", " (List.map (fun (a,b) -> a^"->"^b) al)); flush stderr#<End>;
116 String.strip_quotes (try List.assoc name al with Not_found -> "")
117 | _ -> ""
118 in #<If>Logger.debug "get_multipart_name(%s): returning '%s'" name res#<End>; res
119
120 let get_multipart_type msglst =
121 let res =
122 match List.find_opt (function HSCp.Content_Type _ -> true | _ -> false) msglst with
123 Some (HSCp.Content_Type (s,_)) -> s
124 | _ -> "unknown/unknown"
125 in #<If>Logger.debug "get_multipart_type: returning '%s'" res#<End>; res
126
127 let get_multipart_content req =
128 req.HST.request_post_body
129
130 let m2 =
131 Lazy.lazy_from_fun
132 (fun () ->
133 let mime_types_file_content =
134 try
135 let res = File.content ((Lazy.force File.mlstate_dir)^"/.mime.types") in
136 Logger.info "Loaded .mime.types file";
137 res
138 with Unix.Unix_error _ -> "" in
139 let (_,(_,m1)) = Mime.parse_mime_file mime_types_file_content in
140 let (_,(_,m2)) = Mime.parse_mime_file Mimes.mimetypes in
141 StringMap.merge (fun x1 _ -> x1) m1 m2)
142
143 let mime_type f =
144 let ext =
145 match File.extension f with
146 | "" -> f (* pour pouvoir directement trouver le type mime de "html" *)
147 | e -> e in
148 try StringMap.find (String.lowercase (ext)) (Lazy.force m2)
149 with Not_found -> "unknown/unknown"
150
151 let get_user_agent req = Option.default "unknown" (HSC.get_User_Agent req.HST.request_header)
152
153 let get_request_cookie req =
154 match req.HST.handle_request.HST.hr_ic with
155 | "" -> None
156 | ic -> Some ic
157
158 (* Returns the ic and ec cookies, contrary to get_request_cookie that just returns ic *)
159 let get_request_cookies req =
160 let ic = match req.HST.handle_request.HST.hr_ic with
161 | "" -> None
162 | ic -> Some ic
163 and ec = match req.HST.handle_request.HST.hr_ec with
164 | "" -> None
165 | ec -> Some ec
166 in (ic, ec)
167
168 let get_cookie req =
169 let s = req.HST.handle_request.HST.hr_ic in
170 #<If>Logger.debug "HttpServer.get_cookie: '%s'" s; flush stderr#<End>;
171 s
172 let get_resource_tracker req =
173 let s = req.HST.handle_request.HST.hr_ic in
174 let r = Cookie2.get_resource_tracker s in
175 r
176
177 let is_ie req = String.is_contained "MSIE" <| get_user_agent req
178 let is_firefox req = String.is_contained "Firefox" <| get_user_agent req
179 let is_googlebot req = String.is_contained "googlebot" <| String.lowercase (get_user_agent req)
180 let is_apple_mobile req =
181 let ua = get_user_agent req in
182 (String.is_contained "Mobile" ua) && (String.is_contained "Apple" ua)
183 let is_safari_mobile req =
184 let ua = get_user_agent req in
185 (String.is_contained "Mobile" ua) && (String.is_contained "Safari" ua)
186 let is_apple_mobile_webapp req =
187 let ua = get_user_agent req in
188 (String.is_contained "Mobile" ua) && (String.is_contained "Apple" ua) && (not (String.is_contained "Safari" ua))
189
190 let make_error_response html code msg headers =
191 let sl = HSCp.Sl (HSC.http_version_number, code, msg) in
192 let headers = headers@[HSCp.Content_Length (Int64.of_int (String.length html))] in
193 { HST.sl = sl ; HST.headers = headers ; HST.body = Rc.ContentString html }
194
195 let _not_found () =
196 make_error_response "<html><head><title>404 Error</title></head><body>404 - Not Found</body></html>" 404 "Not Found" []
197
198 let _unauthorized () =
199 make_error_response "<html><head><title>401 Error</title></head><body>401 - Unauthorized</body></html>" 401 "Unauthorized" []
200
201 let _not_modified ?(include_date=true) () =
202 make_error_response
203 (* SEE: RFC 2616 10.3.5 *)
204 "" 304 "Not Modified"
205 (if include_date
206 then [HSCp.Date (Date.rfc1123 (Unix.gmtime (Unix.time())))] (* RFC2616: 10.3.5 - we have a clock *)
207 else [])
208
65c62f3e » Thomas Refis
2011-08-10 [enhance] Stdlib: response headers now really used
209 let limstr ?(extra="") str lim =
210 let len = String.length str in
211 (String.sub str 0 (min lim len)) ^ (if len > lim then extra else "")
212
213 let str_of_result = function
214 | Http_common.Result page -> page
215 | _ -> "<html><head><title>Error</title></head><body>Error.</body></html>"
216
217 let make_response_with_headers ?(modified_since=None) ?(compression_level=6)
218 ?(cache_response=true) ?(delcookies=false) ?req
219 headers_out status_line _type content =
220 #<If$minlevel 20>Logger.debug "make_response"#<End>;
221 let code = Rd.status_code status_line in
222 let reason = Rd.reason_phrase code in
223 let sl = HSCp.Sl (HSC.http_version_number, code, reason) in
224 let content = str_of_result content in
225 #<If>Logger.debug "make_response: content=%s" (limstr ~extra:"..." content 100)#<End>;
226 let (sched,hr_opt,uri,headers_in,include_body) =
227 match req with
228 Some req -> (req.HST.request_scheduler,
229 (Some req.HST.handle_request),
230 req.HST.request_line.HST.request_uri,
231 req.HST.request_header,
232 (match req.HST.request_line.HST._method with HSCp.Head _ -> false | _ -> true))
233 | _ -> (Scheduler.default,None,"",[],true) in
234 let processed =
235 HSCm.process_content_with_headers sched ~modified_since ~compression_level
236 ~cache_response ~_delcookies:delcookies ~_type hr_opt uri
237 (Rc.ContentString content) headers_in headers_out include_body
238 in match processed with
239 Some (headers_out,body,len) -> {
240 HST.sl = sl;
241 HST.headers = HSCp.Content_Length len :: headers_out;
242 HST.body = body;
243 }
244 | None -> _not_modified ()
fccc6851 » MLstate
2011-06-21 Initial open-source release
245
246 let make_response ?(modified_since=None) ?(compression_level=6) ?(cache_response=true) ?(expires=Time.zero) ?(cache=true)
247 ?(delcookies=false) ?location ?req status_line _type ?content_dispo content =
248 #<If$minlevel 20>Logger.debug "make_response"#<End>;
249 let code = Rd.status_code status_line in
250 let reason = Rd.reason_phrase code in
251 let sl = HSCp.Sl (HSC.http_version_number, code, reason) in
65c62f3e » Thomas Refis
2011-08-10 [enhance] Stdlib: response headers now really used
252 let content = str_of_result content in
fccc6851 » MLstate
2011-06-21 Initial open-source release
253 #<If>Logger.debug "make_response: content=%s" (limstr ~extra:"..." content 100)#<End>;
254 let (sched,hr_opt,uri,headers_in,include_body) =
255 match req with
256 Some req -> (req.HST.request_scheduler,
257 (Some req.HST.handle_request),
258 req.HST.request_line.HST.request_uri,
259 req.HST.request_header,
260 (match req.HST.request_line.HST._method with HSCp.Head _ -> false | _ -> true))
261 | _ -> (Scheduler.default,None,"",[],true) in
262 match HSCm.process_content sched ~modified_since ~compression_level ~cache_response ~expires
263 ~cache ~_delcookies:delcookies ~_type ?content_dispo
264 hr_opt uri (Rc.ContentString content) headers_in include_body with
265 Some (headers_out,body,len) ->
266 let headers_out = match location with
267 | Some url -> (HSCp.Location url)::headers_out
268 | None -> headers_out in
65c62f3e » Thomas Refis
2011-08-10 [enhance] Stdlib: response headers now really used
269 { HST.sl = sl; HST.headers = HSCp.Content_Length len::headers_out; HST.body = body }
fccc6851 » MLstate
2011-06-21 Initial open-source release
270 | None -> _not_modified ()
271
272 let make_response_result ?(modified_since=None) ?(compression_level=6) ?(cache_response=true) ?(expires=Time.zero)
273 ?(cache=true) ?(delcookies=false) ?location ?req status _type ?content_dispo content =
274 make_response ~modified_since:modified_since ~compression_level:compression_level
275 ~cache_response:cache_response ~expires:expires ~cache:cache ~delcookies:delcookies
276 ?location ?req status _type ?content_dispo
277 (Http_common.Result content)
278
279 let make_response_modified_since date req = make_response ~modified_since:(Some date) ~req
280 let make_response_req expires req = make_response ~expires ~req
281 let make_response_req_loc expires location req = make_response ~expires ~location ~req
282
283 let get_req_type req = req.HST.request_line.HST._method
284
285 let move_page time url sc =
286 let code = Rd.status_code sc in
287 let reason = Rd.reason_phrase code in
288 Http_common.Result (sprintf "<html><head><meta http-equiv=\"refresh\" content=\"%d; URL=%s\"></head>%s</html>" (truncate (Time.in_seconds time)) url
289 (if Time.is_positive time then sprintf "<body><p>%s %d %s</p></body>" HSC.http_version code reason else ""))
290
291 let error_page server_url e =
292 let sc = Rd.status_code e in
293 let rp = Rd.reason_phrase sc in
294 Http_common.Result
295 (sprintf
296 "<html><head><title>%d %s</title></head><body><h1>Error %d: %s</h1><hr /><p><a href=\"%s\">%s</a></body></p></html>"
297 sc rp sc rp server_url HSC.server_name)
298
299 let make_error ?req status =
300 match req with
301 | Some req ->
302 let server_url = get_server_url req in
303 make_response ~req status "text/html" (error_page server_url status)
304 | _ -> make_response status "text/html" (error_page "" status)
305
306 let make_moved ?(time=Time.zero) req url =
307 make_response ~location:url ~req Rd.SC_MovedPermanently "text/html"
308 (move_page time url Rd.SC_MovedPermanently)
309 let make_redirect ?(time=Time.zero) req url =
310 make_response ~location:url ~req Rd.SC_TemporaryRedirect "text/html"
311 (move_page time url Rd.SC_TemporaryRedirect)
312
313 let direct_pair req (m, c) = make_response ~expires:Time.infinity ~req Rd.SC_OK m (Http_common.Result c)
314 let direct ?(expires=Time.infinity) req = make_response ~expires ~req Rd.SC_OK
315
316 let html ?(compression_level=6) ?(cache_response=true) ?(cache=true) ?(delcookies=false) ?(charset="") req =
317 let charset = if charset = "" then "" else "; charset=" ^ charset in
318 let mime = (mime_type ".html") ^ charset in
319 make_response_result ~compression_level:compression_level ~cache_response:cache_response
320 ~cache:cache ~delcookies:delcookies ~req Rd.SC_OK mime
321
322 let get_fields req =
323 let body = Rc.get_content req.HST.request_message_body in
324 let s = String.sub body 0 (get_content_length req) in
325 try
326 let _pos, res = Encodings.http_body_rewrite s in
327 res
328 with Encodings.HttpBodyRewriteError _ -> []
329
330 (* MAIN FUNCTIONS *)
331
332 let make_error_response k sched conn uri hr _method html code msg headers =
333 let req = { HST.request_scheduler = sched;
334 request_line = { HST._method=_method; request_uri=uri; http_version=HSC.http_version_number };
335 request_header = [HSCp.Sl (HSC.http_version_number, code, msg)]@headers
336 @[HSCp.Content_Length (Int64.of_int (String.length html))];
337 request_message_body = Rc.ContentString html; request_post_body = [];
338 server_info = hr.HST.hr_server_info; is_multipart = false; handle_request = hr } in
339 { HST.cont=k; request=req; connection=conn; certificate=None }
340
341 let not_found k sched conn uri hr _method =
342 make_error_response k sched conn uri hr _method
343 "<html><head><title>404 Error</title></head><body>404 - Not Found</body></html>" 404 "Not Found" []
344
345 let unauthorized k sched conn uri hr _method =
346 make_error_response k sched conn uri hr _method
347 "<html><head><title>401 Error</title></head><body>401 - Unauthorized</body></html>" 401 "Unauthorized" []
348
349 let not_modified ?(include_date=true) k sched conn uri hr _method =
350 make_error_response
351 k sched conn uri hr _method
352 (* SEE: RFC 2616 10.3.5 *)
353 "" 304 "Not Modified"
354 (if include_date
355 then [HSCp.Date (Date.rfc1123 (Unix.gmtime (Unix.time())))] (* RFC2616: 10.3.5 - we have a clock *)
356 else [])
357
358 let pre_headers hr request_type headers =
359 #<If:HTTP_NO_COOKIE>
360 (hr, headers)
361 #<Else>
362 (HSCm.cookies2In hr (HSC.request_type_uri request_type), headers)
363 #<End>
364
365 let post_headers hr request_type headers_in headers_out =
366 let connection_opt =
367 match (List.find_opt (function HSCp.Connection _ -> true | _ -> false) headers_in) with
368 | Some (HSCp.Connection s) -> Some s
369 | _ -> None in
370 let (header,close) =
371 match (HSC.request_type_http_version request_type, connection_opt) with
372 | ("1.0",None) -> ([HSCp.Connection "close"],true)
373 | ("1.1",None) -> ([HSCp.Connection "Keep-Alive"],false)
374 | (_,Some s) when String.is_substring_insensitive "keep-alive" s 0 -> ([HSCp.Connection "Keep-Alive"],false)
375 | (_,Some s) when String.is_substring_insensitive "close" s 0 -> ([HSCp.Connection "Close"],true)
376 | _ -> ([HSCp.Connection "Keep-Alive"],false) in
377 #<If:HTTP_NO_COOKIE>
378 (hr,(headers_out@header),close)
379 #<Else>
380 let cookies = HSCm.cookies2Out hr (HSC.request_type_uri request_type) false headers_in in
381 (hr,(headers_out@header@cookies),close)
382 #<End>
383
384 let handle_special sched _runtime _method hr body_value headers _conn k =
385 let include_body = match _method with HSCp.Head _ -> false | _ -> true in
386 match HSCm.get_body_from_value sched hr body_value headers include_body with
387 Some (ceheader,body,len) ->
388 k { HST.sl=HSCp.Sl ("1.0", 200, "OK"); headers=[HSCp.Content_Length len]@ceheader; body=body }
389 | None ->
390 k (_not_modified ())
391
392 let handle_get sched runtime _method hr (uri, headers) conn k =
393 #<If>Logger.debug "handle_get: uri=%s" uri#<End>;
394 HSCm.check_host headers;
395 match uri, runtime.HSC.rt_server.HSC.rt_favicon_ico, runtime.HSC.rt_server.HSC.rt_favicon_gif with
396 | ("/favicon.ico", (_,content,_,_), _) when content <> Rc.ContentNone ->
397 handle_special sched runtime _method hr runtime.HSC.rt_server.HSC.rt_favicon_ico headers conn k
398 | ("/favicon.gif", _, (_,content,_,_)) when content <> Rc.ContentNone ->
399 handle_special sched runtime _method hr runtime.HSC.rt_server.HSC.rt_favicon_gif headers conn k
400 | _, _, _ ->
401 let req = { HST.request_scheduler=sched;
402 HST.request_line = { HST._method=_method; request_uri=uri; http_version=HSC.http_version_number };
403 request_header = headers; request_message_body = Rc.ContentNone; request_post_body = [];
404 server_info = hr.HST.hr_server_info; is_multipart = false; handle_request = hr } in
405 (HD.body runtime.HSC.rt_server.HSC.rt_dialog_content sched) { HST.cont=k; request=req; connection=conn; certificate=None }
406
407 let handle_simple_post sched runtime _method hr uri headers body conn k =
408 #<If>Logger.debug "handle_simple_post: uri=%s" uri#<End>;
409 let req = { HST.request_scheduler=sched;
410 HST.request_line = { HST._method = _method ; request_uri = uri ; http_version = HSC.http_version_number };
411 request_header = headers; request_message_body = body; request_post_body = [];
412 server_info = hr.HST.hr_server_info; is_multipart = false; handle_request = hr} in
413 (HD.body runtime.HSC.rt_server.HSC.rt_dialog_content sched) { HST.cont=k; request=req; connection=conn; certificate=None }
414
415 let handle_multipart_post sched runtime _method hr mpr conn k =
416 try
417 #<If>Logger.debug "handle_multipart_post: uri=%s" mpr.HST.uri#<End>;
418 (* Warning: this debug statement doesn't correctly reconstruct the message body, no boundaries *)
419 #<If>let body = String.concat "\n"
420 <| List.rev_map (fun (lst, content) ->
421 String.concat "\n" <| (List.map HSC.string_of_msg lst) @ [Rc.get_content content]) mpr.HST.request_body
422 in Logger.debug "handle_multipart_post: body=%s" (String.escaped (String.limit 1024 body))#<End>;
423 let rl = { HST._method=_method; request_uri=mpr.HST.uri; http_version=HSC.http_version_number } in
424 let req = { HST.request_scheduler=sched;
425 HST.request_line=rl; request_header=mpr.HST.request_headers; request_message_body=Rc.ContentNone;
426 request_post_body=mpr.HST.request_body;
427 server_info=hr.HST.hr_server_info; is_multipart=true; handle_request=hr; } in
428 let cont = fun wi -> List.iter (fun f -> #<If>Logger.debug "deleting %s" f#<End>; Unix.unlink f) mpr.HST.tmpfiles; k wi in
429 (HD.body runtime.HSC.rt_server.HSC.rt_dialog_content sched) { HST.cont=cont; request=req; connection=conn; certificate=None }
430 with exn ->
431 #<If>Logger.debug "handle_multipart_post: exn=%s" (Printexc.to_string exn)#<End>;
432 List.iter (fun f -> #<If>Logger.debug "deleting %s" f#<End>; Unix.unlink f) mpr.HST.tmpfiles;
433 raise exn
434
435 let handle_post sched runtime _method hr = function
436 | HST.Simple (uri, headers, body) -> handle_simple_post sched runtime _method hr uri headers body
437 | HST.Multipart record -> handle_multipart_post sched runtime _method hr record
438
439 let handle_request ?(cachetype="public") ?(is_secure=false) server_info tm lc =
440 { HST.hr_delcookies = false;
441 hr_cachetype = cachetype;
442 hr_server_info = server_info;
443 hr_is_secure = is_secure;
444 hr_timestamp = tm;
445 hr_timestamp_tm = lc;
446 hr_inet_addr_str = "";
447 hr_user_agent = "";
448 hr_referer = "";
449 hr_ec = "";
450 hr_ic = "";
451 hr_dt2 = Time.zero;
452 }
453
454 (* Runtime layer *)
455
456 let name = "httpServer"
457 let version = "1.0"
458
459 type t = HSC.t
460
461 type options =
462 { ssl_cert : string;
463 ssl_key : string;
464 ssl_pass : string;
465 ssl_accept_fun : Ssl.certificate -> bool;
466 ssl_always : bool;
467 ssl_ca_file : string;
468 ssl_ca_path : string;
469 ssl_client_ca_file : string;
470 ssl_client_cert_path : string;
97e3f739 » Hugo Heuzard
2011-06-28 [feature] stdlib: missing ssl param for server
471 ssl_certificate : SslAS.ssl_certificate option;
472 ssl_verify_params : SslAS.ssl_verify_params option;
fccc6851 » MLstate
2011-06-21 Initial open-source release
473 pid_file : string option;
474 dialog : string;
475 request_size_max : int;
476 print_log_info : bool;
477 print_server_info : bool;
478 timeout : float;
479 long_cookies : bool;
480 cookie_expire_time_short : Time.t;
481 cookie_expire_time_long : Time.t;
482 dt1 : Time.t;
483 dt2 : Time.t;
484 max_external_cookies : int;
485 rotate_cookies : bool;
486 cachetype : string;
487 server_send_buffer_size: int;
488 cookie_gc_period: int;
489 cookie_pool_size_min: int;
490 cookie_pool_size_max: int;
491 cookie_timer_interval: int;
492 cookie_rate_max: float;
493 cookie_period_max: int;
494 cookie_rate_ultimate: float;
495 cookie_period_ultimate: int;
496 cookies_filename: string;
497 server_wait_for_request_timeout: Time.t;
498 server_wait_for_request_initial_timeout: Time.t;
499 server_write_timeout: Time.t;
500 maximum_number_of_connections: int;
501 maximum_content_length: int;
502 maximum_number_of_headers: int;
503 favicon_ico: HSC.body_value;
504 favicon_gif: HSC.body_value;
505 backtrace: bool;
506 name : string;
507 addr : string;
508 port : int;
509 block_size : int;
510 allowed_hosts : string list;
511 dos_prevention : bool;
512 drop_privilege : bool;
513 on_server_run : options -> Scheduler.t -> unit;
514 on_server_close : Scheduler.t -> unit;
515 get : Scheduler.t -> HSC.runtime -> HSCp.msg -> HST.handle_request -> HST.get
516 -> Scheduler.connection_info -> (HST.response -> unit) -> unit;
517 post : Scheduler.t -> HSC.runtime -> HSCp.msg -> HST.handle_request -> HST.post
518 -> Scheduler.connection_info -> (HST.response -> unit) -> unit;
519 pre_headers : HST.handle_request -> HSCp.msg -> HST.header list -> (HST.handle_request * HST.header list);
520 post_headers : HST.handle_request -> HSCp.msg -> HST.header list -> HST.header list
521 -> (HST.handle_request * HST.header list * bool);
522 callback : (HSC.payload -> int -> Buffer.t -> bool) option;
523 }
524
525 let null_callback (_str,_hdrs) _i _buf = (*Logger.debug "null_callback(%s): i=%d" str i;*) true
526
527 let null_body_value = (("<no file>", Rc.ContentNone, Time.zero, "unknown/unknown"):HSC.body_value)
528
529 let body_value_from_file ?(log=false) file : HSC.body_value =
530 try
531 let stat = Unix.stat file in
532 let content =
533 if stat.Unix.st_size > (1024*1024)
534 then Rc.ContentFile (file,None,None,Some stat,false)
535 else Rc.ContentString (File.content file) in
536 let modified_time = Time.of_unix_time stat.Unix.st_mtime in
537 let mime_type_string = mime_type file in
538 if log then Logger.info "Loaded file: %s" file;
539 file, content, modified_time, mime_type_string
540 with Unix.Unix_error _ -> null_body_value
541
542 let body_value_from_home ?log file =
543 try body_value_from_file ?log (Filename.concat (Lazy.force File.mlstate_dir) file)
544 with Not_found -> null_body_value
545
546 let bv_file (file,_,_,_) = file
547
548 let default_options =
549 { ssl_cert = "";
550 ssl_key = "";
551 ssl_pass = "";
552 ssl_accept_fun = (fun _ -> true);
553 ssl_always = false;
554 ssl_ca_file = "";
555 ssl_ca_path = "";
556 ssl_client_ca_file = "";
557 ssl_client_cert_path = "";
97e3f739 » Hugo Heuzard
2011-06-28 [feature] stdlib: missing ssl param for server
558 ssl_certificate = None;
559 ssl_verify_params = None;
fccc6851 » MLstate
2011-06-21 Initial open-source release
560 pid_file = None;
561 dialog = "default";
562 request_size_max = 10*1024*1024;
563 print_log_info = true;
564 print_server_info = true;
565 timeout = 36.;
566 long_cookies = true;
567 cookie_expire_time_short = Time.seconds 5;
568 cookie_expire_time_long = Time.seconds 50;
569 dt1 = Time.days 10;
570 dt2 = Time.infinity;
571 max_external_cookies = 10;
572 rotate_cookies = true;
573 cachetype = "public";
574 server_send_buffer_size = 1024;
575 cookie_gc_period = 100;
576 cookie_pool_size_min = 100;
577 cookie_pool_size_max = 10000;
578 cookie_timer_interval = 1;
579 cookie_rate_max = 5.0;
580 cookie_period_max = 5;
581 cookie_rate_ultimate = 10.0;
582 cookie_period_ultimate = 100;
583 cookies_filename = ""(*(Lazy.force File.mlstate_dir)^"/cookies.txt"*);
584 server_wait_for_request_timeout = Time.seconds 36;
585 server_wait_for_request_initial_timeout = Time.seconds 36;
586 server_write_timeout = Time.hours 1;
587 maximum_number_of_connections = max_int;
588 maximum_content_length = (50*1024*1024);
589 maximum_number_of_headers = 200;
590 favicon_ico = null_body_value (*(body_value_from_home ~log:true ".favicon.ico")*);
591 favicon_gif = null_body_value (*(body_value_from_home ~log:true ".favicon.gif")*);
592 backtrace = true;
593 name = "httpServerPort";
594 addr = "0.0.0.0";
595 port = 8080;
596 block_size = 4096; (* TODO: implement separate callbac blocksize *)
597 allowed_hosts = [];
598 dos_prevention = true;
599 drop_privilege = true;
600 on_server_run = (fun _ _ -> ());
601 on_server_close = (fun _ -> ());
602 get = handle_get;
603 post = handle_post;
604 pre_headers = pre_headers;
605 post_headers = post_headers;
606 callback = Some null_callback;
607 }
608
609 let prefixed_opt name opt =
610 if name = "" then
611 [sprintf "--%s" opt]
612 else
613 [sprintf "--%s-%s" name opt; sprintf "--%s" opt]
614
615 let opt_time = function
616 | "inf" | "INF" | "Inf" | "infinity" | "Infinity" | "INFINITY" | "none" | "None" | "NONE" -> Time.infinity
617 | s ->
618 try Time.seconds (int_of_string s)
619 with | Failure "int_of_string" -> failwith ("Argument '"^s^"' not valid time (<int> | \"inf\")")
620
621 let string_of_opt_time t = if t = Time.infinity then "inf" else sprintf "%7.0f" (Time.in_seconds t)
622
623 let spec_args name =
624 let p = prefixed_opt name in
625 [
626 (p"addr")@["-a"],
627 ServerArg.func ServerArg.string
628 (fun o a ->
629 ((try ignore (Unix.inet_addr_of_string a) with Failure _ -> (Logger.critical "Bad address: %s" a; exit 1));
630 { o with addr = a })),
631 "<string>", (sprintf "Sets the IP address on which the server should run (default:%s)"
632 default_options.addr);
633
634 (p"port")@["-p"],
635 ServerArg.func ServerArg.int
636 (fun o p -> if p > 0xffff then (Logger.critical "Bad port number: %d" p; exit 1) else { o with port = p }),
637 "<int>", (sprintf "Sets the port on which the server should run (default:%d)" default_options.port);
638
639 p"long-cookies",
640 ServerArg.func ServerArg.bool (fun o b -> { o with long_cookies = b }),
641 "<bool>", (sprintf "Use long cookies (default:%b)" default_options.long_cookies);
642
643 p"cookie-expire-short",
644 ServerArg.func ServerArg.int (fun o i -> { o with cookie_expire_time_short = Time.seconds i }),
645 "<int>", (sprintf "Cookie expire time (short) seconds (default:%1.0f)"
646 (Time.in_seconds default_options.cookie_expire_time_short));
647
648 p"cookie-expire-long",
649 ServerArg.func ServerArg.int (fun o i -> { o with cookie_expire_time_long = Time.seconds i }),
650 "<int>", (sprintf "Cookie expire time (long) seconds (default:%2.0f)"
651 (Time.in_seconds default_options.cookie_expire_time_long));
652
653 p"long-cookie-expire-variable",
654 ServerArg.func ServerArg.string (fun o s -> { o with dt1 = opt_time s }),
655 "<int>|\"inf\"", (sprintf "Long cookie variable expire time seconds (default:%s)"
656 (string_of_opt_time default_options.dt1));
657
658 p"long-cookie-expire-fixed",
659 ServerArg.func ServerArg.string (fun o s -> { o with dt2 = opt_time s }),
660 "<int>|\"inf\"", (sprintf "Long cookie fixed expire time seconds (default:%s)"
661 (string_of_opt_time default_options.dt2));
662
663 p"max-external-cookies",
664 ServerArg.func ServerArg.int (fun o i -> { o with max_external_cookies = i }),
665 "<int>", (sprintf "Maximum number of concurrent external cookies per internal cookie (default:%d)"
666 default_options.max_external_cookies);
667
668 p"no-rotate-cookies",
669 ServerArg.func ServerArg.unit (fun o () -> { o with rotate_cookies = false }),
670 "", (sprintf "Switch off cookie rotation" (*default_options.rotate_cookies*));
671
672 p"server-send-buffer-size",
673 ServerArg.func ServerArg.int (fun o i -> { o with server_send_buffer_size = i }),
674 "<int>", (sprintf "Server send buffer size (default: %d)" default_options.server_send_buffer_size);
675
676 p"cookie-gc-period",
677 ServerArg.func ServerArg.int (fun o i -> { o with cookie_gc_period = i }),
678 "<int>", (sprintf "Cookie GC period in requests (default: %d)" default_options.cookie_gc_period);
679
680 p"cookie-pool-size-min",
681 ServerArg.func ServerArg.int (fun o i -> { o with cookie_pool_size_min = i }),
682 "<int>", (sprintf "Cookie pool size minimum (default: %d)" default_options.cookie_pool_size_min);
683
684 p"cookie-pool-size-max",
685 ServerArg.func ServerArg.int (fun o i -> { o with cookie_pool_size_max = i }),
686 "<int>", (sprintf "Cookie pool size maximum (default: %d)" default_options.cookie_pool_size_max);
687
688 p"cookie-timer-interval",
689 ServerArg.func ServerArg.int (fun o i -> { o with cookie_timer_interval = i }),
690 "<int>", (sprintf "Cookie timer interval (seconds) (default: %d)" default_options.cookie_timer_interval);
691
692 p"cookie-rate-max",
693 ServerArg.func ServerArg.float (fun o f -> { o with cookie_rate_max = f }),
694 "<float>", (sprintf "Cookie connection rate max (default: %3.1f)" default_options.cookie_rate_max);
695
696 p"cookie-period-max",
697 ServerArg.func ServerArg.int (fun o i -> { o with cookie_period_max = i }),
698 "<int>", (sprintf "Cookie rotation period above max rate (default: %d)" default_options.cookie_period_max);
699
700 p"cookie-rate-ultimate",
701 ServerArg.func ServerArg.float (fun o f -> { o with cookie_rate_ultimate = f }),
702 "<float>", (sprintf "Cookie connection rate ultimate (default: %3.1f)" default_options.cookie_rate_ultimate);
703
704 p"cookie-period-ultimate",
705 ServerArg.func ServerArg.int (fun o i -> { o with cookie_period_ultimate = i }),
706 "<int>", (sprintf "Cookie rotation period above ultimate rate (default: %d)" default_options.cookie_period_ultimate);
707
708 p"cookies-filename",
709 ServerArg.func ServerArg.string (fun o s -> { o with cookies_filename = s }),
710 "<filename>", (sprintf "Cookies filename (empty=disabled) (default: %s)" default_options.cookies_filename);
711
712 p"wait-for-request-timeout",
713 ServerArg.func ServerArg.float (fun o f -> { o with server_wait_for_request_timeout = Time.seconds_float f }),
714 "<float>", (sprintf "Timeout while waiting for requests (default: %4.1f)"
715 (Time.in_seconds default_options.server_wait_for_request_timeout));
716
717 p"wait-for-request-initial-timeout",
718 ServerArg.func ServerArg.float (fun o f -> { o with server_wait_for_request_initial_timeout = Time.seconds_float f }),
719 "<float>", (sprintf "Initial timeout while waiting for requests (default: %4.1f)"
720 (Time.in_seconds default_options.server_wait_for_request_initial_timeout));
721
722 p"write-timeout",
723 ServerArg.func ServerArg.float (fun o f -> { o with server_write_timeout = Time.seconds_float f }),
724 "<float>", (sprintf "Timeout while writing data (default: %6.1f)" (Time.in_seconds default_options.server_write_timeout));
725
726 (*(p"max-connections")@["-C"],
727 ServerArg.func ServerArg.int (fun o i -> { o with maximum_number_of_connections = i }),
728 "<int>", "Maximum number of active server connections (default: 100)";*)
729
730 p"maximum-content-length",
731 ServerArg.func ServerArg.int (fun o i -> { o with maximum_content_length = i }),
732 "<int>", (sprintf "Maximum request content length (default: %d)" default_options.maximum_content_length);
733
734 p"maximum-number-of-headers",
735 ServerArg.func ServerArg.int (fun o i -> { o with maximum_number_of_headers = i }),
736 "<int>", (sprintf "Maximum number of request headers (default: %d)" default_options.maximum_number_of_headers);
737
738 p"favicon-ico",
739 ServerArg.func ServerArg.string (fun o s -> { o with favicon_ico = body_value_from_file ~log:true s }),
740 "<string>", (sprintf "Favicon.ico file (default: %s)" (bv_file default_options.favicon_ico));
741
742 p"favicon-gif",
743 ServerArg.func ServerArg.string (fun o s -> { o with favicon_gif = body_value_from_file ~log:true s }),
744 "<string>", (sprintf "Favicon.gif file (default: %s)" (bv_file default_options.favicon_gif));
745
746 p"no-print-log-info",
747 ServerArg.func ServerArg.unit (fun o () -> { o with print_log_info = false }),
748 "", (sprintf "Disable access and error logs" (*default_options.print_log_info*));
749
750 p"no-print-server-info",
751 ServerArg.func ServerArg.unit (fun o () -> { o with print_server_info = false }),
752 "", (sprintf "Disable server information printout" (*default_options.print_server_info*));
753
754 p"no-flood-prevention",
755 ServerArg.func ServerArg.unit (fun o () -> { o with dos_prevention = false }),
756 "", (sprintf "Disable the built-in protection against Denial-of-Service attacks" (*default_options.dos_prevention*));
757
758 p"no-backtrace",
759 ServerArg.func ServerArg.unit (fun o () -> { o with backtrace = false }),
760 "", (sprintf "Disable backtrace printout for server exceptions" (*default_options.backtrace*));
761
762 p"no-drop-privilege",
763 ServerArg.func ServerArg.unit (fun o () -> { o with drop_privilege = false }),
764 "", (sprintf "Disable the drop of privilege on server start" (*default_options.drop_privilege*));
765
766 p"ssl-cert",
767 ServerArg.func ServerArg.string (fun o s -> { o with ssl_cert = s }),
768 "<file>", (sprintf "Location of your SSL certificate (requires ssl-key) (default:'%s')" default_options.ssl_cert);
769
770 p"ssl-key",
771 ServerArg.func ServerArg.string (fun o s -> { o with ssl_key = s }),
772 "<file>", (sprintf "Location of your SSL key (requires ssl-cert) (default:'%s')" default_options.ssl_key);
773
774 p"ssl-pass",
775 ServerArg.func ServerArg.string (fun o s -> { o with ssl_pass = s }),
776 "<string>", (sprintf "Password of your SSL certificate (requires ssl-cert and ssl-key options) (default:'%s')"
777 default_options.ssl_pass);
778
779 p"dialog",
780 ServerArg.func ServerArg.string (fun o s -> { o with dialog = s }),
781 "<string>", (sprintf "Name of the http dialog to use (default:'%s') "
782 default_options.dialog);
783
784 p"pidfile",
785 ServerArg.func ServerArg.string (fun o s -> { o with pid_file = Some s }),
786 "<string>", "File to dump server's pid. Server exits on error."
787
788 ]
789
790 (* From httpServerOptions *)
791 let make_ssl_cert opt =
97e3f739 » Hugo Heuzard
2011-06-28 [feature] stdlib: missing ssl param for server
792 match opt.ssl_certificate with
793 | Some x -> Some x
794 | None ->
795 if opt.ssl_cert <> "" then
796 if opt.ssl_key <> "" then
797 Some (SslAS.make_ssl_certificate opt.ssl_cert opt.ssl_key opt.ssl_pass)
798 else begin
799 Logger.critical "Error : ssl-cert option MUST be used with ssl-key option";
800 exit 1
801 end
802 else
803 None
fccc6851 » MLstate
2011-06-21 Initial open-source release
804
805 let make_ssl_verify opt =
97e3f739 » Hugo Heuzard
2011-06-28 [feature] stdlib: missing ssl param for server
806 match opt.ssl_verify_params with
807 | Some x -> Some x
808 | None ->
809 if opt.ssl_ca_file <> "" || opt.ssl_ca_path <> "" || opt.ssl_client_cert_path <> "" then
810 Some (SslAS.make_ssl_verify_params ~client_ca_file:opt.ssl_client_ca_file
811 ~accept_fun:opt.ssl_accept_fun ~always:opt.ssl_always
812 opt.ssl_ca_file opt.ssl_ca_path opt.ssl_client_cert_path)
813 else
814 None
fccc6851 » MLstate
2011-06-21 Initial open-source release
815
816 let init_server opt runtime server_info =
817 if opt.print_log_info then HSCm.init_logger ();
818 if opt.print_server_info then HSCm.banner runtime server_info
819
820 let options = ((Hashtbl.create 4):(string,options) Hashtbl.t)
821 let () = Hashtbl.add options "default" default_options
822
823 let get_options ?(name="default") () = Hashtbl.find options name
824
825 let make (name:string) (opt:options) (sched:Scheduler.t) : t =
826 #<If>Logger.debug "HttpServer.make: name=%s addr=%s port=%d ssl_cert=%s" name opt.addr opt.port opt.ssl_cert#<End>;
827 let _ = Lazy.force m2 in
828 Hashtbl.add options name opt;
829 (*if opt.drop_privilege then Systools.change_user ();*)
830 let secure_mode = Network.secure_mode_from_params (make_ssl_cert opt) (make_ssl_verify opt) in
831 let addr = Unix.inet_addr_of_string opt.addr in
832 let server_info = HSCm.make_server_info addr opt.port (opt.ssl_cert <> "") in
833 let is_secure = match secure_mode with Network.Secured _ -> true | _ -> false in
834 let tm = Time.now () in
835 let lc = Time.localtime tm in
836 let hr = handle_request ~cachetype:opt.cachetype ~is_secure server_info tm lc in
837 HSCm.set_allowed_hosts opt.allowed_hosts;
838 HSCm.use_long_cookies := opt.long_cookies;
839 (if !HSCm.use_long_cookies then CookieLong.init_cookies else Cookie2.init_cookies)
840 ~sched ~gc_period:opt.cookie_gc_period
841 ~pool_min:opt.cookie_pool_size_min
842 ~pool_max:opt.cookie_pool_size_max
843 ~timer_interval:opt.cookie_timer_interval
844 ~rate_max:opt.cookie_rate_max
845 ~period_max:opt.cookie_period_max
846 ~rate_ultimate:opt.cookie_rate_ultimate
847 ~period_ultimate:opt.cookie_period_ultimate
848 ~expires_short:opt.cookie_expire_time_short
849 ~expires_long:opt.cookie_expire_time_long
850 ~dt1:opt.dt1
851 ~dt2:opt.dt2
852 ~max_external_cookies:opt.max_external_cookies
853 ~rotate_cookies:opt.rotate_cookies
854 ~cookies_filename:opt.cookies_filename
855 ();
856 let log_accesses = ref true in
857 #<If:NO_ACCESS_LOG> log_accesses := false #<End>;
858 let gm = Time.gmtime tm in
859 let diff = lc.Unix.tm_hour - gm.Unix.tm_hour in
860 let sign = if diff > 0 then "+" else if diff < 0 then "-" else "" in
861 HST.time_diff := sprintf "%s%02d00" sign diff;
862 let runtime = {
863 HSC.rt_get = opt.get;
864 rt_post = opt.post;
865 rt_core =
866 { HSC.rt_pre_headers = opt.pre_headers;
867 rt_post_headers = opt.post_headers;
868 rt_server_send_buffer_size = opt.server_send_buffer_size;
869 rt_server_wait_for_request_timeout = opt.server_wait_for_request_timeout;
870 rt_server_wait_for_request_initial_timeout = opt.server_wait_for_request_initial_timeout;
871 rt_maximum_number_of_connections = opt.maximum_number_of_connections;
872 rt_maximum_content_length = opt.maximum_content_length;
873 rt_maximum_number_of_headers = opt.maximum_number_of_headers;
874 rt_log_accesses = (!log_accesses);
875 rt_time_diff = !(HST.time_diff);
876 rt_plim = 128;
877 };
878 rt_server =
879 { HSC.rt_dialog_content = Obj.magic None;
880 rt_dialog_name = opt.dialog;
881 rt_server_name = name;
882 rt_on_run = opt.on_server_run opt;
883 rt_on_close = opt.on_server_close;
884 rt_favicon_ico = opt.favicon_ico;
885 rt_favicon_gif = opt.favicon_gif;
886 };
887 rt_proto =
888 { HSC.rt_name = opt.name;
889 rt_addr = opt.addr;
890 rt_port = opt.port;
891 rt_secure_mode = secure_mode;
892 rt_block_size = opt.block_size;
893 rt_backtrace = opt.backtrace;
894 rt_server_write_timeout = opt.server_write_timeout;
895 rt_payload = HSC.null_payload;
896 };
897 rt_tmp =
898 { HSC.rt_hr = hr;
899 rt_conn = 0;
900 rt_callback = opt.callback;
901 };
902 } in
903 init_server opt runtime server_info;
904 let () = (
905 match opt.pid_file with
906 | None -> ()
907 | Some f -> (
908 try begin
909 let ochan = open_out f in
910 let () = output_string ochan (sprintf "%d" (Unix.getpid())) in
911 let () = close_out ochan in
912 at_exit (fun () ->
913 try Unix.unlink f
914 with Unix.Unix_error (Unix.ENOENT, _, s2) ->
915 Logger.critical "HttpServer.make: couldn't delete pid file '%s'\n" s2
916 )
917 end with Sys_error e ->
918 let () = Logger.critical "HttpServer.make:'%s'\n" e in exit 1
919 )
920 ) in
921 { HSC.runtime = runtime; HSC.err_cont = None; HSC.extra_params = hr; }
922
923 let get_ports (server:t) (sched:Scheduler.t) =
924 (HSC.get_ports server sched)
925 @[(server.HSC.runtime.HSC.rt_server.HSC.rt_dialog_name,
926 `HttpDialog { HttpDialog.set_dialog = fun dialog -> server.HSC.runtime.HSC.rt_server.HSC.rt_dialog_content <- dialog })]
927
928 let get_description _http_server _sched = `HttpServer
929
930 let run http_server sched = http_server.HSC.runtime.HSC.rt_server.HSC.rt_on_run sched; http_server
931
932 let close (http_server:t) sched = http_server.HSC.runtime.HSC.rt_server.HSC.rt_on_close sched
Something went wrong with that request. Please try again.