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