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