Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 891 lines (764 sloc) 39.145 kb
fccc685 Initial open-source release
MLstate authored
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
209 let limstr ?(extra="") str lim = let len = String.length str in (String.sub str 0 (min lim len))^(if len > lim then extra else "")
210
211 let make_response ?(modified_since=None) ?(compression_level=6) ?(cache_response=true) ?(expires=Time.zero) ?(cache=true)
212 ?(delcookies=false) ?location ?req status_line _type ?content_dispo content =
213 #<If$minlevel 20>Logger.debug "make_response"#<End>;
214 let code = Rd.status_code status_line in
215 let reason = Rd.reason_phrase code in
216 let sl = HSCp.Sl (HSC.http_version_number, code, reason) in
217 let content =
218 match content with
219 | Http_common.Result page -> page
220 | _ -> "<html><head><title>Error</title></head><body>Error.</body></html>" in
221 #<If>Logger.debug "make_response: content=%s" (limstr ~extra:"..." content 100)#<End>;
222 let (sched,hr_opt,uri,headers_in,include_body) =
223 match req with
224 Some req -> (req.HST.request_scheduler,
225 (Some req.HST.handle_request),
226 req.HST.request_line.HST.request_uri,
227 req.HST.request_header,
228 (match req.HST.request_line.HST._method with HSCp.Head _ -> false | _ -> true))
229 | _ -> (Scheduler.default,None,"",[],true) in
230 match HSCm.process_content sched ~modified_since ~compression_level ~cache_response ~expires
231 ~cache ~_delcookies:delcookies ~_type ?content_dispo
232 hr_opt uri (Rc.ContentString content) headers_in include_body with
233 Some (headers_out,body,len) ->
234 let headers_out = match location with
235 | Some url -> (HSCp.Location url)::headers_out
236 | None -> headers_out in
237 { HST.sl = sl; HST.headers = [HSCp.Content_Length len]@headers_out; HST.body = body }
238 | None -> _not_modified ()
239
240 let make_response_result ?(modified_since=None) ?(compression_level=6) ?(cache_response=true) ?(expires=Time.zero)
241 ?(cache=true) ?(delcookies=false) ?location ?req status _type ?content_dispo content =
242 make_response ~modified_since:modified_since ~compression_level:compression_level
243 ~cache_response:cache_response ~expires:expires ~cache:cache ~delcookies:delcookies
244 ?location ?req status _type ?content_dispo
245 (Http_common.Result content)
246
247 let make_response_modified_since date req = make_response ~modified_since:(Some date) ~req
248 let make_response_req expires req = make_response ~expires ~req
249 let make_response_req_loc expires location req = make_response ~expires ~location ~req
250
251 let get_req_type req = req.HST.request_line.HST._method
252
253 let move_page time url sc =
254 let code = Rd.status_code sc in
255 let reason = Rd.reason_phrase code in
256 Http_common.Result (sprintf "<html><head><meta http-equiv=\"refresh\" content=\"%d; URL=%s\"></head>%s</html>" (truncate (Time.in_seconds time)) url
257 (if Time.is_positive time then sprintf "<body><p>%s %d %s</p></body>" HSC.http_version code reason else ""))
258
259 let error_page server_url e =
260 let sc = Rd.status_code e in
261 let rp = Rd.reason_phrase sc in
262 Http_common.Result
263 (sprintf
264 "<html><head><title>%d %s</title></head><body><h1>Error %d: %s</h1><hr /><p><a href=\"%s\">%s</a></body></p></html>"
265 sc rp sc rp server_url HSC.server_name)
266
267 let make_error ?req status =
268 match req with
269 | Some req ->
270 let server_url = get_server_url req in
271 make_response ~req status "text/html" (error_page server_url status)
272 | _ -> make_response status "text/html" (error_page "" status)
273
274 let make_moved ?(time=Time.zero) req url =
275 make_response ~location:url ~req Rd.SC_MovedPermanently "text/html"
276 (move_page time url Rd.SC_MovedPermanently)
277 let make_redirect ?(time=Time.zero) req url =
278 make_response ~location:url ~req Rd.SC_TemporaryRedirect "text/html"
279 (move_page time url Rd.SC_TemporaryRedirect)
280
281 let direct_pair req (m, c) = make_response ~expires:Time.infinity ~req Rd.SC_OK m (Http_common.Result c)
282 let direct ?(expires=Time.infinity) req = make_response ~expires ~req Rd.SC_OK
283
284 let html ?(compression_level=6) ?(cache_response=true) ?(cache=true) ?(delcookies=false) ?(charset="") req =
285 let charset = if charset = "" then "" else "; charset=" ^ charset in
286 let mime = (mime_type ".html") ^ charset in
287 make_response_result ~compression_level:compression_level ~cache_response:cache_response
288 ~cache:cache ~delcookies:delcookies ~req Rd.SC_OK mime
289
290 let get_fields req =
291 let body = Rc.get_content req.HST.request_message_body in
292 let s = String.sub body 0 (get_content_length req) in
293 try
294 let _pos, res = Encodings.http_body_rewrite s in
295 res
296 with Encodings.HttpBodyRewriteError _ -> []
297
298 (* MAIN FUNCTIONS *)
299
300 let make_error_response k sched conn uri hr _method html code msg headers =
301 let req = { HST.request_scheduler = sched;
302 request_line = { HST._method=_method; request_uri=uri; http_version=HSC.http_version_number };
303 request_header = [HSCp.Sl (HSC.http_version_number, code, msg)]@headers
304 @[HSCp.Content_Length (Int64.of_int (String.length html))];
305 request_message_body = Rc.ContentString html; request_post_body = [];
306 server_info = hr.HST.hr_server_info; is_multipart = false; handle_request = hr } in
307 { HST.cont=k; request=req; connection=conn; certificate=None }
308
309 let not_found k sched conn uri hr _method =
310 make_error_response k sched conn uri hr _method
311 "<html><head><title>404 Error</title></head><body>404 - Not Found</body></html>" 404 "Not Found" []
312
313 let unauthorized k sched conn uri hr _method =
314 make_error_response k sched conn uri hr _method
315 "<html><head><title>401 Error</title></head><body>401 - Unauthorized</body></html>" 401 "Unauthorized" []
316
317 let not_modified ?(include_date=true) k sched conn uri hr _method =
318 make_error_response
319 k sched conn uri hr _method
320 (* SEE: RFC 2616 10.3.5 *)
321 "" 304 "Not Modified"
322 (if include_date
323 then [HSCp.Date (Date.rfc1123 (Unix.gmtime (Unix.time())))] (* RFC2616: 10.3.5 - we have a clock *)
324 else [])
325
326 let pre_headers hr request_type headers =
327 #<If:HTTP_NO_COOKIE>
328 (hr, headers)
329 #<Else>
330 (HSCm.cookies2In hr (HSC.request_type_uri request_type), headers)
331 #<End>
332
333 let post_headers hr request_type headers_in headers_out =
334 let connection_opt =
335 match (List.find_opt (function HSCp.Connection _ -> true | _ -> false) headers_in) with
336 | Some (HSCp.Connection s) -> Some s
337 | _ -> None in
338 let (header,close) =
339 match (HSC.request_type_http_version request_type, connection_opt) with
340 | ("1.0",None) -> ([HSCp.Connection "close"],true)
341 | ("1.1",None) -> ([HSCp.Connection "Keep-Alive"],false)
342 | (_,Some s) when String.is_substring_insensitive "keep-alive" s 0 -> ([HSCp.Connection "Keep-Alive"],false)
343 | (_,Some s) when String.is_substring_insensitive "close" s 0 -> ([HSCp.Connection "Close"],true)
344 | _ -> ([HSCp.Connection "Keep-Alive"],false) in
345 #<If:HTTP_NO_COOKIE>
346 (hr,(headers_out@header),close)
347 #<Else>
348 let cookies = HSCm.cookies2Out hr (HSC.request_type_uri request_type) false headers_in in
349 (hr,(headers_out@header@cookies),close)
350 #<End>
351
352 let handle_special sched _runtime _method hr body_value headers _conn k =
353 let include_body = match _method with HSCp.Head _ -> false | _ -> true in
354 match HSCm.get_body_from_value sched hr body_value headers include_body with
355 Some (ceheader,body,len) ->
356 k { HST.sl=HSCp.Sl ("1.0", 200, "OK"); headers=[HSCp.Content_Length len]@ceheader; body=body }
357 | None ->
358 k (_not_modified ())
359
360 let handle_get sched runtime _method hr (uri, headers) conn k =
361 #<If>Logger.debug "handle_get: uri=%s" uri#<End>;
362 HSCm.check_host headers;
363 match uri, runtime.HSC.rt_server.HSC.rt_favicon_ico, runtime.HSC.rt_server.HSC.rt_favicon_gif with
364 | ("/favicon.ico", (_,content,_,_), _) when content <> Rc.ContentNone ->
365 handle_special sched runtime _method hr runtime.HSC.rt_server.HSC.rt_favicon_ico headers conn k
366 | ("/favicon.gif", _, (_,content,_,_)) when content <> Rc.ContentNone ->
367 handle_special sched runtime _method hr runtime.HSC.rt_server.HSC.rt_favicon_gif headers conn k
368 | _, _, _ ->
369 let req = { HST.request_scheduler=sched;
370 HST.request_line = { HST._method=_method; request_uri=uri; http_version=HSC.http_version_number };
371 request_header = headers; request_message_body = Rc.ContentNone; request_post_body = [];
372 server_info = hr.HST.hr_server_info; is_multipart = false; handle_request = hr } in
373 (HD.body runtime.HSC.rt_server.HSC.rt_dialog_content sched) { HST.cont=k; request=req; connection=conn; certificate=None }
374
375 let handle_simple_post sched runtime _method hr uri headers body conn k =
376 #<If>Logger.debug "handle_simple_post: uri=%s" uri#<End>;
377 let req = { HST.request_scheduler=sched;
378 HST.request_line = { HST._method = _method ; request_uri = uri ; http_version = HSC.http_version_number };
379 request_header = headers; request_message_body = body; request_post_body = [];
380 server_info = hr.HST.hr_server_info; is_multipart = false; handle_request = hr} in
381 (HD.body runtime.HSC.rt_server.HSC.rt_dialog_content sched) { HST.cont=k; request=req; connection=conn; certificate=None }
382
383 let handle_multipart_post sched runtime _method hr mpr conn k =
384 try
385 #<If>Logger.debug "handle_multipart_post: uri=%s" mpr.HST.uri#<End>;
386 (* Warning: this debug statement doesn't correctly reconstruct the message body, no boundaries *)
387 #<If>let body = String.concat "\n"
388 <| List.rev_map (fun (lst, content) ->
389 String.concat "\n" <| (List.map HSC.string_of_msg lst) @ [Rc.get_content content]) mpr.HST.request_body
390 in Logger.debug "handle_multipart_post: body=%s" (String.escaped (String.limit 1024 body))#<End>;
391 let rl = { HST._method=_method; request_uri=mpr.HST.uri; http_version=HSC.http_version_number } in
392 let req = { HST.request_scheduler=sched;
393 HST.request_line=rl; request_header=mpr.HST.request_headers; request_message_body=Rc.ContentNone;
394 request_post_body=mpr.HST.request_body;
395 server_info=hr.HST.hr_server_info; is_multipart=true; handle_request=hr; } in
396 let cont = fun wi -> List.iter (fun f -> #<If>Logger.debug "deleting %s" f#<End>; Unix.unlink f) mpr.HST.tmpfiles; k wi in
397 (HD.body runtime.HSC.rt_server.HSC.rt_dialog_content sched) { HST.cont=cont; request=req; connection=conn; certificate=None }
398 with exn ->
399 #<If>Logger.debug "handle_multipart_post: exn=%s" (Printexc.to_string exn)#<End>;
400 List.iter (fun f -> #<If>Logger.debug "deleting %s" f#<End>; Unix.unlink f) mpr.HST.tmpfiles;
401 raise exn
402
403 let handle_post sched runtime _method hr = function
404 | HST.Simple (uri, headers, body) -> handle_simple_post sched runtime _method hr uri headers body
405 | HST.Multipart record -> handle_multipart_post sched runtime _method hr record
406
407 let handle_request ?(cachetype="public") ?(is_secure=false) server_info tm lc =
408 { HST.hr_delcookies = false;
409 hr_cachetype = cachetype;
410 hr_server_info = server_info;
411 hr_is_secure = is_secure;
412 hr_timestamp = tm;
413 hr_timestamp_tm = lc;
414 hr_inet_addr_str = "";
415 hr_user_agent = "";
416 hr_referer = "";
417 hr_ec = "";
418 hr_ic = "";
419 hr_dt2 = Time.zero;
420 }
421
422 (* Runtime layer *)
423
424 let name = "httpServer"
425 let version = "1.0"
426
427 type t = HSC.t
428
429 type options =
430 { ssl_cert : string;
431 ssl_key : string;
432 ssl_pass : string;
433 ssl_accept_fun : Ssl.certificate -> bool;
434 ssl_always : bool;
435 ssl_ca_file : string;
436 ssl_ca_path : string;
437 ssl_client_ca_file : string;
438 ssl_client_cert_path : string;
439 pid_file : string option;
440 dialog : string;
441 request_size_max : int;
442 print_log_info : bool;
443 print_server_info : bool;
444 timeout : float;
445 long_cookies : bool;
446 cookie_expire_time_short : Time.t;
447 cookie_expire_time_long : Time.t;
448 dt1 : Time.t;
449 dt2 : Time.t;
450 max_external_cookies : int;
451 rotate_cookies : bool;
452 cachetype : string;
453 server_send_buffer_size: int;
454 cookie_gc_period: int;
455 cookie_pool_size_min: int;
456 cookie_pool_size_max: int;
457 cookie_timer_interval: int;
458 cookie_rate_max: float;
459 cookie_period_max: int;
460 cookie_rate_ultimate: float;
461 cookie_period_ultimate: int;
462 cookies_filename: string;
463 server_wait_for_request_timeout: Time.t;
464 server_wait_for_request_initial_timeout: Time.t;
465 server_write_timeout: Time.t;
466 maximum_number_of_connections: int;
467 maximum_content_length: int;
468 maximum_number_of_headers: int;
469 favicon_ico: HSC.body_value;
470 favicon_gif: HSC.body_value;
471 backtrace: bool;
472 name : string;
473 addr : string;
474 port : int;
475 block_size : int;
476 allowed_hosts : string list;
477 dos_prevention : bool;
478 drop_privilege : bool;
479 on_server_run : options -> Scheduler.t -> unit;
480 on_server_close : Scheduler.t -> unit;
481 get : Scheduler.t -> HSC.runtime -> HSCp.msg -> HST.handle_request -> HST.get
482 -> Scheduler.connection_info -> (HST.response -> unit) -> unit;
483 post : Scheduler.t -> HSC.runtime -> HSCp.msg -> HST.handle_request -> HST.post
484 -> Scheduler.connection_info -> (HST.response -> unit) -> unit;
485 pre_headers : HST.handle_request -> HSCp.msg -> HST.header list -> (HST.handle_request * HST.header list);
486 post_headers : HST.handle_request -> HSCp.msg -> HST.header list -> HST.header list
487 -> (HST.handle_request * HST.header list * bool);
488 callback : (HSC.payload -> int -> Buffer.t -> bool) option;
489 }
490
491 let null_callback (_str,_hdrs) _i _buf = (*Logger.debug "null_callback(%s): i=%d" str i;*) true
492
493 let null_body_value = (("<no file>", Rc.ContentNone, Time.zero, "unknown/unknown"):HSC.body_value)
494
495 let body_value_from_file ?(log=false) file : HSC.body_value =
496 try
497 let stat = Unix.stat file in
498 let content =
499 if stat.Unix.st_size > (1024*1024)
500 then Rc.ContentFile (file,None,None,Some stat,false)
501 else Rc.ContentString (File.content file) in
502 let modified_time = Time.of_unix_time stat.Unix.st_mtime in
503 let mime_type_string = mime_type file in
504 if log then Logger.info "Loaded file: %s" file;
505 file, content, modified_time, mime_type_string
506 with Unix.Unix_error _ -> null_body_value
507
508 let body_value_from_home ?log file =
509 try body_value_from_file ?log (Filename.concat (Lazy.force File.mlstate_dir) file)
510 with Not_found -> null_body_value
511
512 let bv_file (file,_,_,_) = file
513
514 let default_options =
515 { ssl_cert = "";
516 ssl_key = "";
517 ssl_pass = "";
518 ssl_accept_fun = (fun _ -> true);
519 ssl_always = false;
520 ssl_ca_file = "";
521 ssl_ca_path = "";
522 ssl_client_ca_file = "";
523 ssl_client_cert_path = "";
524 pid_file = None;
525 dialog = "default";
526 request_size_max = 10*1024*1024;
527 print_log_info = true;
528 print_server_info = true;
529 timeout = 36.;
530 long_cookies = true;
531 cookie_expire_time_short = Time.seconds 5;
532 cookie_expire_time_long = Time.seconds 50;
533 dt1 = Time.days 10;
534 dt2 = Time.infinity;
535 max_external_cookies = 10;
536 rotate_cookies = true;
537 cachetype = "public";
538 server_send_buffer_size = 1024;
539 cookie_gc_period = 100;
540 cookie_pool_size_min = 100;
541 cookie_pool_size_max = 10000;
542 cookie_timer_interval = 1;
543 cookie_rate_max = 5.0;
544 cookie_period_max = 5;
545 cookie_rate_ultimate = 10.0;
546 cookie_period_ultimate = 100;
547 cookies_filename = ""(*(Lazy.force File.mlstate_dir)^"/cookies.txt"*);
548 server_wait_for_request_timeout = Time.seconds 36;
549 server_wait_for_request_initial_timeout = Time.seconds 36;
550 server_write_timeout = Time.hours 1;
551 maximum_number_of_connections = max_int;
552 maximum_content_length = (50*1024*1024);
553 maximum_number_of_headers = 200;
554 favicon_ico = null_body_value (*(body_value_from_home ~log:true ".favicon.ico")*);
555 favicon_gif = null_body_value (*(body_value_from_home ~log:true ".favicon.gif")*);
556 backtrace = true;
557 name = "httpServerPort";
558 addr = "0.0.0.0";
559 port = 8080;
560 block_size = 4096; (* TODO: implement separate callbac blocksize *)
561 allowed_hosts = [];
562 dos_prevention = true;
563 drop_privilege = true;
564 on_server_run = (fun _ _ -> ());
565 on_server_close = (fun _ -> ());
566 get = handle_get;
567 post = handle_post;
568 pre_headers = pre_headers;
569 post_headers = post_headers;
570 callback = Some null_callback;
571 }
572
573 let prefixed_opt name opt =
574 if name = "" then
575 [sprintf "--%s" opt]
576 else
577 [sprintf "--%s-%s" name opt; sprintf "--%s" opt]
578
579 let opt_time = function
580 | "inf" | "INF" | "Inf" | "infinity" | "Infinity" | "INFINITY" | "none" | "None" | "NONE" -> Time.infinity
581 | s ->
582 try Time.seconds (int_of_string s)
583 with | Failure "int_of_string" -> failwith ("Argument '"^s^"' not valid time (<int> | \"inf\")")
584
585 let string_of_opt_time t = if t = Time.infinity then "inf" else sprintf "%7.0f" (Time.in_seconds t)
586
587 let spec_args name =
588 let p = prefixed_opt name in
589 [
590 (p"addr")@["-a"],
591 ServerArg.func ServerArg.string
592 (fun o a ->
593 ((try ignore (Unix.inet_addr_of_string a) with Failure _ -> (Logger.critical "Bad address: %s" a; exit 1));
594 { o with addr = a })),
595 "<string>", (sprintf "Sets the IP address on which the server should run (default:%s)"
596 default_options.addr);
597
598 (p"port")@["-p"],
599 ServerArg.func ServerArg.int
600 (fun o p -> if p > 0xffff then (Logger.critical "Bad port number: %d" p; exit 1) else { o with port = p }),
601 "<int>", (sprintf "Sets the port on which the server should run (default:%d)" default_options.port);
602
603 p"long-cookies",
604 ServerArg.func ServerArg.bool (fun o b -> { o with long_cookies = b }),
605 "<bool>", (sprintf "Use long cookies (default:%b)" default_options.long_cookies);
606
607 p"cookie-expire-short",
608 ServerArg.func ServerArg.int (fun o i -> { o with cookie_expire_time_short = Time.seconds i }),
609 "<int>", (sprintf "Cookie expire time (short) seconds (default:%1.0f)"
610 (Time.in_seconds default_options.cookie_expire_time_short));
611
612 p"cookie-expire-long",
613 ServerArg.func ServerArg.int (fun o i -> { o with cookie_expire_time_long = Time.seconds i }),
614 "<int>", (sprintf "Cookie expire time (long) seconds (default:%2.0f)"
615 (Time.in_seconds default_options.cookie_expire_time_long));
616
617 p"long-cookie-expire-variable",
618 ServerArg.func ServerArg.string (fun o s -> { o with dt1 = opt_time s }),
619 "<int>|\"inf\"", (sprintf "Long cookie variable expire time seconds (default:%s)"
620 (string_of_opt_time default_options.dt1));
621
622 p"long-cookie-expire-fixed",
623 ServerArg.func ServerArg.string (fun o s -> { o with dt2 = opt_time s }),
624 "<int>|\"inf\"", (sprintf "Long cookie fixed expire time seconds (default:%s)"
625 (string_of_opt_time default_options.dt2));
626
627 p"max-external-cookies",
628 ServerArg.func ServerArg.int (fun o i -> { o with max_external_cookies = i }),
629 "<int>", (sprintf "Maximum number of concurrent external cookies per internal cookie (default:%d)"
630 default_options.max_external_cookies);
631
632 p"no-rotate-cookies",
633 ServerArg.func ServerArg.unit (fun o () -> { o with rotate_cookies = false }),
634 "", (sprintf "Switch off cookie rotation" (*default_options.rotate_cookies*));
635
636 p"server-send-buffer-size",
637 ServerArg.func ServerArg.int (fun o i -> { o with server_send_buffer_size = i }),
638 "<int>", (sprintf "Server send buffer size (default: %d)" default_options.server_send_buffer_size);
639
640 p"cookie-gc-period",
641 ServerArg.func ServerArg.int (fun o i -> { o with cookie_gc_period = i }),
642 "<int>", (sprintf "Cookie GC period in requests (default: %d)" default_options.cookie_gc_period);
643
644 p"cookie-pool-size-min",
645 ServerArg.func ServerArg.int (fun o i -> { o with cookie_pool_size_min = i }),
646 "<int>", (sprintf "Cookie pool size minimum (default: %d)" default_options.cookie_pool_size_min);
647
648 p"cookie-pool-size-max",
649 ServerArg.func ServerArg.int (fun o i -> { o with cookie_pool_size_max = i }),
650 "<int>", (sprintf "Cookie pool size maximum (default: %d)" default_options.cookie_pool_size_max);
651
652 p"cookie-timer-interval",
653 ServerArg.func ServerArg.int (fun o i -> { o with cookie_timer_interval = i }),
654 "<int>", (sprintf "Cookie timer interval (seconds) (default: %d)" default_options.cookie_timer_interval);
655
656 p"cookie-rate-max",
657 ServerArg.func ServerArg.float (fun o f -> { o with cookie_rate_max = f }),
658 "<float>", (sprintf "Cookie connection rate max (default: %3.1f)" default_options.cookie_rate_max);
659
660 p"cookie-period-max",
661 ServerArg.func ServerArg.int (fun o i -> { o with cookie_period_max = i }),
662 "<int>", (sprintf "Cookie rotation period above max rate (default: %d)" default_options.cookie_period_max);
663
664 p"cookie-rate-ultimate",
665 ServerArg.func ServerArg.float (fun o f -> { o with cookie_rate_ultimate = f }),
666 "<float>", (sprintf "Cookie connection rate ultimate (default: %3.1f)" default_options.cookie_rate_ultimate);
667
668 p"cookie-period-ultimate",
669 ServerArg.func ServerArg.int (fun o i -> { o with cookie_period_ultimate = i }),
670 "<int>", (sprintf "Cookie rotation period above ultimate rate (default: %d)" default_options.cookie_period_ultimate);
671
672 p"cookies-filename",
673 ServerArg.func ServerArg.string (fun o s -> { o with cookies_filename = s }),
674 "<filename>", (sprintf "Cookies filename (empty=disabled) (default: %s)" default_options.cookies_filename);
675
676 p"wait-for-request-timeout",
677 ServerArg.func ServerArg.float (fun o f -> { o with server_wait_for_request_timeout = Time.seconds_float f }),
678 "<float>", (sprintf "Timeout while waiting for requests (default: %4.1f)"
679 (Time.in_seconds default_options.server_wait_for_request_timeout));
680
681 p"wait-for-request-initial-timeout",
682 ServerArg.func ServerArg.float (fun o f -> { o with server_wait_for_request_initial_timeout = Time.seconds_float f }),
683 "<float>", (sprintf "Initial timeout while waiting for requests (default: %4.1f)"
684 (Time.in_seconds default_options.server_wait_for_request_initial_timeout));
685
686 p"write-timeout",
687 ServerArg.func ServerArg.float (fun o f -> { o with server_write_timeout = Time.seconds_float f }),
688 "<float>", (sprintf "Timeout while writing data (default: %6.1f)" (Time.in_seconds default_options.server_write_timeout));
689
690 (*(p"max-connections")@["-C"],
691 ServerArg.func ServerArg.int (fun o i -> { o with maximum_number_of_connections = i }),
692 "<int>", "Maximum number of active server connections (default: 100)";*)
693
694 p"maximum-content-length",
695 ServerArg.func ServerArg.int (fun o i -> { o with maximum_content_length = i }),
696 "<int>", (sprintf "Maximum request content length (default: %d)" default_options.maximum_content_length);
697
698 p"maximum-number-of-headers",
699 ServerArg.func ServerArg.int (fun o i -> { o with maximum_number_of_headers = i }),
700 "<int>", (sprintf "Maximum number of request headers (default: %d)" default_options.maximum_number_of_headers);
701
702 p"favicon-ico",
703 ServerArg.func ServerArg.string (fun o s -> { o with favicon_ico = body_value_from_file ~log:true s }),
704 "<string>", (sprintf "Favicon.ico file (default: %s)" (bv_file default_options.favicon_ico));
705
706 p"favicon-gif",
707 ServerArg.func ServerArg.string (fun o s -> { o with favicon_gif = body_value_from_file ~log:true s }),
708 "<string>", (sprintf "Favicon.gif file (default: %s)" (bv_file default_options.favicon_gif));
709
710 p"no-print-log-info",
711 ServerArg.func ServerArg.unit (fun o () -> { o with print_log_info = false }),
712 "", (sprintf "Disable access and error logs" (*default_options.print_log_info*));
713
714 p"no-print-server-info",
715 ServerArg.func ServerArg.unit (fun o () -> { o with print_server_info = false }),
716 "", (sprintf "Disable server information printout" (*default_options.print_server_info*));
717
718 p"no-flood-prevention",
719 ServerArg.func ServerArg.unit (fun o () -> { o with dos_prevention = false }),
720 "", (sprintf "Disable the built-in protection against Denial-of-Service attacks" (*default_options.dos_prevention*));
721
722 p"no-backtrace",
723 ServerArg.func ServerArg.unit (fun o () -> { o with backtrace = false }),
724 "", (sprintf "Disable backtrace printout for server exceptions" (*default_options.backtrace*));
725
726 p"no-drop-privilege",
727 ServerArg.func ServerArg.unit (fun o () -> { o with drop_privilege = false }),
728 "", (sprintf "Disable the drop of privilege on server start" (*default_options.drop_privilege*));
729
730 p"ssl-cert",
731 ServerArg.func ServerArg.string (fun o s -> { o with ssl_cert = s }),
732 "<file>", (sprintf "Location of your SSL certificate (requires ssl-key) (default:'%s')" default_options.ssl_cert);
733
734 p"ssl-key",
735 ServerArg.func ServerArg.string (fun o s -> { o with ssl_key = s }),
736 "<file>", (sprintf "Location of your SSL key (requires ssl-cert) (default:'%s')" default_options.ssl_key);
737
738 p"ssl-pass",
739 ServerArg.func ServerArg.string (fun o s -> { o with ssl_pass = s }),
740 "<string>", (sprintf "Password of your SSL certificate (requires ssl-cert and ssl-key options) (default:'%s')"
741 default_options.ssl_pass);
742
743 p"dialog",
744 ServerArg.func ServerArg.string (fun o s -> { o with dialog = s }),
745 "<string>", (sprintf "Name of the http dialog to use (default:'%s') "
746 default_options.dialog);
747
748 p"pidfile",
749 ServerArg.func ServerArg.string (fun o s -> { o with pid_file = Some s }),
750 "<string>", "File to dump server's pid. Server exits on error."
751
752 ]
753
754 (* From httpServerOptions *)
755 let make_ssl_cert opt =
756 if opt.ssl_cert <> "" then
757 if opt.ssl_key <> "" then
758 Some (SslAS.make_ssl_certificate opt.ssl_cert opt.ssl_key opt.ssl_pass)
759 else begin
760 Logger.critical "Error : ssl-cert option MUST be used with ssl-key option";
761 exit 1
762 end
763 else
764 None
765
766 let make_ssl_verify opt =
767 if opt.ssl_ca_file <> "" || opt.ssl_ca_path <> "" || opt.ssl_client_cert_path <> "" then
768 Some (SslAS.make_ssl_verify_params ~client_ca_file:opt.ssl_client_ca_file
769 ~accept_fun:opt.ssl_accept_fun ~always:opt.ssl_always
770 opt.ssl_ca_file opt.ssl_ca_path opt.ssl_client_cert_path)
771 else
772 None
773
774 let init_server opt runtime server_info =
775 if opt.print_log_info then HSCm.init_logger ();
776 if opt.print_server_info then HSCm.banner runtime server_info
777
778 let options = ((Hashtbl.create 4):(string,options) Hashtbl.t)
779 let () = Hashtbl.add options "default" default_options
780
781 let get_options ?(name="default") () = Hashtbl.find options name
782
783 let make (name:string) (opt:options) (sched:Scheduler.t) : t =
784 #<If>Logger.debug "HttpServer.make: name=%s addr=%s port=%d ssl_cert=%s" name opt.addr opt.port opt.ssl_cert#<End>;
785 let _ = Lazy.force m2 in
786 Hashtbl.add options name opt;
787 (*if opt.drop_privilege then Systools.change_user ();*)
788 let secure_mode = Network.secure_mode_from_params (make_ssl_cert opt) (make_ssl_verify opt) in
789 let addr = Unix.inet_addr_of_string opt.addr in
790 let server_info = HSCm.make_server_info addr opt.port (opt.ssl_cert <> "") in
791 let is_secure = match secure_mode with Network.Secured _ -> true | _ -> false in
792 let tm = Time.now () in
793 let lc = Time.localtime tm in
794 let hr = handle_request ~cachetype:opt.cachetype ~is_secure server_info tm lc in
795 HSCm.set_allowed_hosts opt.allowed_hosts;
796 HSCm.use_long_cookies := opt.long_cookies;
797 (if !HSCm.use_long_cookies then CookieLong.init_cookies else Cookie2.init_cookies)
798 ~sched ~gc_period:opt.cookie_gc_period
799 ~pool_min:opt.cookie_pool_size_min
800 ~pool_max:opt.cookie_pool_size_max
801 ~timer_interval:opt.cookie_timer_interval
802 ~rate_max:opt.cookie_rate_max
803 ~period_max:opt.cookie_period_max
804 ~rate_ultimate:opt.cookie_rate_ultimate
805 ~period_ultimate:opt.cookie_period_ultimate
806 ~expires_short:opt.cookie_expire_time_short
807 ~expires_long:opt.cookie_expire_time_long
808 ~dt1:opt.dt1
809 ~dt2:opt.dt2
810 ~max_external_cookies:opt.max_external_cookies
811 ~rotate_cookies:opt.rotate_cookies
812 ~cookies_filename:opt.cookies_filename
813 ();
814 let log_accesses = ref true in
815 #<If:NO_ACCESS_LOG> log_accesses := false #<End>;
816 let gm = Time.gmtime tm in
817 let diff = lc.Unix.tm_hour - gm.Unix.tm_hour in
818 let sign = if diff > 0 then "+" else if diff < 0 then "-" else "" in
819 HST.time_diff := sprintf "%s%02d00" sign diff;
820 let runtime = {
821 HSC.rt_get = opt.get;
822 rt_post = opt.post;
823 rt_core =
824 { HSC.rt_pre_headers = opt.pre_headers;
825 rt_post_headers = opt.post_headers;
826 rt_server_send_buffer_size = opt.server_send_buffer_size;
827 rt_server_wait_for_request_timeout = opt.server_wait_for_request_timeout;
828 rt_server_wait_for_request_initial_timeout = opt.server_wait_for_request_initial_timeout;
829 rt_maximum_number_of_connections = opt.maximum_number_of_connections;
830 rt_maximum_content_length = opt.maximum_content_length;
831 rt_maximum_number_of_headers = opt.maximum_number_of_headers;
832 rt_log_accesses = (!log_accesses);
833 rt_time_diff = !(HST.time_diff);
834 rt_plim = 128;
835 };
836 rt_server =
837 { HSC.rt_dialog_content = Obj.magic None;
838 rt_dialog_name = opt.dialog;
839 rt_server_name = name;
840 rt_on_run = opt.on_server_run opt;
841 rt_on_close = opt.on_server_close;
842 rt_favicon_ico = opt.favicon_ico;
843 rt_favicon_gif = opt.favicon_gif;
844 };
845 rt_proto =
846 { HSC.rt_name = opt.name;
847 rt_addr = opt.addr;
848 rt_port = opt.port;
849 rt_secure_mode = secure_mode;
850 rt_block_size = opt.block_size;
851 rt_backtrace = opt.backtrace;
852 rt_server_write_timeout = opt.server_write_timeout;
853 rt_payload = HSC.null_payload;
854 };
855 rt_tmp =
856 { HSC.rt_hr = hr;
857 rt_conn = 0;
858 rt_callback = opt.callback;
859 };
860 } in
861 init_server opt runtime server_info;
862 let () = (
863 match opt.pid_file with
864 | None -> ()
865 | Some f -> (
866 try begin
867 let ochan = open_out f in
868 let () = output_string ochan (sprintf "%d" (Unix.getpid())) in
869 let () = close_out ochan in
870 at_exit (fun () ->
871 try Unix.unlink f
872 with Unix.Unix_error (Unix.ENOENT, _, s2) ->
873 Logger.critical "HttpServer.make: couldn't delete pid file '%s'\n" s2
874 )
875 end with Sys_error e ->
876 let () = Logger.critical "HttpServer.make:'%s'\n" e in exit 1
877 )
878 ) in
879 { HSC.runtime = runtime; HSC.err_cont = None; HSC.extra_params = hr; }
880
881 let get_ports (server:t) (sched:Scheduler.t) =
882 (HSC.get_ports server sched)
883 @[(server.HSC.runtime.HSC.rt_server.HSC.rt_dialog_name,
884 `HttpDialog { HttpDialog.set_dialog = fun dialog -> server.HSC.runtime.HSC.rt_server.HSC.rt_dialog_content <- dialog })]
885
886 let get_description _http_server _sched = `HttpServer
887
888 let run http_server sched = http_server.HSC.runtime.HSC.rt_server.HSC.rt_on_run sched; http_server
889
890 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.