Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 982 lines (850 sloc) 43.571 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
68b7e50 @nrs135 [feature] libnet: Added PUT and DELETE methods to HttpServer.
nrs135 authored
453 let handle_put sched runtime _method hr (uri, headers, body) conn k =
454 #<If>Logger.debug "handle_put: uri=%s" uri#<End>;
455 let req = { HST.request_scheduler=sched;
456 HST.request_line = { HST._method = _method ; request_uri = uri ; http_version = HSC.http_version_number };
457 request_header = headers; request_message_body = body; request_post_body = [];
458 server_info = hr.HST.hr_server_info; is_multipart = false; handle_request = hr} in
459 (HD.body runtime.HSC.rt_server.HSC.rt_dialog_content sched) { HST.cont=k; request=req; connection=conn; certificate=None }
460
461 let handle_delete sched runtime _method hr (uri, headers) conn k =
462 #<If>Logger.debug "handle_delete: uri=%s" uri#<End>;
463 HSCm.check_host headers;
464 let req = { HST.request_scheduler=sched;
465 HST.request_line = { HST._method=_method; request_uri=uri; http_version=HSC.http_version_number };
466 request_header = headers; request_message_body = Rc.ContentNone; request_post_body = [];
467 server_info = hr.HST.hr_server_info; is_multipart = false; handle_request = hr } in
468 (HD.body runtime.HSC.rt_server.HSC.rt_dialog_content sched) { HST.cont=k; request=req; connection=conn; certificate=None }
469
fccc685 Initial open-source release
MLstate authored
470 let handle_request ?(cachetype="public") ?(is_secure=false) server_info tm lc =
471 { HST.hr_delcookies = false;
472 hr_cachetype = cachetype;
473 hr_server_info = server_info;
474 hr_is_secure = is_secure;
475 hr_timestamp = tm;
476 hr_timestamp_tm = lc;
477 hr_inet_addr_str = "";
478 hr_user_agent = "";
479 hr_referer = "";
480 hr_ec = "";
481 hr_ic = "";
482 hr_dt2 = Time.zero;
483 }
484
485 (* Runtime layer *)
486
487 let name = "httpServer"
488 let version = "1.0"
489
490 type t = HSC.t
491
492 type options =
493 { ssl_cert : string;
494 ssl_key : string;
495 ssl_pass : string;
496 ssl_accept_fun : Ssl.certificate -> bool;
497 ssl_always : bool;
498 ssl_ca_file : string;
499 ssl_ca_path : string;
500 ssl_client_ca_file : string;
501 ssl_client_cert_path : string;
97e3f73 [feature] stdlib: missing ssl param for server
Hugo Heuzard authored
502 ssl_certificate : SslAS.ssl_certificate option;
503 ssl_verify_params : SslAS.ssl_verify_params option;
fccc685 Initial open-source release
MLstate authored
504 pid_file : string option;
505 dialog : string;
506 request_size_max : int;
507 print_log_info : bool;
508 print_server_info : bool;
509 timeout : float;
510 long_cookies : bool;
511 cookie_expire_time_short : Time.t;
512 cookie_expire_time_long : Time.t;
513 dt1 : Time.t;
514 dt2 : Time.t;
515 max_external_cookies : int;
516 rotate_cookies : bool;
517 cachetype : string;
518 server_send_buffer_size: int;
519 cookie_gc_period: int;
b429b69 @cedricss [feature] Http server: new option to accept client cookie values
cedricss authored
520 cookie_accept_client_values: bool;
fccc685 Initial open-source release
MLstate authored
521 cookie_pool_size_min: int;
522 cookie_pool_size_max: int;
523 cookie_timer_interval: int;
524 cookie_rate_max: float;
525 cookie_period_max: int;
526 cookie_rate_ultimate: float;
527 cookie_period_ultimate: int;
528 cookies_filename: string;
529 server_wait_for_request_timeout: Time.t;
530 server_wait_for_request_initial_timeout: Time.t;
531 server_write_timeout: Time.t;
532 maximum_number_of_connections: int;
533 maximum_content_length: int;
534 maximum_number_of_headers: int;
3062e57 @cedricss [feature] HttpServer and RemoteLog: push logs to a remote log server (ex...
cedricss authored
535 remote_logs: HST.remote_logs option;
fccc685 Initial open-source release
MLstate authored
536 favicon_ico: HSC.body_value;
537 favicon_gif: HSC.body_value;
538 backtrace: bool;
539 name : string;
540 addr : string;
541 port : int;
542 block_size : int;
543 allowed_hosts : string list;
544 dos_prevention : bool;
545 on_server_run : options -> Scheduler.t -> unit;
546 on_server_close : Scheduler.t -> unit;
547 get : Scheduler.t -> HSC.runtime -> HSCp.msg -> HST.handle_request -> HST.get
548 -> Scheduler.connection_info -> (HST.response -> unit) -> unit;
549 post : Scheduler.t -> HSC.runtime -> HSCp.msg -> HST.handle_request -> HST.post
550 -> Scheduler.connection_info -> (HST.response -> unit) -> unit;
68b7e50 @nrs135 [feature] libnet: Added PUT and DELETE methods to HttpServer.
nrs135 authored
551 put : Scheduler.t -> HSC.runtime -> HSCp.msg -> HST.handle_request -> HST.put
552 -> Scheduler.connection_info -> (HST.response -> unit) -> unit;
553 delete : Scheduler.t -> HSC.runtime -> HSCp.msg -> HST.handle_request -> HST.delete
554 -> Scheduler.connection_info -> (HST.response -> unit) -> unit;
fccc685 Initial open-source release
MLstate authored
555 pre_headers : HST.handle_request -> HSCp.msg -> HST.header list -> (HST.handle_request * HST.header list);
556 post_headers : HST.handle_request -> HSCp.msg -> HST.header list -> HST.header list
557 -> (HST.handle_request * HST.header list * bool);
558 callback : (HSC.payload -> int -> Buffer.t -> bool) option;
559 }
560
561 let null_callback (_str,_hdrs) _i _buf = (*Logger.debug "null_callback(%s): i=%d" str i;*) true
562
563 let null_body_value = (("<no file>", Rc.ContentNone, Time.zero, "unknown/unknown"):HSC.body_value)
564
565 let body_value_from_file ?(log=false) file : HSC.body_value =
566 try
567 let stat = Unix.stat file in
568 let content =
569 if stat.Unix.st_size > (1024*1024)
570 then Rc.ContentFile (file,None,None,Some stat,false)
571 else Rc.ContentString (File.content file) in
572 let modified_time = Time.of_unix_time stat.Unix.st_mtime in
573 let mime_type_string = mime_type file in
574 if log then Logger.info "Loaded file: %s" file;
575 file, content, modified_time, mime_type_string
576 with Unix.Unix_error _ -> null_body_value
577
578 let body_value_from_home ?log file =
579 try body_value_from_file ?log (Filename.concat (Lazy.force File.mlstate_dir) file)
580 with Not_found -> null_body_value
581
582 let bv_file (file,_,_,_) = file
583
584 let default_options =
585 { ssl_cert = "";
586 ssl_key = "";
587 ssl_pass = "";
588 ssl_accept_fun = (fun _ -> true);
589 ssl_always = false;
590 ssl_ca_file = "";
591 ssl_ca_path = "";
592 ssl_client_ca_file = "";
593 ssl_client_cert_path = "";
97e3f73 [feature] stdlib: missing ssl param for server
Hugo Heuzard authored
594 ssl_certificate = None;
595 ssl_verify_params = None;
fccc685 Initial open-source release
MLstate authored
596 pid_file = None;
597 dialog = "default";
598 request_size_max = 10*1024*1024;
599 print_log_info = true;
600 print_server_info = true;
601 timeout = 36.;
602 long_cookies = true;
603 cookie_expire_time_short = Time.seconds 5;
604 cookie_expire_time_long = Time.seconds 50;
605 dt1 = Time.days 10;
606 dt2 = Time.infinity;
607 max_external_cookies = 10;
608 rotate_cookies = true;
609 cachetype = "public";
610 server_send_buffer_size = 1024;
611 cookie_gc_period = 100;
b429b69 @cedricss [feature] Http server: new option to accept client cookie values
cedricss authored
612 cookie_accept_client_values = false;
fccc685 Initial open-source release
MLstate authored
613 cookie_pool_size_min = 100;
614 cookie_pool_size_max = 10000;
615 cookie_timer_interval = 1;
616 cookie_rate_max = 5.0;
617 cookie_period_max = 5;
618 cookie_rate_ultimate = 10.0;
619 cookie_period_ultimate = 100;
620 cookies_filename = ""(*(Lazy.force File.mlstate_dir)^"/cookies.txt"*);
621 server_wait_for_request_timeout = Time.seconds 36;
622 server_wait_for_request_initial_timeout = Time.seconds 36;
623 server_write_timeout = Time.hours 1;
624 maximum_number_of_connections = max_int;
625 maximum_content_length = (50*1024*1024);
626 maximum_number_of_headers = 200;
3062e57 @cedricss [feature] HttpServer and RemoteLog: push logs to a remote log server (ex...
cedricss authored
627 remote_logs = None;
fccc685 Initial open-source release
MLstate authored
628 favicon_ico = null_body_value (*(body_value_from_home ~log:true ".favicon.ico")*);
629 favicon_gif = null_body_value (*(body_value_from_home ~log:true ".favicon.gif")*);
630 backtrace = true;
631 name = "httpServerPort";
632 addr = "0.0.0.0";
633 port = 8080;
634 block_size = 4096; (* TODO: implement separate callbac blocksize *)
635 allowed_hosts = [];
636 dos_prevention = true;
637 on_server_run = (fun _ _ -> ());
638 on_server_close = (fun _ -> ());
639 get = handle_get;
640 post = handle_post;
68b7e50 @nrs135 [feature] libnet: Added PUT and DELETE methods to HttpServer.
nrs135 authored
641 put = handle_put;
642 delete = handle_delete;
fccc685 Initial open-source release
MLstate authored
643 pre_headers = pre_headers;
644 post_headers = post_headers;
645 callback = Some null_callback;
646 }
647
648 let prefixed_opt name opt =
649 if name = "" then
650 [sprintf "--%s" opt]
651 else
652 [sprintf "--%s-%s" name opt; sprintf "--%s" opt]
653
654 let opt_time = function
655 | "inf" | "INF" | "Inf" | "infinity" | "Infinity" | "INFINITY" | "none" | "None" | "NONE" -> Time.infinity
656 | s ->
657 try Time.seconds (int_of_string s)
658 with | Failure "int_of_string" -> failwith ("Argument '"^s^"' not valid time (<int> | \"inf\")")
659
660 let string_of_opt_time t = if t = Time.infinity then "inf" else sprintf "%7.0f" (Time.in_seconds t)
661
662 let spec_args name =
663 let p = prefixed_opt name in
664 [
665 (p"addr")@["-a"],
666 ServerArg.func ServerArg.string
667 (fun o a ->
668 ((try ignore (Unix.inet_addr_of_string a) with Failure _ -> (Logger.critical "Bad address: %s" a; exit 1));
669 { o with addr = a })),
670 "<string>", (sprintf "Sets the IP address on which the server should run (default:%s)"
671 default_options.addr);
672
673 (p"port")@["-p"],
674 ServerArg.func ServerArg.int
675 (fun o p -> if p > 0xffff then (Logger.critical "Bad port number: %d" p; exit 1) else { o with port = p }),
676 "<int>", (sprintf "Sets the port on which the server should run (default:%d)" default_options.port);
677
678 p"long-cookies",
679 ServerArg.func ServerArg.bool (fun o b -> { o with long_cookies = b }),
680 "<bool>", (sprintf "Use long cookies (default:%b)" default_options.long_cookies);
681
682 p"cookie-expire-short",
683 ServerArg.func ServerArg.int (fun o i -> { o with cookie_expire_time_short = Time.seconds i }),
684 "<int>", (sprintf "Cookie expire time (short) seconds (default:%1.0f)"
685 (Time.in_seconds default_options.cookie_expire_time_short));
686
687 p"cookie-expire-long",
688 ServerArg.func ServerArg.int (fun o i -> { o with cookie_expire_time_long = Time.seconds i }),
689 "<int>", (sprintf "Cookie expire time (long) seconds (default:%2.0f)"
690 (Time.in_seconds default_options.cookie_expire_time_long));
691
692 p"long-cookie-expire-variable",
693 ServerArg.func ServerArg.string (fun o s -> { o with dt1 = opt_time s }),
694 "<int>|\"inf\"", (sprintf "Long cookie variable expire time seconds (default:%s)"
695 (string_of_opt_time default_options.dt1));
696
697 p"long-cookie-expire-fixed",
698 ServerArg.func ServerArg.string (fun o s -> { o with dt2 = opt_time s }),
699 "<int>|\"inf\"", (sprintf "Long cookie fixed expire time seconds (default:%s)"
700 (string_of_opt_time default_options.dt2));
701
702 p"max-external-cookies",
703 ServerArg.func ServerArg.int (fun o i -> { o with max_external_cookies = i }),
704 "<int>", (sprintf "Maximum number of concurrent external cookies per internal cookie (default:%d)"
705 default_options.max_external_cookies);
706
707 p"no-rotate-cookies",
708 ServerArg.func ServerArg.unit (fun o () -> { o with rotate_cookies = false }),
709 "", (sprintf "Switch off cookie rotation" (*default_options.rotate_cookies*));
710
711 p"server-send-buffer-size",
712 ServerArg.func ServerArg.int (fun o i -> { o with server_send_buffer_size = i }),
713 "<int>", (sprintf "Server send buffer size (default: %d)" default_options.server_send_buffer_size);
714
715 p"cookie-gc-period",
716 ServerArg.func ServerArg.int (fun o i -> { o with cookie_gc_period = i }),
717 "<int>", (sprintf "Cookie GC period in requests (default: %d)" default_options.cookie_gc_period);
718
b429b69 @cedricss [feature] Http server: new option to accept client cookie values
cedricss authored
719 p"cookie-accept-client-values",
720 ServerArg.func ServerArg.unit (fun o () -> { o with cookie_accept_client_values = true }),
721 "", (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);
722
fccc685 Initial open-source release
MLstate authored
723 p"cookie-pool-size-min",
724 ServerArg.func ServerArg.int (fun o i -> { o with cookie_pool_size_min = i }),
725 "<int>", (sprintf "Cookie pool size minimum (default: %d)" default_options.cookie_pool_size_min);
726
727 p"cookie-pool-size-max",
728 ServerArg.func ServerArg.int (fun o i -> { o with cookie_pool_size_max = i }),
729 "<int>", (sprintf "Cookie pool size maximum (default: %d)" default_options.cookie_pool_size_max);
730
731 p"cookie-timer-interval",
732 ServerArg.func ServerArg.int (fun o i -> { o with cookie_timer_interval = i }),
733 "<int>", (sprintf "Cookie timer interval (seconds) (default: %d)" default_options.cookie_timer_interval);
734
735 p"cookie-rate-max",
736 ServerArg.func ServerArg.float (fun o f -> { o with cookie_rate_max = f }),
737 "<float>", (sprintf "Cookie connection rate max (default: %3.1f)" default_options.cookie_rate_max);
738
739 p"cookie-period-max",
740 ServerArg.func ServerArg.int (fun o i -> { o with cookie_period_max = i }),
741 "<int>", (sprintf "Cookie rotation period above max rate (default: %d)" default_options.cookie_period_max);
742
743 p"cookie-rate-ultimate",
744 ServerArg.func ServerArg.float (fun o f -> { o with cookie_rate_ultimate = f }),
745 "<float>", (sprintf "Cookie connection rate ultimate (default: %3.1f)" default_options.cookie_rate_ultimate);
746
747 p"cookie-period-ultimate",
748 ServerArg.func ServerArg.int (fun o i -> { o with cookie_period_ultimate = i }),
749 "<int>", (sprintf "Cookie rotation period above ultimate rate (default: %d)" default_options.cookie_period_ultimate);
750
751 p"cookies-filename",
752 ServerArg.func ServerArg.string (fun o s -> { o with cookies_filename = s }),
753 "<filename>", (sprintf "Cookies filename (empty=disabled) (default: %s)" default_options.cookies_filename);
754
755 p"wait-for-request-timeout",
756 ServerArg.func ServerArg.float (fun o f -> { o with server_wait_for_request_timeout = Time.seconds_float f }),
757 "<float>", (sprintf "Timeout while waiting for requests (default: %4.1f)"
758 (Time.in_seconds default_options.server_wait_for_request_timeout));
759
760 p"wait-for-request-initial-timeout",
761 ServerArg.func ServerArg.float (fun o f -> { o with server_wait_for_request_initial_timeout = Time.seconds_float f }),
762 "<float>", (sprintf "Initial timeout while waiting for requests (default: %4.1f)"
763 (Time.in_seconds default_options.server_wait_for_request_initial_timeout));
764
765 p"write-timeout",
766 ServerArg.func ServerArg.float (fun o f -> { o with server_write_timeout = Time.seconds_float f }),
767 "<float>", (sprintf "Timeout while writing data (default: %6.1f)" (Time.in_seconds default_options.server_write_timeout));
768
3062e57 @cedricss [feature] HttpServer and RemoteLog: push logs to a remote log server (ex...
cedricss authored
769 p"remote-logs",
770 ServerArg.func ServerArg.string (fun o s ->
771 try
772 let (hostname,port_appkey) = Base.String.split_char ':' s in
773 let (port,appkey) = Base.String.split_char '/' port_appkey in
774 let port = int_of_string port in
775 let remote_logs = Some {HST.hostname=hostname; HST.port=port; HST.appkey=appkey} in
776 remote_logs_params := remote_logs;
777 {o with remote_logs = remote_logs}
778 with
779 | Not_found -> let _ = prerr_endline ("Bad option \""^s^"\" for --remote-logs") in o
780 | Failure s -> let _ = prerr_endline ("Invalid port for --remote-logs."^s) in o
781 ),
782 "<hostname:port/appkey>", "Log access to a remote server (WARNING: this is experimental) (default: no log server).";
783
fccc685 Initial open-source release
MLstate authored
784 (*(p"max-connections")@["-C"],
785 ServerArg.func ServerArg.int (fun o i -> { o with maximum_number_of_connections = i }),
786 "<int>", "Maximum number of active server connections (default: 100)";*)
787
788 p"maximum-content-length",
789 ServerArg.func ServerArg.int (fun o i -> { o with maximum_content_length = i }),
790 "<int>", (sprintf "Maximum request content length (default: %d)" default_options.maximum_content_length);
791
792 p"maximum-number-of-headers",
793 ServerArg.func ServerArg.int (fun o i -> { o with maximum_number_of_headers = i }),
794 "<int>", (sprintf "Maximum number of request headers (default: %d)" default_options.maximum_number_of_headers);
795
796 p"no-print-log-info",
797 ServerArg.func ServerArg.unit (fun o () -> { o with print_log_info = false }),
798 "", (sprintf "Disable access and error logs" (*default_options.print_log_info*));
799
800 p"no-print-server-info",
801 ServerArg.func ServerArg.unit (fun o () -> { o with print_server_info = false }),
802 "", (sprintf "Disable server information printout" (*default_options.print_server_info*));
803
804 p"no-flood-prevention",
805 ServerArg.func ServerArg.unit (fun o () -> { o with dos_prevention = false }),
806 "", (sprintf "Disable the built-in protection against Denial-of-Service attacks" (*default_options.dos_prevention*));
807
808 p"no-backtrace",
809 ServerArg.func ServerArg.unit (fun o () -> { o with backtrace = false }),
810 "", (sprintf "Disable backtrace printout for server exceptions" (*default_options.backtrace*));
811
812 p"ssl-cert",
813 ServerArg.func ServerArg.string (fun o s -> { o with ssl_cert = s }),
814 "<file>", (sprintf "Location of your SSL certificate (requires ssl-key) (default:'%s')" default_options.ssl_cert);
815
816 p"ssl-key",
817 ServerArg.func ServerArg.string (fun o s -> { o with ssl_key = s }),
818 "<file>", (sprintf "Location of your SSL key (requires ssl-cert) (default:'%s')" default_options.ssl_key);
819
820 p"ssl-pass",
821 ServerArg.func ServerArg.string (fun o s -> { o with ssl_pass = s }),
822 "<string>", (sprintf "Password of your SSL certificate (requires ssl-cert and ssl-key options) (default:'%s')"
823 default_options.ssl_pass);
824
825 p"dialog",
826 ServerArg.func ServerArg.string (fun o s -> { o with dialog = s }),
827 "<string>", (sprintf "Name of the http dialog to use (default:'%s') "
828 default_options.dialog);
829
830 p"pidfile",
831 ServerArg.func ServerArg.string (fun o s -> { o with pid_file = Some s }),
832 "<string>", "File to dump server's pid. Server exits on error."
833
834 ]
835
836 (* From httpServerOptions *)
837 let make_ssl_cert opt =
97e3f73 [feature] stdlib: missing ssl param for server
Hugo Heuzard authored
838 match opt.ssl_certificate with
839 | Some x -> Some x
840 | None ->
841 if opt.ssl_cert <> "" then
842 if opt.ssl_key <> "" then
843 Some (SslAS.make_ssl_certificate opt.ssl_cert opt.ssl_key opt.ssl_pass)
844 else begin
845 Logger.critical "Error : ssl-cert option MUST be used with ssl-key option";
846 exit 1
847 end
848 else
849 None
fccc685 Initial open-source release
MLstate authored
850
851 let make_ssl_verify opt =
97e3f73 [feature] stdlib: missing ssl param for server
Hugo Heuzard authored
852 match opt.ssl_verify_params with
853 | Some x -> Some x
854 | None ->
855 if opt.ssl_ca_file <> "" || opt.ssl_ca_path <> "" || opt.ssl_client_cert_path <> "" then
856 Some (SslAS.make_ssl_verify_params ~client_ca_file:opt.ssl_client_ca_file
857 ~accept_fun:opt.ssl_accept_fun ~always:opt.ssl_always
858 opt.ssl_ca_file opt.ssl_ca_path opt.ssl_client_cert_path)
859 else
860 None
fccc685 Initial open-source release
MLstate authored
861
862 let init_server opt runtime server_info =
863 if opt.print_log_info then HSCm.init_logger ();
864 if opt.print_server_info then HSCm.banner runtime server_info
865
866 let options = ((Hashtbl.create 4):(string,options) Hashtbl.t)
867 let () = Hashtbl.add options "default" default_options
868
869 let get_options ?(name="default") () = Hashtbl.find options name
870
871 let make (name:string) (opt:options) (sched:Scheduler.t) : t =
872 #<If>Logger.debug "HttpServer.make: name=%s addr=%s port=%d ssl_cert=%s" name opt.addr opt.port opt.ssl_cert#<End>;
873 let _ = Lazy.force m2 in
874 Hashtbl.add options name opt;
875 let secure_mode = Network.secure_mode_from_params (make_ssl_cert opt) (make_ssl_verify opt) in
876 let addr = Unix.inet_addr_of_string opt.addr in
877 let server_info = HSCm.make_server_info addr opt.port (opt.ssl_cert <> "") in
878 let is_secure = match secure_mode with Network.Secured _ -> true | _ -> false in
879 let tm = Time.now () in
880 let lc = Time.localtime tm in
881 let hr = handle_request ~cachetype:opt.cachetype ~is_secure server_info tm lc in
882 HSCm.set_allowed_hosts opt.allowed_hosts;
883 HSCm.use_long_cookies := opt.long_cookies;
884 (if !HSCm.use_long_cookies then CookieLong.init_cookies else Cookie2.init_cookies)
885 ~sched ~gc_period:opt.cookie_gc_period
b429b69 @cedricss [feature] Http server: new option to accept client cookie values
cedricss authored
886 ~accept_client_values:opt.cookie_accept_client_values
fccc685 Initial open-source release
MLstate authored
887 ~pool_min:opt.cookie_pool_size_min
888 ~pool_max:opt.cookie_pool_size_max
889 ~timer_interval:opt.cookie_timer_interval
890 ~rate_max:opt.cookie_rate_max
891 ~period_max:opt.cookie_period_max
892 ~rate_ultimate:opt.cookie_rate_ultimate
893 ~period_ultimate:opt.cookie_period_ultimate
894 ~expires_short:opt.cookie_expire_time_short
895 ~expires_long:opt.cookie_expire_time_long
896 ~dt1:opt.dt1
897 ~dt2:opt.dt2
898 ~max_external_cookies:opt.max_external_cookies
899 ~rotate_cookies:opt.rotate_cookies
900 ~cookies_filename:opt.cookies_filename
901 ();
902 let log_accesses = ref true in
903 #<If:NO_ACCESS_LOG> log_accesses := false #<End>;
904 let gm = Time.gmtime tm in
905 let diff = lc.Unix.tm_hour - gm.Unix.tm_hour in
906 let sign = if diff > 0 then "+" else if diff < 0 then "-" else "" in
907 HST.time_diff := sprintf "%s%02d00" sign diff;
908 let runtime = {
909 HSC.rt_get = opt.get;
910 rt_post = opt.post;
68b7e50 @nrs135 [feature] libnet: Added PUT and DELETE methods to HttpServer.
nrs135 authored
911 rt_put = opt.put;
912 rt_delete = opt.delete;
fccc685 Initial open-source release
MLstate authored
913 rt_core =
914 { HSC.rt_pre_headers = opt.pre_headers;
915 rt_post_headers = opt.post_headers;
916 rt_server_send_buffer_size = opt.server_send_buffer_size;
917 rt_server_wait_for_request_timeout = opt.server_wait_for_request_timeout;
918 rt_server_wait_for_request_initial_timeout = opt.server_wait_for_request_initial_timeout;
919 rt_maximum_number_of_connections = opt.maximum_number_of_connections;
920 rt_maximum_content_length = opt.maximum_content_length;
921 rt_maximum_number_of_headers = opt.maximum_number_of_headers;
922 rt_log_accesses = (!log_accesses);
3062e57 @cedricss [feature] HttpServer and RemoteLog: push logs to a remote log server (ex...
cedricss authored
923 rt_remote_logs = opt.remote_logs;
fccc685 Initial open-source release
MLstate authored
924 rt_time_diff = !(HST.time_diff);
925 rt_plim = 128;
926 };
927 rt_server =
928 { HSC.rt_dialog_content = Obj.magic None;
929 rt_dialog_name = opt.dialog;
930 rt_server_name = name;
931 rt_on_run = opt.on_server_run opt;
932 rt_on_close = opt.on_server_close;
933 rt_favicon_ico = opt.favicon_ico;
934 rt_favicon_gif = opt.favicon_gif;
935 };
936 rt_proto =
937 { HSC.rt_name = opt.name;
938 rt_addr = opt.addr;
939 rt_port = opt.port;
940 rt_secure_mode = secure_mode;
941 rt_block_size = opt.block_size;
942 rt_backtrace = opt.backtrace;
943 rt_server_write_timeout = opt.server_write_timeout;
944 rt_payload = HSC.null_payload;
945 };
946 rt_tmp =
947 { HSC.rt_hr = hr;
948 rt_conn = 0;
949 rt_callback = opt.callback;
950 };
951 } in
952 init_server opt runtime server_info;
953 let () = (
954 match opt.pid_file with
955 | None -> ()
956 | Some f -> (
957 try begin
958 let ochan = open_out f in
959 let () = output_string ochan (sprintf "%d" (Unix.getpid())) in
960 let () = close_out ochan in
961 at_exit (fun () ->
962 try Unix.unlink f
963 with Unix.Unix_error (Unix.ENOENT, _, s2) ->
964 Logger.critical "HttpServer.make: couldn't delete pid file '%s'\n" s2
965 )
966 end with Sys_error e ->
967 let () = Logger.critical "HttpServer.make:'%s'\n" e in exit 1
968 )
969 ) in
970 { HSC.runtime = runtime; HSC.err_cont = None; HSC.extra_params = hr; }
971
972 let get_ports (server:t) (sched:Scheduler.t) =
973 (HSC.get_ports server sched)
974 @[(server.HSC.runtime.HSC.rt_server.HSC.rt_dialog_name,
975 `HttpDialog { HttpDialog.set_dialog = fun dialog -> server.HSC.runtime.HSC.rt_server.HSC.rt_dialog_content <- dialog })]
976
977 let get_description _http_server _sched = `HttpServer
978
979 let run http_server sched = http_server.HSC.runtime.HSC.rt_server.HSC.rt_on_run sched; http_server
980
981 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.