Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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