server/ocsigen_server.ml

   1 (* Ocsigen
   2  * http://www.ocsigen.org
   3  * Module server.ml
   4  * Copyright (C) 2005
   5  * Vincent Balat, Denis Berthod, Nataliya Guts, Jérôme Vouillon
   6  * Laboratoire PPS - CNRS Université Paris Diderot
   7  *
   8  * This program is free software; you can redistribute it and/or modify
   9  * it under the terms of the GNU Lesser General Public License as published by
  10  * the Free Software Foundation, with linking exception;
  11  * either version 2.1 of the License, or (at your option) any later version.
  12  *
  13  * This program is distributed in the hope that it will be useful,
  14  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16  * GNU Lesser General Public License for more details.
  17  *
  18  * You should have received a copy of the GNU Lesser General Public License
  19  * along with this program; if not, write to the Free Software
  20  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  21  *)
  22
  23 open Lwt
  24 open Ocsigen_messages
  25 open Ocsigen_lib
  26 open Ocsigen_extensions
  27 open Ocsigen_http_frame
  28 open Ocsigen_headers
  29 open Ocsigen_http_com
  30 open Ocsigen_senders
  31 open Ocsigen_config
  32 open Ocsigen_parseconfig
  33 open Lazy
  34
  35
  36 exception Ocsigen_unsupported_media
  37 exception Ssl_Exception
  38 exception Ocsigen_upload_forbidden
  39 exception Socket_closed
  40
  41 let shutdown = ref false
  42
  43 let () = Random.self_init ()
  44
  45 (* Without the following line, it stops with "Broken Pipe" without raising
  46    an exception ... *)
  47 let _ = Sys.set_signal Sys.sigpipe Sys.Signal_ignore
  48
  49 (* Initialize exception handler for Lwt timeouts: *)
  50 let _ =
  51   Lwt_timeout.set_exn_handler
  52     (fun e -> Ocsigen_messages.errlog ("Uncaught Exception after lwt timeout: "^
  53                                  Ocsigen_lib.string_of_exn e))
  54
  55 external disable_nagle : Unix.file_descr -> unit = "disable_nagle"
  56 external initgroups : string -> int -> unit = "initgroups_stub"
  57
  58 let make_ipv6_socket addr port =
  59   let socket = Lwt_unix.socket Unix.PF_INET6 Unix.SOCK_STREAM 0 in
  60   Lwt_unix.set_close_on_exec socket;
  61   Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true;
  62   Lwt_unix.setsockopt socket Unix.IPV6_ONLY true;
  63   Lwt_unix.bind socket (Unix.ADDR_INET (addr, port));
  64   socket
  65
  66 let make_ipv4_socket addr port =
  67   let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
  68   Lwt_unix.set_close_on_exec socket;
  69   Lwt_unix.setsockopt socket Unix.SO_REUSEADDR true;
  70   Lwt_unix.bind socket (Unix.ADDR_INET (addr, port));
  71   socket
  72
  73 let make_sockets addr port =
  74   match addr with
  75     | All ->
  76         (* The user didn't specify a protocol in the configuration
  77            file; we try to open an IPv6 socket (listening to IPv6
  78            only) if possible and we open an IPv4 socket anyway. This
  79            corresponds to the net.ipv6.bindv6only=0 behaviour on Linux,
  80            but is portable and should work with
  81            net.ipv6.bindv6only=1 as well. *)
  82         let ipv6_socket =
  83           try [make_ipv6_socket Unix.inet6_addr_any port]
  84           with Unix.Unix_error
  85               ((Unix.EAFNOSUPPORT | Unix.EPROTONOSUPPORT),
  86                _, _) -> []
  87         in
  88         (make_ipv4_socket Unix.inet_addr_any port)::ipv6_socket
  89     | IPv4 addr ->
  90         [make_ipv4_socket addr port]
  91     | IPv6 addr ->
  92         [make_ipv6_socket addr port]
  93
  94 let sslctx = Ocsigen_http_client.sslcontext
  95
  96
  97 let ip_of_sockaddr = function
  98   | Unix.ADDR_INET (ip, port) -> ip
  99   | _ -> raise (Ocsigen_Internal_Error "ip of unix socket")
 100
 101 let port_of_sockaddr = function
 102   | Unix.ADDR_INET (ip, port) -> port
 103   | _ -> raise (Ocsigen_Internal_Error "port of unix socket")
 104
 105
 106 let get_boundary ctparams = List.assoc "boundary" ctparams
 107
 108 let find_field field content_disp =
 109   let (_, res) = Netstring_pcre.search_forward
 110       (Netstring_pcre.regexp (field^"=.([^\"]*).;?")) content_disp 0 in
 111   Netstring_pcre.matched_group res 1 content_disp
 112
 113 type to_write =
 114     No_File of string * Buffer.t
 115   | A_File of (string * string * string * Unix.file_descr * (string * string option) option)
 116
 117 let counter = let c = ref (Random.int 1000000) in fun () -> c := !c + 1 ; !c
 118
 119 let warn sockaddr s =
 120   let ip = Unix.string_of_inet_addr (ip_of_sockaddr sockaddr) in
 121   Ocsigen_messages.warning ("While talking to " ^ ip ^ ": " ^ s)
 122
 123 let dbg sockaddr s =
 124   Ocsigen_messages.debug
 125     (fun () ->
 126        let ip = Unix.string_of_inet_addr (ip_of_sockaddr sockaddr) in
 127        "While talking to " ^ ip ^ ": " ^ s)
 128
 129
 130 let r_content_type = Netstring_pcre.regexp "([^ ]*)"
 131
 132 let rec find_post_params http_frame ct filenames uploaddir =
 133   match http_frame.Ocsigen_http_frame.frame_content with
 134     | None -> return ([], [])
 135     | Some body_gen ->
 136         try
 137           let ((ct, cst), ctparams) = match ct with
 138 (* RFC 2616, sect. 7.2.1 *)
 139 (* If the media type remains unknown, the recipient SHOULD
 140    treat it as type "application/octet-stream". *)
 141             | None -> (("application", "octet-stream"), [])
 142             | Some (c, p) -> (c, p)
 143           in
 144           match String.lowercase ct, String.lowercase cst with
 145             | "application", "x-www-form-urlencoded" ->
 146                 find_post_params_form_urlencoded body_gen
 147             | "multipart", "form-data" ->
 148                 find_post_params_multipart_form_data body_gen ctparams filenames
 149                   uploaddir
 150             | _ -> fail Ocsigen_unsupported_media
 151         with e -> Lwt.fail e
 152
 153 and find_post_params_form_urlencoded body_gen =
 154   catch
 155     (fun () ->
 156        let body = Ocsigen_stream.get body_gen in
 157        (* BY, adapted from a previous comment. Should this stream be
 158           consumed in case of error? *)
 159        Ocsigen_stream.string_of_stream body
 160        >>= fun r ->
 161        Lwt.return
 162          ((Netencoding.Url.dest_url_encoded_parameters r), [])
 163     )
 164     (function
 165        | Ocsigen_stream.String_too_large -> fail Input_is_too_large
 166        | e -> fail e)
 167
 168 and find_post_params_multipart_form_data body_gen ctparams filenames ci =
 169   (* Same question here, should this stream be consumed after an error ? *)
 170   let body = Ocsigen_stream.get body_gen
 171   and bound = get_boundary ctparams
 172   and params = ref []
 173   and files = ref [] in
 174   let create hs =
 175     let content_type =
 176       try
 177         let ct = List.assoc "content-type" hs in
 178         let content_type =
 179           let (_, res) = Netstring_pcre.search_forward r_content_type ct 0 in
 180           Netstring_pcre.matched_group res 1 ct
 181         in
 182         let charset = try
 183           Some (find_field "charset" ct)
 184         with _ -> None
 185         in Some (content_type, charset)
 186       with _ -> None
 187     in
 188     let cd = List.assoc "content-disposition" hs in
 189     let p_name = find_field "name" cd in
 190     try
 191       let store = find_field "filename" cd in
 192       match ci.uploaddir with
 193         | Some dname ->
 194             let now = Printf.sprintf "%f-%d"
 195               (Unix.gettimeofday ()) (counter ()) in
 196             let fname = dname^"/"^now in
 197             let fd = Unix.openfile fname
 198               [Unix.O_CREAT; Unix.O_TRUNC; Unix.O_WRONLY; Unix.O_NONBLOCK] 0o666
 199             in
 200             Ocsigen_messages.debug2 ("Upload file opened: " ^ fname);
 201             filenames := fname::!filenames;
 202             A_File (p_name, fname, store, fd, content_type)
 203         | None -> raise Ocsigen_upload_forbidden
 204     with Not_found -> No_File (p_name, Buffer.create 1024)
 205   in
 206   let rec add where s =
 207     match where with
 208       | No_File (p_name, to_buf) ->
 209           Buffer.add_string to_buf s;
 210           return ()
 211       | A_File (_,_,_,wh,_) ->
 212           let len = String.length s in
 213           let r = Unix.write wh s 0 len in
 214           if r < len then
 215             (*XXXX Inefficient if s is long *)
 216             add where (String.sub s r (len - r))
 217           else
 218             Lwt_unix.yield ()
 219   in
 220   let stop size = function
 221     | No_File (p_name, to_buf) ->
 222         return
 223           (params := !params @ [(p_name, Buffer.contents to_buf)])
 224           (* à la fin ? *)
 225     | A_File (p_name,fname,oname,wh, content_type) ->
 226         (* Ocsigen_messages.debug "closing file"; *)
 227         files :=
 228           !files@[(p_name, {tmp_filename=fname;
 229                             filesize=size;
 230                             raw_original_filename=oname;
 231                             original_basename=(Ocsigen_lib.basename oname);
 232                             file_content_type = content_type;
 233                            })];
 234         Unix.close wh;
 235         return ()
 236   in
 237   Multipart.scan_multipart_body_from_stream
 238     body bound create add stop ci.maxuploadfilesize >>= fun () ->
 239     (*VVV Does scan_multipart_body_from_stream read until the end or
 240       only what it needs?  If we do not consume here, the following
 241       request will be read only when this one is finished ...  *)
 242   Ocsigen_stream.consume body_gen >>= fun () ->
 243   Lwt.return (!params, !files)
 244
 245
 246
 247 (* reading the request *)
 248 let get_request_infos
 249     meth clientproto url http_frame filenames sockaddr port receiver =
 250
 251   Lwt.catch
 252     (fun () ->
 253
 254        let (_, headerhost, headerport, url, path, params, get_params) =
 255          Ocsigen_lib.parse_url url
 256        in
 257
 258        let headerhost, headerport =
 259          match headerhost with
 260          | None -> get_host_from_host_header http_frame
 261          | _ -> headerhost, headerport
 262        in
 263
 264     (* RFC:
 265     1. If Request-URI is an absoluteURI, the host is part of the Request-URI.
 266        Any Host header field value in the request MUST be ignored.
 267     2. If the Request-URI is not an absoluteURI, and the request includes a
 268        Host header field, the host is determined by the Host header field value.
 269     3. If the host as determined by rule 1 or 2 is not a valid host on the
 270         server, the response MUST be a 400 (Bad Request) error message.
 271     *)
 272        (*  Here we don't trust the port information given by the request.
 273           We use the port we are listening on. *)
 274        Ocsigen_messages.debug
 275          (fun () ->
 276            "- host="^(match headerhost with None -> "<none>" | Some h -> h));
 277
 278    (* Servers MUST report a 400 (Bad Request) error if an HTTP/1.1
 279       request does not include a Host request-header. *)
 280
 281        if clientproto = Ocsigen_http_frame.Http_header.HTTP11 && headerhost = None
 282        then raise Ocsigen_Bad_Request;
 283
 284        let useragent = get_user_agent http_frame in
 285
 286        let cookies_string = lazy (get_cookie_string http_frame) in
 287
 288        let cookies =
 289          lazy (match (Lazy.force cookies_string) with
 290          | None -> Ocsigen_lib.String_Table.empty
 291          | Some s -> parse_cookies s)
 292        in
 293
 294        let ifmodifiedsince = get_if_modified_since http_frame in
 295
 296        let ifunmodifiedsince =  get_if_unmodified_since http_frame in
 297
 298        let ifnonematch = get_if_none_match http_frame in
 299
 300        let ifmatch = get_if_match http_frame in
 301
 302        let client_inet_addr = ip_of_sockaddr sockaddr in
 303
 304        let ct_string = get_content_type http_frame in
 305
 306        let ct = Ocsigen_headers.parse_content_type ct_string in
 307
 308        let cl = get_content_length http_frame in
 309
 310        let referer = lazy (get_referer http_frame) in
 311
 312        let accept = lazy (get_accept http_frame)   in
 313
 314        let accept_charset = lazy (get_accept_charset http_frame) in
 315
 316        let accept_encoding = lazy (get_accept_encoding http_frame) in
 317
 318        let accept_language = lazy (get_accept_language http_frame) in
 319
 320        let post_params =
 321          let r = ref None in
 322            (fun ci ->
 323               match !r with
 324                 | None ->
 325                     (if meth = Http_header.GET || meth = Http_header.HEAD then
 326                        return ([],[])
 327                      else
 328                        find_post_params http_frame ct filenames ci
 329                     ) >>= fun res ->
 330                     r := Some res;
 331                     return res
 332                 | Some r -> return r
 333            )
 334        in
 335
 336        let ipstring = Unix.string_of_inet_addr client_inet_addr in
 337        let path_string = string_of_url_path ~encode:true path in
 338
 339        Lwt.return
 340          {ri_url_string = url;
 341           ri_method = meth;
 342           ri_protocol = http_frame.Ocsigen_http_frame.frame_header.Ocsigen_http_frame.Http_header.proto;
 343           ri_ssl = Lwt_ssl.is_ssl (Ocsigen_http_com.connection_fd receiver);
 344           ri_full_path_string = path_string;
 345           ri_full_path = path;
 346           ri_original_full_path_string = path_string;
 347           ri_original_full_path = path;
 348           ri_sub_path = path;
 349           ri_sub_path_string = string_of_url_path ~encode:true path;
 350           ri_get_params_string = params;
 351           ri_host = headerhost;
 352           ri_port_from_host_field = headerport;
 353           ri_get_params = get_params;
 354           ri_initial_get_params = get_params;
 355           ri_post_params =(fun ci -> post_params ci >>= fun (a, b) -> return a);
 356           ri_files = (fun ci -> post_params ci >>= fun (a, b) -> return b);
 357           ri_remote_inet_addr = client_inet_addr;
 358           ri_remote_ip = ipstring;
 359           ri_remote_ip_parsed = lazy (fst (Ocsigen_lib.parse_ip ipstring));
 360           ri_remote_port = port_of_sockaddr sockaddr;
 361           ri_server_port = port;
 362           ri_user_agent = useragent;
 363           ri_cookies_string = cookies_string;
 364           ri_cookies = cookies;
 365           ri_ifmodifiedsince = ifmodifiedsince;
 366           ri_ifunmodifiedsince = ifunmodifiedsince;
 367           ri_ifnonematch = ifnonematch;
 368           ri_ifmatch = ifmatch;
 369           ri_content_type = ct;
 370           ri_content_type_string = ct_string;
 371           ri_content_length = cl;
 372           ri_referer = referer;
 373           ri_accept = accept;
 374           ri_accept_charset = accept_charset;
 375           ri_accept_encoding = accept_encoding;
 376           ri_accept_language = accept_language;
 377           ri_http_frame = http_frame;
 378           ri_request_cache = Polytables.create ();
 379           ri_client = Ocsigen_extensions.client_of_connection receiver;
 380           ri_range = lazy (Ocsigen_headers.get_range http_frame);
 381           ri_nb_tries = 0;
 382         }
 383     )
 384     (fun e ->
 385        Ocsigen_messages.debug (fun () -> "~~~ Exn during get_request_infos : "^
 386                                  string_of_exn e);
 387        Lwt.fail e)
 388
 389
 390 (* An http result [res] frame has been computed. Depending on
 391    the If-(None-)?Match and If-(Un)?Modified-Since headers of [ri],
 392    we return this frame, a 304: Not-Modified, or a 412: Precondition Failed.
 393    See RFC 2616, sections 14.24, 14.25, 14.26, 14.28 and 13.3.4
 394 *)
 395 let handle_result_frame ri res send =
 396   (* Subfonctions to handle each header separately *)
 397   let if_unmodified_since unmodified_since = (* Section 14.28 *)
 398     if (res.res_code = 412 ||
 399         (200 <= res.res_code && res.res_code < 300)) then
 400       match res.res_lastmodified with
 401         | Some r ->
 402             if r <= unmodified_since then
 403               `Ignore_header
 404             else
 405               `Precondition_failed
 406         | None -> `Ignore_header
 407     else
 408       `Ignore_header
 409
 410   and if_modified_since modified_since = (* Section 14.25 *)
 411     if res.res_code = 200 then
 412       match res.res_lastmodified with
 413         | Some r ->
 414             if r <= modified_since then
 415               `Unmodified
 416             else
 417               `Ignore_header
 418         | _ -> `Ignore_header
 419     else
 420       `Ignore_header
 421
 422   and if_none_match if_none_match = (* Section 14.26 *)
 423     if (res.res_code = 412 ||
 424         (200 <= res.res_code && res.res_code < 300)) then
 425       match res.res_etag with
 426         | None   -> `Ignore_header
 427         | Some e ->
 428             if List.mem e if_none_match then
 429               if ri.ri_method = Http_header.GET ||
 430                 ri.ri_method = Http_header.HEAD then
 431                   `Unmodified
 432               else
 433                 `Precondition_failed
 434             else
 435               `Ignore_header_and_ModifiedSince
 436     else
 437       `Ignore_header
 438
 439   and if_match if_match = (* Section 14.24 *)
 440     if (res.res_code = 412 ||
 441         (200 <= res.res_code && res.res_code < 300)) then
 442       match res.res_etag with
 443         | None   -> `Precondition_failed
 444         | Some e ->
 445             if List.mem e if_match then
 446               `Ignore_header
 447             else
 448               `Precondition_failed
 449     else
 450       `Ignore_header
 451
 452   in
 453
 454   let handle_header f h = match h with
 455     | None -> `No_header
 456     | Some h -> f h
 457   in
 458
 459   (* Main code *)
 460   let r =
 461     (* For the cases unspecified with RFC2616. we follow more or less
 462        the order used by Apache. See the function
 463        modules/http/http_protocol.c/ap_meets_conditions in the Apache
 464        source *)
 465     match handle_header if_match ri.ri_ifmatch with
 466     | `Precondition_failed -> `Precondition_failed
 467     | `No_header | `Ignore_header ->
 468       match handle_header if_unmodified_since ri.ri_ifunmodifiedsince with
 469       | `Precondition_failed -> `Precondition_failed
 470       | `No_header | `Ignore_header ->
 471         match handle_header if_none_match ri.ri_ifnonematch with
 472         | `Precondition_failed -> `Precondition_failed
 473         | `Ignore_header_and_ModifiedSince -> `Std
 474         | `Unmodified | `No_header as r1 ->
 475             (match handle_header if_modified_since ri.ri_ifmodifiedsince with
 476              | `Unmodified | `No_header as r2 ->
 477                  if r1 = `No_header && r2 = `No_header then
 478                    `Std
 479                  else
 480                    `Unmodified
 481              | `Ignore_header -> `Std)
 482         | `Ignore_header ->
 483             (* We cannot return a 304, so there is no need to consult
 484                if_modified_since *)
 485             `Std
 486   in
 487   match r with
 488     | `Unmodified ->
 489         Ocsigen_messages.debug2 "-> Sending 304 Not modified ";
 490         Ocsigen_stream.finalize (fst res.res_stream) >>= fun () ->
 491         send { (Ocsigen_http_frame.empty_result ()) with
 492                  res_code = 304  (* Not modified *);
 493                  res_lastmodified = res.res_lastmodified;
 494                  res_etag = res.res_etag;
 495              }
 496
 497     | `Precondition_failed ->
 498         Ocsigen_messages.debug2 "-> Sending 412 Precondition Failed \
 499                      (conditional headers)";
 500         Ocsigen_stream.finalize (fst res.res_stream) >>= fun () ->
 501         send { (Ocsigen_http_frame.empty_result ()) with
 502                  res_code = 412 (* Precondition failed *)}
 503
 504     | `Std ->
 505         Ocsigen_range.compute_range ri res
 506         >>= send
 507
 508 let http_url_syntax = Hashtbl.find Neturl.common_url_syntax "http"
 509
 510
 511 let service receiver sender_slot request meth url port sockaddr =
 512   (* sender_slot is here for pipelining:
 513      we must wait before sending the page,
 514      because the previous one may not be sent *)
 515
 516   let head = meth = Http_header.HEAD in
 517   let clientproto =
 518     Http_header.get_proto request.Ocsigen_http_frame.frame_header in
 519
 520   let handle_service_errors e =
 521     (* Exceptions during page generation *)
 522     Ocsigen_messages.debug
 523       (fun () -> "~~~ Exception during generation/sending: " ^ string_of_exn e);
 524     let send_error ?cookies code =
 525       Ocsigen_senders.send_error ~exn:e sender_slot ~clientproto ?cookies ~head
 526         ~code ~sender:Ocsigen_http_com.default_sender ()
 527     in
 528     match e with
 529       (* EXCEPTIONS WHILE COMPUTING A PAGE *)
 530     | Ocsigen_http_error (cookies_to_set, i) ->
 531         Ocsigen_messages.debug
 532           (fun () -> "-> Sending HTTP error "^(string_of_int i)^" "^
 533             Ocsigen_http_frame.Http_error.expl_of_code i);
 534         send_error ~cookies:cookies_to_set i
 535     | Ocsigen_stream.Interrupted Ocsigen_stream.Already_read ->
 536         Ocsigen_messages.warning
 537           "Cannot read the request twice. You probably have \
 538            two incompatible options in <site> configuration, \
 539            or the order of the options in the config file is wrong.";
 540         send_error 500 (* Internal error *)
 541     | Unix.Unix_error (Unix.EACCES,_,_)
 542     | Ocsigen_upload_forbidden ->
 543         Ocsigen_messages.debug2 "-> Sending 403 Forbidden";
 544         send_error 403
 545     | Http_error.Http_exception (code,_,_) ->
 546         Ocsigen_http_frame.Http_error.display_http_exception e;
 547         send_error code
 548     | Ocsigen_Bad_Request ->
 549         Ocsigen_messages.debug2 "-> Sending 400";
 550         send_error 400
 551     | Ocsigen_unsupported_media ->
 552         Ocsigen_messages.debug2 "-> Sending 415";
 553         send_error 415
 554     | Neturl.Malformed_URL ->
 555         Ocsigen_messages.debug2 "-> Sending 400 (Malformed URL)";
 556         send_error 400
 557     | Ocsigen_lib.Ocsigen_Request_too_long ->
 558         Ocsigen_messages.debug2 "-> Sending 413 (Entity too large)";
 559         send_error 413
 560     | e ->
 561         Ocsigen_messages.warning
 562           ("Exn during page generation: " ^ string_of_exn e ^" (sending 500)");
 563         Ocsigen_messages.debug2 "-> Sending 500";
 564         send_error 500
 565   in
 566   let finish_request () =
 567     (* We asynchronously finish to read the request contents if this
 568        is not done yet so that:
 569        - we can handle the next request
 570        - there is no dead-lock with the client writing the request and
 571          the server writing the response.
 572        We need to do this once the request has been handled before sending
 573        any reply to the client. *)
 574     match request.Ocsigen_http_frame.frame_content with
 575       | Some f ->
 576           ignore
 577             (Lwt.catch
 578                (fun () ->
 579                   Ocsigen_stream.finalize f (* will consume the stream and
 580                                                unlock the mutex
 581                                                if not already done *)
 582                )
 583                (function
 584                  | e ->
 585
 586                      (match e with
 587                      | Ocsigen_http_com.Lost_connection _ ->
 588                          warn sockaddr "connection abruptly closed by peer \
 589                            while reading contents"
 590                      | Ocsigen_http_com.Timeout ->
 591                          warn sockaddr "timeout while reading contents"
 592                      | Ocsigen_http_com.Aborted ->
 593                          dbg sockaddr "reading thread aborted"
 594                      | Http_error.Http_exception (code, mesg, _) ->
 595                          warn sockaddr (Http_error.string_of_http_exception e)
 596                      | _ ->
 597                          Ocsigen_messages.unexpected_exception
 598                            e "Server.finish_request"
 599                             );
 600                      Ocsigen_http_com.abort receiver;
 601                      (* We unlock the receiver in order to resume the
 602                         reading loop.  As the connection has been aborted,
 603                         the next read will fail and the connection will be
 604                         closed properly. *)
 605                      Ocsigen_http_com.unlock_receiver receiver;
 606                      Lwt.return ()))
 607     | None ->
 608         ()
 609   in
 610
 611   (* body of service *)
 612   if meth <> Http_header.GET &&
 613      meth <> Http_header.POST &&
 614      meth <> Http_header.HEAD
 615   then begin
 616    (* VVV Warning: This must be done once and only once.
 617       Put this somewhere else to ensure that?
 618     *)
 619     warn sockaddr ("Bad request: \""^url^"\"");
 620     Ocsigen_http_com.wakeup_next_request receiver;
 621     finish_request ();
 622     (* RFC 2616, sect 5.1.1 *)
 623     send_error
 624       sender_slot ~clientproto ~head ~code:501
 625       ~sender:Ocsigen_http_com.default_sender ()
 626   end else begin
 627     let filenames = ref [] (* All the files sent by the request *) in
 628
 629     Lwt.finalize (fun () ->
 630       (* *** First of all, we read the whole the request
 631          (that will possibly create files) *)
 632       Lwt.try_bind
 633         (fun () ->
 634            get_request_infos
 635              meth clientproto url request filenames sockaddr
 636              port receiver)
 637         (fun ri ->
 638            (* *** Now we generate the page and send it *)
 639            (* Log *)
 640            accesslog
 641              (Format.sprintf
 642                 "connection for %s from %s (%s): %s"
 643                 (match ri.ri_host with
 644                    | None   -> "<host not specified in the request>"
 645                    | Some h -> h)
 646                 ri.ri_remote_ip
 647                 ri.ri_user_agent
 648                 ri.ri_url_string);
 649
 650            let send_aux =
 651              send sender_slot ~clientproto ~head
 652                ~sender:Ocsigen_http_com.default_sender
 653            in
 654
 655            (* Generation of pages is delegated to extensions: *)
 656            Lwt.try_bind
 657              (fun () -> Ocsigen_extensions.serve_request
 658                 ~awake_next_request:true ri)
 659              (fun res ->
 660                 finish_request ();
 661                 handle_result_frame ri res send_aux
 662              )
 663              (fun e ->
 664                 finish_request ();
 665                 match e with
 666                 | Ocsigen_extensions.Ocsigen_Is_a_directory request ->
 667                     (* User requested a directory. We redirect it to
 668                        the correct url (with a slash), so that relative
 669                        urls become correct *)
 670                     Ocsigen_messages.debug2 "-> Sending 301 Moved permanently";
 671                     let port = Ocsigen_extensions.get_port request in
 672                     let new_url = Neturl.make_url
 673                       ~scheme:(if ri.ri_ssl then "https" else "http")
 674                       ~host:(Ocsigen_extensions.get_hostname request)
 675                       ?port:(if (port = 80 && not ri.ri_ssl)
 676                                || (ri.ri_ssl && port = 443)
 677                              then None
 678                              else Some port)
 679                       ~path:(""::(Ocsigen_lib.add_end_slash_if_missing
 680                                     ri.ri_full_path))
 681                       ?query:ri.ri_get_params_string
 682                       http_url_syntax
 683                     in
 684                     send_aux {
 685                       (Ocsigen_http_frame.empty_result ()) with
 686                         res_code = 301;
 687                         res_location = Some (Neturl.string_of_url new_url)
 688                    }
 689
 690                 | _ -> handle_service_errors e
 691              )
 692         )
 693         (fun e ->
 694            warn sockaddr ("Bad request: \""^url^"\"");
 695            Ocsigen_http_com.wakeup_next_request receiver;
 696            finish_request ();
 697            handle_service_errors e
 698         ))
 699       (fun () ->
 700          (* We remove all the files created by the request
 701             (files sent by the client) *)
 702         if !filenames <> [] then Ocsigen_messages.debug2 "** Removing files";
 703         List.iter
 704           (fun a ->
 705             try Unix.unlink a
 706             with Unix.Unix_error _ as e ->
 707               Ocsigen_messages.warning
 708                 (Format.sprintf "Error while removing file %s: %s"
 709                    a (string_of_exn e)))
 710           !filenames;
 711         return ())
 712   end
 713
 714 let linger in_ch receiver =
 715   Lwt.catch
 716     (fun () ->
 717        (* We wait for 30 seconds at most and close the connection
 718           after 2 seconds without receiving data from the client *)
 719        let abort_fun () = Lwt_ssl.abort in_ch Exit in
 720        let long_timeout = Lwt_timeout.create 30 abort_fun in
 721        let short_timeout = Lwt_timeout.create 2 abort_fun in
 722        Lwt_timeout.start long_timeout;
 723        let s = String.create 1024 in
 724
 725        let rec linger_aux () =
 726          Lwt_ssl.wait_read in_ch >>= fun () ->
 727          Lwt.try_bind
 728            (fun () ->
 729               Lwt_timeout.start short_timeout;
 730               Lwt_ssl.read in_ch s 0 1024)
 731            (fun len ->
 732               if len > 0 then linger_aux () else Lwt.return ())
 733            (fun e ->
 734               begin match e with
 735                 Unix.Unix_error(Unix.ECONNRESET,_,_)
 736               | Ssl.Read_error (Ssl.Error_syscall | Ssl.Error_ssl)
 737               | Exit ->
 738                   Lwt.return ()
 739               | _ ->
 740                   Lwt.fail e
 741               end)
 742        in
 743        (* We start the lingering reads before waiting for the
 744           senders to terminate in order to avoid a deadlock *)
 745        let linger_thread = linger_aux () in
 746        Ocsigen_http_com.wait_all_senders receiver >>= fun () ->
 747        Ocsigen_messages.debug2 "** SHUTDOWN";
 748        Lwt_ssl.ssl_shutdown in_ch >>= fun () ->
 749        Lwt_ssl.shutdown in_ch Unix.SHUTDOWN_SEND;
 750        linger_thread >>= fun () ->
 751        Lwt_timeout.stop long_timeout;
 752        Lwt_timeout.stop short_timeout;
 753        Lwt.return ())
 754     (fun e ->
 755        Ocsigen_messages.unexpected_exception e "Server.linger"; Lwt.return ())
 756
 757 let try_bind' f g h = Lwt.try_bind f h g
 758
 759 let add_to_receivers_waiting_for_pipeline,
 760   remove_from_receivers_waiting_for_pipeline,
 761   iter_receivers_waiting_for_pipeline =
 762   let l = Ocsigen_lib.Clist.create () in
 763   ((fun r ->
 764       let node = Ocsigen_lib.Clist.make r in
 765       Ocsigen_lib.Clist.insert l node;
 766       node),
 767    Ocsigen_lib.Clist.remove,
 768    (fun f ->
 769       Ocsigen_lib.Clist.fold_left
 770         (fun t v -> t >>= fun () -> f v)
 771         (Lwt.return ())
 772         l))
 773
 774 let handle_connection port in_ch sockaddr =
 775   let receiver = Ocsigen_http_com.create_receiver
 776     (Ocsigen_config.get_client_timeout ()) Query in_ch
 777   in
 778
 779   let handle_write_errors e =
 780     begin match e with
 781     | Lost_connection e' ->
 782         warn sockaddr ("connection abruptly closed by peer ("
 783                        ^ string_of_exn e' ^ ")")
 784     | Ocsigen_http_com.Timeout ->
 785         warn sockaddr "timeout"
 786     | Ocsigen_http_com.Aborted ->
 787         dbg sockaddr "writing thread aborted"
 788     | Ocsigen_stream.Interrupted e' ->
 789         warn sockaddr ("interrupted content stream (" ^ string_of_exn e' ^ ")")
 790     | _ ->
 791         Ocsigen_messages.unexpected_exception e "Server.handle_write_errors"
 792     end;
 793     Ocsigen_http_com.abort receiver;
 794     Lwt.fail Ocsigen_http_com.Aborted
 795   in
 796
 797   let handle_read_errors e =
 798     begin match e with
 799     | Ocsigen_http_com.Connection_closed ->
 800         (* This is the clean way to terminate the connection *)
 801         dbg sockaddr "connection closed by peer";
 802         Ocsigen_http_com.abort receiver;
 803         Ocsigen_http_com.wait_all_senders receiver
 804     | Ocsigen_http_com.Keepalive_timeout ->
 805         dbg sockaddr "keepalive timeout";
 806         Ocsigen_http_com.abort receiver;
 807         Ocsigen_http_com.wait_all_senders receiver
 808     | Ocsigen_http_com.Lost_connection _ ->
 809         warn sockaddr "connection abruptly closed by peer";
 810         Ocsigen_http_com.abort receiver;
 811         Ocsigen_http_com.wait_all_senders receiver
 812     | Ocsigen_http_com.Timeout ->
 813         warn sockaddr "timeout";
 814         Ocsigen_http_com.abort receiver;
 815         Ocsigen_http_com.wait_all_senders receiver
 816     | Ocsigen_http_com.Aborted ->
 817         dbg sockaddr "reading thread aborted";
 818         Ocsigen_http_com.wait_all_senders receiver
 819     | Http_error.Http_exception (code, mes, _) ->
 820         warn sockaddr (Http_error.string_of_http_exception e);
 821         Ocsigen_http_com.start_processing receiver (fun slot ->
 822           (*XXX We should use the right information for clientproto
 823             and head... *)
 824           send_error slot
 825             ~clientproto:Ocsigen_http_frame.Http_header.HTTP10
 826             ~head:false
 827             (* ~keep_alive:false *)
 828             ~exn:e
 829             ~sender:Ocsigen_http_com.default_sender ());
 830         linger in_ch receiver
 831     | _ ->
 832         Ocsigen_messages.unexpected_exception e "Server.handle_read_errors";
 833         Ocsigen_http_com.abort receiver;
 834         Ocsigen_http_com.wait_all_senders receiver
 835     end
 836   in
 837
 838   let rec handle_request ?receiver_pos () =
 839     try_bind'
 840       (fun () ->
 841          Ocsigen_messages.debug2 "** Receiving HTTP message";
 842          (if Ocsigen_config.get_respect_pipeline () then
 843          (* if we lock this mutex, requests from a same connection will be sent
 844             to extensions in the same order they are received on pipeline.
 845             It is locked only in server. Ocsigen_http_client has its own mutex.
 846 (*VVV use the same? *)
 847          *)
 848             Ocsigen_http_com.block_next_request receiver
 849           else
 850             Lwt.return ())
 851          >>= fun () ->
 852          Ocsigen_http_com.get_http_frame receiver)
 853       (fun exn ->
 854          (* We remove the receiver from the set of requests
 855             waiting for pipeline *)
 856          (match receiver_pos with
 857            | Some pos -> remove_from_receivers_waiting_for_pipeline pos
 858            | None -> ());
 859          handle_read_errors exn)
 860       (fun request ->
 861          (* As above *)
 862          (match receiver_pos with
 863            | Some pos -> remove_from_receivers_waiting_for_pipeline pos
 864            | None -> ());
 865          let meth, url =
 866            match
 867              Http_header.get_firstline request.Ocsigen_http_frame.frame_header
 868            with
 869              | Http_header.Query a -> a
 870              | _                   -> assert false
 871            (*XXX Should be checked in [get_http_frame] *)
 872          in
 873          Ocsigen_http_com.start_processing receiver (fun slot ->
 874            Lwt.catch
 875              (fun () ->
 876 (*XXX Why do we need the port but not the host name? *)
 877                 service receiver slot request meth url port sockaddr)
 878              handle_write_errors);
 879          if not !shutdown &&
 880            get_keepalive request.Ocsigen_http_frame.frame_header
 881          then
 882            (* We put the receiver in the set of receiver waiting for
 883               pipeline in order to be able to shutdown the connections
 884               if the server is shutting down.
 885            *)
 886            handle_request
 887              ~receiver_pos:(add_to_receivers_waiting_for_pipeline receiver) ()
 888          else (* No keep-alive => no pipeline *)
 889             (* We wait for the query to be entirely read and for
 890                the reply to be sent *)
 891             Ocsigen_http_com.lock_receiver receiver >>= fun () ->
 892             Ocsigen_http_com.wait_all_senders receiver >>= fun () ->
 893             Lwt_ssl.ssl_shutdown in_ch
 894       )
 895
 896   in (* body of handle_connection *)
 897   handle_request ()
 898
 899 let rec wait_connection use_ssl port socket =
 900   let handle_exn e =
 901     Lwt_unix.yield () >>= fun () -> match e with
 902     | Socket_closed ->
 903         Ocsigen_messages.debug2 "Socket closed";
 904         Lwt.return ()
 905     | Unix.Unix_error ((Unix.EMFILE | Unix.ENFILE), _, _) ->
 906         (* this should not happen, report it *)
 907         Ocsigen_messages.errlog
 908           "Max number of file descriptors reached unexpectedly, please check...";
 909         wait_connection use_ssl port socket
 910     | e ->
 911         Ocsigen_messages.debug
 912           (fun () -> Format.sprintf "Accept failed: %s" (string_of_exn e));
 913         wait_connection use_ssl port socket
 914   in
 915   try_bind'
 916     (fun () ->
 917        (* if too much connections,
 918           we wait for a signal before accepting again *)
 919        let max = get_max_number_of_connections () in
 920        (if get_number_of_connected () < max
 921         then Lwt.return ()
 922         else begin
 923           ignore
 924             (Ocsigen_messages.warning
 925                (Format.sprintf "Max simultaneous connections (%d) reached."
 926                   (get_max_number_of_connections ())));
 927           wait_fewer_connected max
 928         end) >>= fun () ->
 929        (* We do several accept(), as explained in
 930          "Accept()able strategies ..." by Tim Brecht & al. *)
 931        Lwt_unix.accept_n socket 50)
 932     handle_exn
 933     (fun (l, e) ->
 934        let number_of_accepts = List.length l in
 935        Ocsigen_messages.debug
 936          (fun () -> "received "^string_of_int number_of_accepts^" accepts" );
 937        incr_connected number_of_accepts;
 938        ignore (wait_connection use_ssl port socket);
 939
 940        let handle_one (s, sockaddr) =
 941          Ocsigen_messages.debug2
 942            "\n__________________NEW CONNECTION__________________________";
 943          Lwt.catch
 944            (fun () ->
 945               Lwt_unix.set_close_on_exec s;
 946               disable_nagle (Lwt_unix.unix_file_descr s);
 947               begin if use_ssl then
 948                 Lwt_ssl.ssl_accept s !sslctx
 949               else
 950                 Lwt.return (Lwt_ssl.plain s)
 951               end >>= fun in_ch ->
 952               handle_connection port in_ch sockaddr)
 953            (fun e ->
 954               Ocsigen_messages.unexpected_exception e
 955                 "Server.wait_connection (handle connection)";
 956               return ())
 957          >>= fun () ->
 958          Ocsigen_messages.debug2 "** CLOSE";
 959          Lwt.catch
 960            (fun () -> Lwt_unix.close s)
 961            (function
 962            | Unix.Unix_error _ as e ->
 963              Ocsigen_messages.unexpected_exception e
 964                "Server.wait_connection (close)";
 965              Lwt.return ()
 966            | e -> Lwt.fail e)
 967          >>= (fun () -> decr_connected ())
 968        in
 969
 970        Lwt_util.iter handle_one l >>= fun () ->
 971        match e with
 972          | Some e -> handle_exn e
 973          | None -> Lwt.return ())
 974
 975
 976
 977 let stop m n =
 978   errlog m; exit n
 979
 980 (** Thread waiting for events on a the listening port *)
 981 let listen use_ssl (addr, port) wait_end_init =
 982   let listening_sockets =
 983     try
 984       let sockets = make_sockets addr port in
 985       List.iter (fun x -> Lwt_unix.listen x 1024) sockets;
 986       sockets
 987     with
 988     | Unix.Unix_error (Unix.EACCES, _, _) ->
 989         stop
 990           (Format.sprintf "Fatal - You are not allowed to use port %d." port)
 991           7
 992     | Unix.Unix_error (Unix.EADDRINUSE, _, _) ->
 993         stop (Format.sprintf "Fatal - The port %d is already in use." port) 8
 994     | exn ->
 995         stop ("Fatal - Uncaught exception: " ^ string_of_exn exn) 100
 996   in
 997   List.iter (fun x ->
 998                ignore (wait_end_init >>= fun () ->
 999                        wait_connection use_ssl port x)) listening_sockets;
1000   listening_sockets
1001
1002 (* fatal errors messages *)
1003 let errmsg = function
1004   | Dynlink_wrapper.Error e ->
1005       (("Fatal - Dynamic linking error: "^(Dynlink_wrapper.error_message e)),
1006       6)
1007   | (Unix.Unix_error _) as e ->
1008       (("Fatal - "^(string_of_exn e)),
1009       9)
1010   | Ssl.Private_key_error ->
1011       (("Fatal - bad password"),
1012       10)
1013   | Ocsigen_config.Config_file_error msg
1014   | Ocsigen_extensions.Error_in_config_file msg ->
1015       (("Fatal - Error in configuration file: "^msg),
1016       50)
1017   | Simplexmlparser.Xml_parser_error s ->
1018       (("Fatal - Error in configuration file: "^s),
1019        51)
1020   | Ocsigen_loader.Dynlink_error (s, exn) ->
1021       (("Fatal - While loading "^s^": "^(string_of_exn exn)),
1022       52)
1023   | Ocsigen_loader.Findlib_error _ as e ->
1024       (("Fatal - " ^ string_of_exn e), 53)
1025   | exn ->
1026       try
1027         ((Ocsigen_extensions.get_init_exn_handler () exn),
1028         20)
1029       with
1030         exn ->
1031           (("Fatal - Uncaught exception: "^string_of_exn exn),
1032           100)
1033
1034
1035
1036
1037 (* loading new configuration *)
1038 let reload_conf s =
1039   try
1040     Ocsigen_extensions.start_initialisation ();
1041
1042     parse_server true s;
1043
1044     Ocsigen_extensions.end_initialisation ();
1045   with e ->
1046     Ocsigen_extensions.end_initialisation ();
1047     errlog (fst (errmsg e))
1048
1049 (* reloading the config file *)
1050 let reload ?file () =
1051
1052   (* That function cannot be interrupted??? *)
1053   Ocsigen_messages.warning "Reloading config file" ;
1054
1055   (try
1056     match parse_config ?file () with
1057     | [] -> ()
1058     | s::_ -> reload_conf s
1059   with e -> errlog (fst (errmsg e)));
1060
1061   Ocsigen_messages.warning "Config file reloaded"
1062
1063
1064 let shutdown_server s l =
1065   try
1066     let timeout = match l with
1067       | [] -> Ocsigen_config.get_shutdown_timeout ()
1068       | ["notimeout"] -> None
1069       | [t] ->
1070           Some (float_of_string t)
1071       | _ -> failwith "syntax error in command"
1072     in
1073     Ocsigen_messages.warning "Shutting down";
1074     List.iter
1075       (fun s -> Lwt_unix.abort s Socket_closed) !sockets;
1076     List.iter
1077       (fun s -> Lwt_unix.abort s Socket_closed) !sslsockets;
1078     sockets := [];
1079     sslsockets := [];
1080     shutdown := true;
1081     if Ocsigen_extensions.get_number_of_connected () <= 0
1082     then exit 0;
1083     (match timeout with
1084        | Some t -> ignore (Lwt_unix.sleep t >>= fun () -> exit 0)
1085        | None -> ());
1086     ignore
1087       (iter_receivers_waiting_for_pipeline
1088          (fun receiver ->
1089             Ocsigen_http_com.wait_all_senders receiver >>= fun () ->
1090               Ocsigen_http_com.abort receiver;
1091               Lwt.return ()));
1092   with Failure e ->
1093     Ocsigen_messages.warning ("Wrong command: " ^ s ^ " (" ^ e ^ ")")
1094
1095
1096 let _ =
1097   let f s = function
1098     | ["reopen_logs"] ->
1099         Ocsigen_messages.open_files ();
1100         Ocsigen_messages.warning "Log files reopened"
1101     | ["reload"] -> reload ()
1102     | ["reload"; file] -> reload ~file ()
1103     | "shutdown"::l -> shutdown_server s l
1104     | ["gc"] ->
1105         Gc.compact ();
1106         Ocsigen_messages.warning "Heap compaction requested by user"
1107     | ["clearcache"] -> Ocsigen_cache.clear_all_caches ()
1108     | _ -> raise Ocsigen_extensions.Unknown_command
1109   in
1110   Ocsigen_extensions.register_command_function f
1111
1112
1113
1114 let start_server () = try
1115
1116   (* initialization functions for modules (Ocsigen extensions or application
1117      code) loaded from now on will be executed directly. *)
1118   Ocsigen_loader.set_init_on_load true;
1119
1120   let config_servers = parse_config () in
1121
1122   let number_of_servers = List.length config_servers in
1123
1124   if number_of_servers > 1
1125   then ignore (Ocsigen_messages.warning "Multiple servers not supported anymore");
1126
1127   let ask_for_passwd sslports _ =
1128     print_string "Please enter the password for the HTTPS server listening \
1129       on port(s) ";
1130     print_string (String.concat ", " (List.map (fun (_,p) -> string_of_int p) sslports));
1131     print_string ": ";
1132     let old_term= Unix.tcgetattr Unix.stdin in
1133     let old_echo = old_term.Unix.c_echo in
1134     old_term.Unix.c_echo <- false;
1135     Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH old_term;
1136     try
1137       let r = read_line () in
1138       print_newline ();
1139       old_term.Unix.c_echo <- old_echo;
1140       Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH old_term;
1141       r
1142     with exn ->
1143       old_term.Unix.c_echo <- old_echo;
1144       Unix.tcsetattr Unix.stdin Unix.TCSAFLUSH old_term;
1145       raise exn
1146   in
1147
1148   let run (user, group) (_, ports, sslports) (minthreads, maxthreads) s =
1149
1150     Ocsigen_messages.open_files ();
1151
1152     Lwt_unix.run
1153       (let wait_end_init, wait_end_init_awakener = wait () in
1154       (* Listening on all ports: *)
1155       sockets := List.fold_left (fun a i -> (listen false i wait_end_init)@a) [] ports;
1156       sslsockets := List.fold_left (fun a i -> (listen true i wait_end_init)@a) [] sslports;
1157
1158       begin match ports with
1159         | (_, p)::_ -> Ocsigen_config.set_default_port p
1160         | _ -> ()
1161       end;
1162       begin match sslports with
1163         | (_, p)::_ -> Ocsigen_config.set_default_sslport p
1164         | _ -> ()
1165       end;
1166
1167       let current_uid = Unix.getuid () in
1168
1169       let gid = match group with
1170         | None -> Unix.getgid ()
1171         | Some group -> (try
1172                            (Unix.getgrnam group).Unix.gr_gid
1173                          with Not_found as e -> errlog ("Error: Wrong group"); raise e)
1174       in
1175
1176       let uid = match user with
1177         | None -> current_uid
1178         | Some user -> (try
1179                           (Unix.getpwnam user).Unix.pw_uid
1180                         with Not_found as e -> (errlog ("Error: Wrong user"); raise e))
1181       in
1182
1183       (* A pipe to communicate with the server *)
1184       let commandpipe = get_command_pipe () in
1185       (try
1186         ignore (Unix.stat commandpipe);
1187       with Unix.Unix_error _ ->
1188         (try
1189           let umask = Unix.umask 0 in
1190           Unix.mkfifo commandpipe 0o660;
1191           Unix.chown commandpipe uid gid;
1192           ignore (Unix.umask umask);
1193         with e ->
1194           Ocsigen_messages.errlog
1195             ("Cannot create the command pipe: "^(string_of_exn e))));
1196
1197       (* I change the user for the process *)
1198       begin try
1199         if current_uid = 0 then begin
1200           match user with
1201             | None -> ()
1202             | Some user -> initgroups user gid
1203         end;
1204         Unix.setgid gid;
1205         Unix.setuid uid;
1206       with (Unix.Unix_error _ | Failure _) as e ->
1207         Ocsigen_messages.errlog ("Error: Wrong user or group"); raise e
1208       end;
1209
1210       Ocsigen_config.set_user user;
1211       Ocsigen_config.set_group group;
1212
1213       (* Je suis fou :
1214          let rec f () =
1215            print_endline "-";
1216            Lwt_unix.yield () >>= f
1217            in f (); *)
1218
1219       if maxthreads < minthreads
1220       then
1221         raise
1222           (Config_file_error "maxthreads should be greater than minthreads");
1223
1224       ignore (Lwt_preemptive.init minthreads maxthreads Ocsigen_messages.errlog);
1225
1226       (* Now I can load the modules *)
1227       Dynlink_wrapper.init ();
1228       Dynlink_wrapper.allow_unsafe_modules true;
1229
1230       Ocsigen_extensions.start_initialisation ();
1231
1232       parse_server false s;
1233
1234       Dynlink_wrapper.prohibit ["Ocsigen_extensions.R"];
1235       (* As libraries are reloaded each time the config file is read,
1236          we do not allow to register extensions in libraries *)
1237       (* seems it does not work :-/ *)
1238
1239
1240       (* Closing stderr, stdout stdin if silent *)
1241       if (Ocsigen_config.get_silent ())
1242       then begin
1243         (* redirect stdout and stderr to /dev/null *)
1244         let devnull = Unix.openfile "/dev/null" [Unix.O_WRONLY] 0 in
1245         Unix.dup2 devnull Unix.stdout;
1246         Unix.dup2 devnull Unix.stderr;
1247         Unix.close devnull;
1248         Unix.close Unix.stdin;
1249       end;
1250
1251       (* detach from the terminal *)
1252       if (Ocsigen_config.get_daemon ())
1253       then ignore (Unix.setsid ());
1254
1255       Ocsigen_extensions.end_initialisation ();
1256
1257       (* Communication with the server through the pipe *)
1258       (try
1259         ignore (Unix.stat commandpipe)
1260       with Unix.Unix_error _ ->
1261           let umask = Unix.umask 0 in
1262           Unix.mkfifo commandpipe 0o660;
1263           ignore (Unix.umask umask);
1264           ignore (Ocsigen_messages.warning "Command pipe created"));
1265
1266       let pipe = Lwt_chan.in_channel_of_descr
1267           (Lwt_unix.of_unix_file_descr
1268              (Unix.openfile commandpipe
1269                 [Unix.O_RDWR; Unix.O_NONBLOCK; Unix.O_APPEND] 0o660)) in
1270
1271       let rec f () =
1272         Lwt_chan.input_line pipe >>= fun s ->
1273         Ocsigen_messages.warning ("Command received: "^s);
1274         (try
1275           let prefix, c =
1276             match Ocsigen_lib.split ~multisep:true ' ' s with
1277               | [] -> raise Ocsigen_extensions.Unknown_command
1278               | a::l ->
1279                   try
1280                     let aa, ab = Ocsigen_lib.sep ':' a in
1281                     (Some aa, (ab::l))
1282                   with Not_found -> None, (a::l)
1283           in
1284           Ocsigen_extensions.get_command_function () ?prefix s c
1285         with Unknown_command ->
1286           Ocsigen_messages.warning "Unknown command: ");
1287         f ()
1288       in ignore (f ());
1289
1290       Lwt.wakeup wait_end_init_awakener ();
1291
1292       Ocsigen_messages.warning "Ocsigen has been launched (initialisations ok)";
1293
1294       fst (Lwt.wait ())
1295       )
1296   in
1297
1298   let set_passwd_if_needed (ssl, ports, sslports) =
1299     if sslports <> []
1300     then
1301       match ssl with
1302         | None
1303         | Some (None, None) -> ()
1304         | Some (None, _) -> raise (Ocsigen_config.Config_file_error
1305                                      "SSL certificate is missing")
1306         | Some (_, None) -> raise (Ocsigen_config.Config_file_error
1307                                      "SSL key is missing")
1308         | Some ((Some c), (Some k)) ->
1309             Ssl.set_password_callback !sslctx (ask_for_passwd sslports);
1310             Ssl.use_certificate !sslctx c k
1311   in
1312
1313   let write_pid pid =
1314     match Ocsigen_config.get_pidfile () with
1315       None -> ()
1316     | Some p ->
1317         let spid = (string_of_int pid)^"\n" in
1318         let len = String.length spid in
1319         let f =
1320           Unix.openfile
1321             p
1322             [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_APPEND] 0o640 in
1323         ignore (Unix.write f spid 0 len);
1324         Unix.close f
1325   in
1326
1327   let rec launch = function
1328       [] -> ()
1329     | [h] ->
1330         let user_info, sslinfo, threadinfo = extract_info h in
1331         set_passwd_if_needed sslinfo;
1332         let pid = Unix.fork () in
1333         if pid = 0
1334         then run user_info sslinfo threadinfo h
1335         else begin
1336           ignore
1337             (Ocsigen_messages.console
1338                (fun () -> "Process "^(string_of_int pid)^" detached"));
1339           write_pid pid;
1340         end
1341     | _ -> () (* Multiple servers not supported any more *)
1342
1343   in
1344
1345   if (not (get_daemon ())) &&
1346     number_of_servers = 1
1347   then begin
1348     let cf = List.hd config_servers in
1349     let (user_info,
1350          ((ssl, ports, sslports) as sslinfo),
1351          threadinfo) =
1352       extract_info cf
1353     in
1354     set_passwd_if_needed sslinfo;
1355     write_pid (Unix.getpid ());
1356     run user_info sslinfo threadinfo cf
1357   end
1358   else launch config_servers
1359
1360 with e ->
1361   let msg, errno = errmsg e in
1362   stop msg errno