helm/uwobo/uwobo.ml

   1 (*
   2  * Copyright (C) 2003:
   3  *    Stefano Zacchiroli <zack@cs.unibo.it>
   4  *    for the HELM Team http://helm.cs.unibo.it/
   5  *
   6  *  This file is part of HELM, an Hypertextual, Electronic
   7  *  Library of Mathematics, developed at the Computer Science
   8  *  Department, University of Bologna, Italy.
   9  *
  10  *  HELM is free software; you can redistribute it and/or
  11  *  modify it under the terms of the GNU General Public License
  12  *  as published by the Free Software Foundation; either version 2
  13  *  of the License, or (at your option) any later version.
  14  *
  15  *  HELM is distributed in the hope that it will be useful,
  16  *  but WITHOUT ANY WARRANTY; without even the implied warranty of
  17  *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18  *  GNU General Public License for more details.
  19  *
  20  *  You should have received a copy of the GNU General Public License
  21  *  along with HELM; if not, write to the Free Software
  22  *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  23  *  MA  02111-1307, USA.
  24  *
  25  *  For details, see the HELM World-Wide-Web page,
  26  *  http://helm.cs.unibo.it/
  27  *)
  28
  29 open Printf;;
  30 open Uwobo_common;;
  31
  32  (* debugging settings *)
  33 let debug = false ;;
  34 let debug_level = `Notice ;;
  35 let debug_print s = if debug then prerr_endline s ;;
  36 Http_common.debug := false ;;
  37
  38
  39   (* First of all we load the configuration *)
  40 let _ =
  41  let configuration_file = "/projects/helm/etc/uwobo.conf.xml" in
  42   Helm_registry.load_from configuration_file
  43 ;;
  44
  45   (* other settings *)
  46 let daemon_name = "UWOBO OCaml" ;;
  47 let default_media_type = "text/html" ;;
  48 let default_encoding = "utf8" ;;
  49
  50 let get_media_type props =
  51  try
  52   List.assoc "media-type" props
  53  with
  54   Not_found -> default_media_type
  55 ;;
  56
  57 let get_encoding props =
  58  try
  59   List.assoc "encoding" props
  60  with
  61   Not_found -> default_encoding
  62 ;;
  63
  64 let string_of_param_option (req: Http_types.request) name =
  65   try
  66     req#param name
  67   with
  68       Http_types.Param_not_found _ -> "#"
  69
  70 let string_option_of_string =
  71   function
  72       "#" -> None
  73     | s -> Some s
  74
  75 let port = Helm_registry.get_int "uwobo.port";;
  76
  77 let logfilename_of_port port =
  78  let basename = Helm_registry.get "uwobo.log_basename" in
  79  let extension = Helm_registry.get "uwobo.log_extension" in
  80   basename ^ "_" ^ string_of_int port ^ extension
  81 ;;
  82
  83 let logfile = logfilename_of_port port;;
  84 let logfile_perm = 0o640 ;;
  85
  86 let respond_html body outchan =
  87   Http_daemon.respond ~body ~headers:["Content-Type", "text/html"] outchan
  88 ;;
  89
  90   (** perform an 'action' that can be applied to a list of keys or, if no keys
  91   was given, to all keys *)
  92 let act_on_keys
  93   keys_param styles logger per_key_action all_keys_action all_keys logmsg
  94 =
  95   let keys =
  96     try
  97       Pcre.split ~pat:"," keys_param
  98     with Http_types.Param_not_found _ -> []
  99   in
 100   match keys with
 101   | [] -> (* no key provided, act on all stylesheets *)
 102       logger#log (sprintf "%s all stylesheets (keys = %s) ..."
 103         logmsg (String.concat ", " all_keys));
 104       (try all_keys_action () with e -> logger#log (Printexc.to_string e));
 105       logger#log (sprintf "Done! (all stylesheets)")
 106   | keys ->
 107       List.iter
 108         (fun key -> (* act on a single stylesheet *)
 109           logger#log (sprintf "%s stylesheet %s" logmsg key);
 110           (try per_key_action key with e -> logger#log (Printexc.to_string e));
 111           logger#log (sprintf "Done! (stylesheet %s)" key))
 112         keys
 113 ;;
 114
 115   (** parse parameters for '/apply' action *)
 116 let parse_apply_params =
 117   let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
 118   let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
 119   let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
 120   List.fold_left
 121     (fun (old_params, old_properties) (name, value) ->
 122       match name with
 123       | name when is_global_param name ->
 124           let name = Pcre.replace ~pat:"^param\\." name in
 125           ((fun x -> (old_params x) @ [name, value]), old_properties)
 126       | name when is_local_param name ->
 127           let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
 128           let (key, name) = (pieces.(1), pieces.(2)) in
 129           ((function
 130             | x when x = key -> [name, value] @ (old_params x)
 131             | x -> old_params x),
 132            old_properties)
 133       | name when is_property name ->
 134           let name = Pcre.replace ~pat:"^prop\\." name in
 135           (old_params, ((name, value) :: old_properties))
 136       | _ -> (old_params, old_properties))
 137     ((fun _ -> []), []) (* no parameters, no properties *)
 138 ;;
 139
 140   (** Parse libxslt's message modes for error and debugging messages. Default is
 141   to ignore mesages of both kind *)
 142 let parse_libxslt_msgs_mode (req: Http_types.request) =
 143   ((try
 144     (match req#param "errormode" with
 145     | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore
 146     | s when String.lowercase s = "comment" -> LibXsltMsgComment
 147     | s when String.lowercase s = "embed" -> LibXsltMsgEmbed
 148     | err ->
 149         raise (Uwobo_failure
 150           (sprintf
 151             "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'"
 152             err "errormode" "ignore" "comment")))
 153   with Http_types.Param_not_found _ -> LibXsltMsgIgnore),
 154   (try
 155     (match req#param "debugmode" with
 156     | s when String.lowercase s = "ignore" -> LibXsltMsgIgnore
 157     | s when String.lowercase s = "comment" -> LibXsltMsgComment
 158     | s when String.lowercase s = "embed" -> LibXsltMsgEmbed
 159     | err ->
 160         raise (Uwobo_failure
 161           (sprintf
 162             "Unknown value '%s' for parameter '%s', use one of '%s' or '%s'"
 163             err "debugmode" "ignore" "comment")))
 164   with Http_types.Param_not_found _ -> LibXsltMsgIgnore))
 165 ;;
 166
 167   (** send ~cmd (without trailing "\n"!) through ~cmd_pipe, then wait for answer
 168   on ~res_pipe (with a timeout of 60 seconds) and send over outchan data
 169   received from ~res_pipe *)
 170 let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
 171 (*   debug_print (sprintf "Sending command '%s' to grandparent ..." cmd); *)
 172   output_string cmd_pipe (cmd ^ "\n");  (* send command to grandfather *)
 173   flush cmd_pipe;
 174   let res_pipe_fd = Unix.descr_of_in_channel res_pipe in
 175   let (read_fds, _, _) =  (* wait for an answer *)
 176     Unix.select [res_pipe_fd] [] [] 60.0
 177   in
 178   (match read_fds with
 179   | [fd] when fd = res_pipe_fd -> (* send answer to http client *)
 180       Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
 181       Http_daemon.send_header "Content-Type" "text/html" outchan;
 182       Http_daemon.send_CRLF outchan;
 183       (try
 184         while true do
 185           output_string outchan ((input_line res_pipe) ^ "\n")
 186         done
 187       with End_of_file -> flush outchan)
 188   | _ ->  (* no answer received from grandfather *)
 189       return_error "Timeout!" outchan)
 190 ;;
 191
 192 let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE, kill_cmd_RE,
 193      createprofile_cmd_RE, removeprofile_cmd_RE, setprofileparam_cmd_RE,
 194      setpassword_cmd_RE, setpermission_cmd_RE) =
 195   (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ",
 196    Pcre.regexp "^kill", Pcre.regexp "^createprofile ", Pcre.regexp "^removeprofile ",
 197    Pcre.regexp "^setprofileparam ", Pcre.regexp "^setpassword ", Pcre.regexp "^setpermission ")
 198 ;;
 199
 200   (** raised by child processes when HTTP daemon process have to be restarted *)
 201 exception Restart_HTTP_daemon ;;
 202
 203   (** log a list of libxslt's messages using a processing logger *)
 204 let log_libxslt_msgs logger libxslt_logger =
 205   List.iter
 206     (function
 207       | (LibXsltErrorMsg _) as msg -> logger#logBold (string_of_xslt_msg msg)
 208       | (LibXsltDebugMsg _) as msg -> logger#logEmph (string_of_xslt_msg msg))
 209     libxslt_logger#msgs
 210 ;;
 211
 212   (* LibXSLT logger *)
 213 let veillogger = new Uwobo_common.libXsltLogger ;;
 214
 215   (* start_new_session cmd_pipe_exit res_pipe_entrance outchan port logfile
 216   @param cmd_pipe Pipe to be closed before forking
 217   @param res_pipe Pipe to be closed before forking
 218   @param outchan  To be closed before forking
 219   @param port The port to be used
 220   @param logfile The logfile to redirect the stdout and sterr to
 221   *)
 222   (* It can raise Failure "Connection refused" *)
 223   (* It can raise Failure "Port already in use" *)
 224 let start_new_session cmd_pipe res_pipe outchan port logfile =
 225  (* Let's check that the port is free *)
 226  (try
 227    ignore
 228     (Http_client.http_get
 229       ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ;
 230    raise (Failure "Port already in use")
 231   with
 232    Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> ()
 233  ) ;
 234  match Unix.fork () with
 235     0 ->
 236       Unix.handle_unix_error
 237        (function () ->
 238          (* 1. We close all the open pipes to avoid duplicating them *)
 239          Unix.close (Unix.descr_of_out_channel cmd_pipe) ;
 240          Unix.close (Unix.descr_of_in_channel res_pipe) ;
 241          Unix.close (Unix.descr_of_out_channel outchan) ;
 242          (* 2. We redirect stdout and stderr to the logfile *)
 243          Unix.close Unix.stdout ;
 244          assert
 245           (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
 246             0o664 = Unix.stdout) ;
 247          Unix.close Unix.stderr ;
 248          assert
 249           (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
 250             0o664 = Unix.stderr) ;
 251          prerr_endline "***** Starting a new session" ;
 252
 253          (* 3. We set up a new environment *)
 254          let environment =
 255           (* Here I am loosing the current value of port_env_var; *)
 256           (* this should not matter                               *)
 257           Unix.putenv "UWOBO__PORT" (string_of_int port) ;
 258           Unix.environment ()
 259          in
 260          (* 4. We exec a new copy of uwobo *)
 261          Unix.execve Sys.executable_name [||] environment ;
 262          (* It should never reach this point *)
 263          assert false
 264        ) ()
 265   | child when child > 0 ->
 266      (* let's check if the new UWOBO started correctly *)
 267      Unix.sleep 5 ;
 268      (* It can raise Failure "Connection refused" *)
 269      (try
 270        ignore
 271          (Http_client.http_get
 272            ("http://127.0.0.1:" ^ string_of_int port ^ "/help"))
 273      with Unix.Unix_error (Unix.ECONNREFUSED, _, _) ->
 274        raise (Failure "Connection refused"))
 275   | _ -> failwith "Can't fork :-("
 276 ;;
 277
 278   (* request handler action
 279   @param syslogger Uwobo_logger.sysLogger instance used for logginf
 280   @param styles Uwobo_styles.styles instance which keeps the stylesheets list
 281   @param cmd_pipe output _channel_ used to _write_ update messages
 282   @param res_pipe input _channel_ used to _read_ grandparent results
 283   @param req http request instance
 284   @param outchan output channel connected to http client
 285   *)
 286 let callback
 287   ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan
 288   =
 289   try
 290     syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
 291     syslogger#log `Debug (sprintf "Received request: %s" req#path);
 292     (match req#path with
 293     | "/add" ->
 294         (let bindings = req#paramAll "bind" in
 295         if bindings = [] then
 296           return_error "No [key,stylesheet] binding provided" outchan
 297         else begin
 298           let cmd = sprintf "add %s" (String.concat ";" bindings) in
 299           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 300         end)
 301     | "/kill" ->
 302         let logger = new Uwobo_logger.processingLogger () in
 303          logger#log "Exiting" ;
 304          respond_html logger#asHtml outchan ;
 305          let cmd = "kill" in
 306           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 307     | "/newsession" ->
 308         let logger = new Uwobo_logger.processingLogger () in
 309         let port = int_of_string (req#param "port") in
 310         let logfile = logfilename_of_port port in
 311         (try
 312           start_new_session cmd_pipe res_pipe outchan port logfile ;
 313           logger#log (sprintf "New session started: port = %d" port) ;
 314           respond_html logger#asHtml outchan
 315          with
 316             Failure "int_of_string" ->
 317              logger#log (sprintf "Invalid port number") ;
 318              respond_html logger#asHtml outchan
 319           | Failure "Port already in use" ->
 320              Uwobo_common.return_error "port already in use" outchan
 321           | Failure "Connection refused" ->
 322              let log = ref [] in
 323               (try
 324                 let ch = open_in logfile in
 325                  while true do log := (input_line ch ^ "\n") :: !log ; done
 326                with
 327                   Sys_error _
 328                 | End_of_file -> ()
 329               ) ;
 330               let rec get_last_lines acc =
 331                function
 332                   (n,he::tl) when n > 0 ->
 333                     get_last_lines (he ^ "<br />" ^ acc) (n-1,tl)
 334                 | _ -> acc
 335               in
 336                (* we just show the last 10 lines of the log file *)
 337                let msg =
 338                 (if List.length !log > 0 then "<br />...<br />" else "<br />") ^
 339                  get_last_lines "" (10,!log)
 340                in
 341                 Uwobo_common.return_error "daemon not initialized"
 342                  ~body:msg outchan)
 343     | "/remove" ->
 344           let cmd = sprintf "remove %s" (req#param "keys") in
 345           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 346     | "/reload" ->
 347           let cmd = sprintf "reload %s" (req#param "keys") in
 348           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 349     | "/list" ->
 350         (let logger = new Uwobo_logger.processingLogger () in
 351         (match styles#list with
 352         | [] -> logger#log "No stylesheets loaded (yet)!"
 353         | l ->
 354             logger#log "Stylesheets list:";
 355             List.iter (fun s -> logger#log s) l);
 356         respond_html logger#asHtml outchan)
 357     | "/listprofiles" ->
 358         let profile_list = Uwobo_profiles.list () in
 359         respond_html ("<html><body><ul>" ^ String.concat "" (List.map (fun s -> "<li>" ^ s ^ "</li>") profile_list) ^ "</ul></body></html>") outchan
 360     | "/createprofile" ->
 361         let cmd = sprintf "createprofile %s,%s,%s,%s,%s,%s,%s"
 362                     (string_of_param_option req "id")
 363                     (string_of_param_option req "orig")
 364                     (string_of_param_option req "origpassword")
 365                     (string_of_param_option req "readperm")
 366                     (string_of_param_option req "writeperm")
 367                     (string_of_param_option req "adminperm")
 368                     (string_of_param_option req "password")
 369         in
 370           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 371     | "/removeprofile" ->
 372         let cmd = sprintf "removeprofile %s,%s"
 373                     (req#param "id")
 374                     (string_of_param_option req "password")
 375         in
 376           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 377     | "/setprofileparam" ->
 378         let cmd = sprintf "setprofileparam %s,%s,%s,%s"
 379                     (string_of_param_option req "id")
 380                     (string_of_param_option req "password")
 381                     (req#param "key")
 382                     (string_of_param_option req "value")
 383         in
 384           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 385     | "/setpassword" ->
 386         let cmd = sprintf "setpassword %s,%s,%s"
 387                     (req#param "id")
 388                     (string_of_param_option req "password")
 389                     (string_of_param_option req "oldpassword")
 390         in
 391           short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 392     | "/setpermission" ->
 393         begin
 394           match req#param "for" with
 395               "read"
 396             | "write"
 397             | "admin" as forwhat ->
 398                 let cmd = sprintf "setpermission %s,%s,%s,%s"
 399                             (req#param "id")
 400                             (string_of_param_option req "password")
 401                             forwhat
 402                             (req#param "value")
 403                 in
 404                   short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
 405             | _ -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan
 406         end
 407     | "/getparams" ->
 408         let pid = req#param "id" in
 409         let password = try Some (req#param "password") with _ -> None in
 410         let res = Uwobo_profiles.get_params pid ?password () in
 411         respond_html
 412          ("<html><body><ul>" ^
 413           String.concat "" (List.map (fun k,v -> "<li>" ^ k ^ " = " ^ v  ^ "</li>") res) ^
 414           "</ul></body></html>") outchan
 415     | "/getparam" ->
 416         let pid = req#param "id" in
 417         let password = try Some (req#param "password") with _ -> None in
 418         let key = req#param "key" in
 419         let value = Uwobo_profiles.get_param pid ?password ~key () in
 420         respond_html ("<html><body>" ^ value ^ "</body></html>") outchan
 421     | "/getpermission" ->
 422         let pid = req#param "id" in
 423         let password = try Some (req#param "password") with _ -> None in
 424         let forwhat =
 425          match req#param "for" with
 426             "read" -> Some `Read
 427           | "write" -> Some `Write
 428           | "admin" -> Some `Admin
 429           | _ -> None
 430         in
 431          begin
 432           match forwhat with
 433              Some forwhat ->
 434               let value = Uwobo_profiles.get_permission pid ?password forwhat in
 435               respond_html ("<html><body>" ^ (if value then "true" else "false") ^ "</body></html>") outchan
 436            | None -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan ;
 437          end
 438     | "/apply" ->
 439         let logger = new Uwobo_logger.processingLogger () in
 440         veillogger#clearMsgs;
 441         let profile = try Some (req#param "profile") with _ -> None in
 442         let password = try Some (req#param "password") with _ -> None in
 443         let xmluri = req#param "xmluri" in
 444         let keys = Pcre.split ~pat:"," (req#param "keys") in
 445         (* notation: "local" parameters are those defined on a per-stylesheet
 446         pasis (i.e. param.key.param=value), "global" parameters are those
 447         defined for all stylesheets (i.e. param.param=value) *)
 448         let (user_params, props) = parse_apply_params req#params in
 449         let profile_params =
 450          match profile with
 451             None -> []
 452           | Some profile -> Uwobo_profiles.get_params profile ?password () in
 453         let params =
 454          (* user provided parameters override the profile parameters *)
 455          let is_global_param x = Pcre.pmatch ~pat:"^(\\.[^.]+){1}$" ("." ^ x) in
 456          let is_local_param x = Pcre.pmatch ~pat:"^(\\.[^.]+){2}$" ("." ^ x) in
 457          let add key value params =
 458           if List.mem_assoc key params then params else params @ [key,value]
 459          in
 460           List.fold_left
 461             (fun old_params (name, value) ->
 462               match name with
 463               | name when is_global_param name ->
 464                  (fun x -> add name value (old_params x))
 465               | name when is_local_param name ->
 466                  let pieces = Pcre.extract ~pat:"^([^.]+)\\.(.*)" name in
 467                  let (key, name) = (pieces.(1), pieces.(2)) in
 468                   (function
 469                     | x when x = key -> add name value (old_params x)
 470                     | x -> old_params x)
 471               | _ -> assert false)
 472             user_params profile_params
 473         in
 474         let (libxslt_errormode, libxslt_debugmode) =
 475           parse_libxslt_msgs_mode req
 476         in
 477         syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
 478         let domImpl = Gdome.domImplementation () in
 479         let input = domImpl#createDocumentFromURI ~uri:xmluri () in
 480         syslogger#log `Debug "Applying stylesheet chain ...";
 481         (try
 482           let (write_result, media_type, encoding) = (* out_channel -> unit *)
 483             Uwobo_engine.apply
 484               ~logger:syslogger ~styles ~keys ~params ~props ~veillogger
 485               ~errormode:libxslt_errormode ~debugmode:libxslt_debugmode
 486               input
 487           in
 488           let content_type = (* value of Content-Type HTTP response header *)
 489             sprintf "%s; charset=%s"
 490               (match media_type with None -> get_media_type props | Some t -> t)
 491               (match encoding with None -> get_encoding props | Some e -> e)
 492           in
 493           syslogger#log `Debug
 494             (sprintf "sending output to client (Content-Type: %s)...."
 495               content_type);
 496           Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
 497           Http_daemon.send_header "Content-Type" content_type outchan;
 498           Http_daemon.send_CRLF outchan;
 499           write_result outchan
 500         with Uwobo_failure errmsg ->
 501           return_error
 502             ("Stylesheet chain application failed: " ^ errmsg)
 503             ~body: ("<h2>LibXSLT's messages:</h2>" ^
 504               String.concat "<br />\n"
 505                 (List.map string_of_xslt_msg veillogger#msgs))
 506             outchan)
 507     | "/help" -> respond_html usage_string outchan
 508     | invalid_request ->
 509         Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan);
 510     syslogger#log `Debug (sprintf "%s done!" req#path);
 511   with
 512   | Http_types.Param_not_found attr_name ->
 513       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 514   | exc ->
 515       return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan
 516 ;;
 517
 518   (* UWOBO's startup *)
 519 let main () =
 520     (* (1) system logger *)
 521   let logger_outchan =
 522    debug_print (sprintf "Logging to file %s" logfile);
 523    open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm logfile
 524   in
 525   let syslogger =
 526     new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan ()
 527   in
 528   syslogger#enable;
 529     (* (2) stylesheets list *)
 530   let styles = new Uwobo_styles.styles in
 531     (* (3) clean up actions *)
 532   let last_process = ref true in
 533   let http_child = ref None in
 534   let die_nice () = (** at_exit callback *)
 535     if !last_process then begin
 536       (match !http_child with
 537       | None -> ()
 538       | Some pid -> Unix.kill pid Sys.sigterm);
 539       syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name);
 540       syslogger#disable;
 541       close_out logger_outchan
 542     end
 543   in
 544   at_exit die_nice;
 545   ignore (Sys.signal Sys.sigterm
 546     (Sys.Signal_handle (fun _ -> raise Sys.Break)));
 547   syslogger#log `Notice
 548     (sprintf "%s started and listening on port %d" daemon_name port);
 549   syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
 550   Unix.putenv "http_proxy" "";  (* reset http_proxy to avoid libxslt problems *)
 551   while true do
 552     let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in
 553     let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in
 554     match Unix.fork () with
 555     | child when child > 0 -> (* (4) parent: listen on cmd pipe for updates *)
 556         http_child := Some child;
 557         let stop_http_daemon () =  (* kill child *)
 558           debug_print (sprintf "UWOBOmaster: killing pid %d" child);
 559           Unix.kill child Sys.sigterm;  (* kill child ... *)
 560           ignore (Unix.waitpid [] child);  (* ... and its zombie *)
 561         in
 562         Unix.close cmd_pipe_entrance;
 563         Unix.close res_pipe_exit;
 564         let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in
 565         let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in
 566         (try
 567           while true do
 568             (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after
 569             child process has been killed *)
 570             debug_print "UWOBOmaster: waiting for commands ...";
 571             let cmd = input_line cmd_pipe in
 572             debug_print (sprintf "UWOBOmaster: received %s command" cmd);
 573             (match cmd with  (* command from grandchild *)
 574             | "test" ->
 575                 stop_http_daemon ();
 576                 output_string res_pipe "UWOBOmaster: Hello, world!\n";
 577                 flush res_pipe;
 578                 raise Restart_HTTP_daemon
 579             | line when Pcre.pmatch ~rex:kill_cmd_RE line -> (* /kill *)
 580                 exit 0
 581             | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *)
 582                 let bindings =
 583                   Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line)
 584                 in
 585                 stop_http_daemon ();
 586                 let logger = new Uwobo_logger.processingLogger () in
 587                 List.iter
 588                   (fun binding -> (* add a <key, stylesheet> binding *)
 589                     let pieces = Pcre.split ~pat:"," binding in
 590                     match pieces with
 591                     | [key; style] ->
 592                         logger#log (sprintf "adding binding <%s,%s>" key style);
 593                         veillogger#clearMsgs;
 594                         (try
 595                           veillogger#clearMsgs;
 596                           styles#add key style;
 597                           log_libxslt_msgs logger veillogger;
 598                         with e ->
 599                           logger#log (Printexc.to_string e))
 600                     | _ -> logger#log (sprintf "invalid binding %s" binding))
 601                   bindings;
 602                 output_string res_pipe logger#asHtml;
 603                 flush res_pipe;
 604                 raise Restart_HTTP_daemon
 605             | line when Pcre.pmatch ~rex:remove_cmd_RE line ->  (* /remove *)
 606                 stop_http_daemon ();
 607                 let arg = Pcre.replace ~rex:remove_cmd_RE line in
 608                 let logger = new Uwobo_logger.processingLogger () in
 609                 veillogger#clearMsgs;
 610                 act_on_keys
 611                   arg styles logger
 612                   styles#remove (fun () -> styles#removeAll) styles#keys
 613                   "removing";
 614                 log_libxslt_msgs logger veillogger;
 615                 output_string res_pipe (logger#asHtml);
 616                 raise Restart_HTTP_daemon
 617             | line when Pcre.pmatch ~rex:reload_cmd_RE line ->  (* /reload *)
 618                 stop_http_daemon ();
 619                 let arg = Pcre.replace ~rex:reload_cmd_RE line in
 620                 let logger = new Uwobo_logger.processingLogger () in
 621                 veillogger#clearMsgs;
 622                 act_on_keys
 623                   arg styles logger
 624                   styles#reload (fun () -> styles#reloadAll) styles#keys
 625                   "reloading";
 626                 output_string res_pipe (logger#asHtml);
 627                 raise Restart_HTTP_daemon
 628             | line when Pcre.pmatch ~rex:createprofile_cmd_RE line -> (* /createprofile *)
 629               stop_http_daemon ();
 630               let params =
 631                 List.map string_option_of_string (Pcre.split ~pat:"," (Pcre.replace ~rex:createprofile_cmd_RE line))
 632               in
 633                 begin
 634                   match params with
 635                       [id; clone; clone_password; read_perm; write_perm; admin_perm; password] ->
 636                         let bool_option_of_string_option =
 637                           function
 638                               Some "true" -> Some true
 639                             | Some _ -> Some false
 640                             | None -> None
 641                         in
 642                         let pid =
 643                           Uwobo_profiles.create
 644                             ?id
 645                             ?clone
 646                             ?clone_password
 647                             ?read_perm:(bool_option_of_string_option read_perm)
 648                             ?write_perm:(bool_option_of_string_option write_perm)
 649                             ?admin_perm:(bool_option_of_string_option admin_perm)
 650                             ?password
 651                             ()
 652                         in
 653                           output_string res_pipe ("Profile " ^ pid ^ " created. Hi " ^ pid) ;
 654                           raise Restart_HTTP_daemon
 655                     | _ -> assert false
 656                 end
 657             | line when Pcre.pmatch ~rex:removeprofile_cmd_RE line -> (* /removeprofile *)
 658               stop_http_daemon ();
 659               let pid, password =
 660                 match Pcre.split ~pat:"," (Pcre.replace ~rex:removeprofile_cmd_RE line) with
 661                     [pid; password] -> pid, (string_option_of_string password)
 662                   | _ -> assert false
 663               in
 664                 Uwobo_profiles.remove pid ?password () ;
 665                 output_string res_pipe "Done" ;
 666                 raise Restart_HTTP_daemon
 667             | line when Pcre.pmatch ~rex:setprofileparam_cmd_RE line -> (* /setprofileparam *)
 668               stop_http_daemon ();
 669               let pid, password, key, value =
 670                 match Pcre.split ~pat:"," (Pcre.replace ~rex:setprofileparam_cmd_RE line) with
 671                     [pid; password; key; value] ->
 672                       pid, (string_option_of_string password), key, (string_option_of_string value)
 673                   | _ -> assert false
 674               in
 675                 Uwobo_profiles.set_param pid ?password ~key ~value () ;
 676                 output_string res_pipe "Done" ;
 677                 raise Restart_HTTP_daemon
 678             | line when Pcre.pmatch ~rex:setpassword_cmd_RE line -> (* /setpassword *)
 679               stop_http_daemon ();
 680               let pid, old_password, password =
 681                 match Pcre.split ~pat:"," (Pcre.replace ~rex:setpassword_cmd_RE line) with
 682                     [pid; old_password; password] ->
 683                       pid, (string_option_of_string old_password), (string_option_of_string password)
 684                   | _ -> assert false
 685               in
 686                 Uwobo_profiles.set_password pid ?old_password password ;
 687                 output_string res_pipe "Done" ;
 688                 raise Restart_HTTP_daemon
 689             | line when Pcre.pmatch ~rex:setpermission_cmd_RE line -> (* /setpermission *)
 690               stop_http_daemon ();
 691               let permission_of_string =
 692                 function
 693                     "read" -> `Read
 694                   | "write" -> `Write
 695                   | "admin" -> `Admin
 696                   | _ -> assert false
 697               and bool_of_string s = "true" = s
 698               in
 699               let pid, password, forwhat, value =
 700                 match Pcre.split ~pat:"," (Pcre.replace ~rex:setpermission_cmd_RE line) with
 701                     [pid; password; forwhat; value] ->
 702                       pid, (string_option_of_string password), (permission_of_string forwhat), (bool_of_string value)
 703                   | _ -> assert false
 704               in
 705                 Uwobo_profiles.set_permission pid ?password forwhat value ;
 706                 output_string res_pipe "Done" ;
 707                 raise Restart_HTTP_daemon
 708             | cmd ->  (* invalid interprocess command received *)
 709                 syslogger#log `Warning
 710                   (sprintf "Ignoring invalid interprocess command: '%s'" cmd))
 711           done
 712         with
 713            Restart_HTTP_daemon ->
 714             close_in cmd_pipe;  (* these calls close also fds *)
 715             close_out res_pipe
 716          | e -> (* Should we return a 404 error here? Maybe... (how?) *)
 717             output_string res_pipe (Printexc.to_string e);
 718             close_in cmd_pipe;  (* these calls close also fds *)
 719             close_out res_pipe)
 720     | 0 ->  (* (5) child: serve http requests *)
 721         Unix.close cmd_pipe_exit;
 722         Unix.close res_pipe_entrance;
 723         last_process := false;
 724         let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in
 725         let res_pipe = Unix.in_channel_of_descr res_pipe_exit in
 726         debug_print (sprintf "Starting HTTP daemon on port %d ..." port);
 727           (* next invocation doesn't return, process will keep on serving HTTP
 728           requests until it will get killed by father *)
 729         Http_daemon.start'~port ~mode:`Fork
 730           (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ())
 731     | _ (* < 0 *) ->  (* fork failed :-((( *)
 732         failwith "Can't fork :-("
 733   done
 734 ;;
 735
 736   (* daemon initialization *)
 737 try
 738   Sys.catch_break true;
 739   main ()
 740 with Sys.Break -> ()  (* 'die_nice' registered with at_exit *)
 741 ;;
 742