]> matita.cs.unibo.it Git - helm.git/commitdiff
MAJOR CHANGES:
authorStefano Zacchiroli <zack@upsilon.cc>
Fri, 17 Jan 2003 15:10:28 +0000 (15:10 +0000)
committerStefano Zacchiroli <zack@upsilon.cc>
Fri, 17 Jan 2003 15:10:28 +0000 (15:10 +0000)
- doesn't use thread anymore, use process with a master process which
  uses two pipes to chat about stylesheets related changes, if the
  stylesheet list needs a change master process kills the child process
  holding the Http daemon, performs the needed changes to the stylesheet
  list and runs a new Http daemon child process
MINOR CHANGES:
- disabled debugging by default
- use logfile support and log to "uwobo.log" by default
- changed default port to 58080
- moved http response facilities to Uwobo_common
- moved usage string to Uwobo_common
- fixed copyright notice

helm/uwobo/src/ocaml/uwobo.ml

index c99b4907c9573929c7f16b6d3a67a188b5068ac4..72f1c08e76cc30a6a8571963497edc432f8566bc 100644 (file)
@@ -1,45 +1,45 @@
-
-(* Copyright (C) 2002, HELM Team.
- * 
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- * 
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- * 
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
- * GNU General Public License for more details.
+(*
+ * Copyright (C) 2003:
+ *    Stefano Zacchiroli <zack@cs.unibo.it>
+ *    for the HELM Team http://helm.cs.unibo.it/
+ *
+ *  This file is part of HELM, an Hypertextual, Electronic
+ *  Library of Mathematics, developed at the Computer Science
+ *  Department, University of Bologna, Italy.
+ *
+ *  HELM is free software; you can redistribute it and/or
+ *  modify it under the terms of the GNU General Public License
+ *  as published by the Free Software Foundation; either version 2
+ *  of the License, or (at your option) any later version.
+ *
+ *  HELM is distributed in the hope that it will be useful,
+ *  but WITHOUT ANY WARRANTY; without even the implied warranty of
+ *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ *  GNU General Public License for more details.
  *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA  02111-1307, USA.
- * 
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
+ *  You should have received a copy of the GNU General Public License
+ *  along with HELM; if not, write to the Free Software
+ *  Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ *  MA  02111-1307, USA.
+ *
+ *  For details, see the HELM World-Wide-Web page,
+ *  http://helm.cs.unibo.it/
  *)
 
-(* TODO braindead situation: /add of a stylesheet which uri is an uwobo
-invocation *)
-
 open Printf;;
 open Uwobo_common;;
 
  (* debugging settings *)
-let debug = true;;
+let debug = false;;
 let debug_level = `Debug;;
 let debug_print s = if debug then prerr_endline s;;
-let http_debug = false;;
-Http_common.debug := http_debug;;
+Http_common.debug := false;;
+let logfile = Some "uwobo.log";;  (* relative to execution dir *)
+let logfile_perm = 0o644;;
 
-  (* environment settings *)
+  (* other settings *)
 let daemon_name = "UWOBO OCaml";;
-let default_port = 8082;;
+let default_port = 58080;;
 let port_env_var = "UWOBO_PORT";;
 let default_media_type = "text/html";;
 let default_encoding = "utf8";;
@@ -50,128 +50,98 @@ let port =
   | Not_found -> default_port
   | Failure "int_of_string" ->
       prerr_endline "Warning: invalid port, reverting to default";
-      default_port
-in
+      default_port;;
 
-  (* facilities *)
-let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>" in
-let return_error msg outchan =
-  (* return an ok (200) http response, which display in html an error message *)
-  Http_daemon.respond ~body:(pp_error msg) outchan
-in
-let bad_request body outchan =  (* return a bad request http response *)
-  Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan
-in
+  (** perform an 'action' that can be applied to a list of keys or, if no keys
+  was given, to all keys *)
+let act_on_keys keys_param styles outchan per_key_action all_keys_action logmsg
+=
+  let log = new Uwobo_logger.processingLogger () in
+  let keys =
+    try
+      Pcre.split ~pat:"," keys_param
+    with Http_types.Param_not_found _ -> []
+  in
+  (match keys with
+  | [] -> (* no key provided, act on all stylesheets *)
+      log#log "reloading all stylesheets ...";
+      (try all_keys_action () with e -> log#log (Printexc.to_string e))
+  | keys ->
+      List.iter
+        (fun key -> (* act on a single stylesheet *)
+          log#log (sprintf "%s stylesheet %s" logmsg key);
+          (try per_key_action key with e -> log#log (Printexc.to_string e)))
+        keys);
+  output_string outchan log#asHtml;
+  flush outchan
+;;
 
-  (* values common to all threads *)
-let syslogger = new Uwobo_logger.sysLogger ~level:debug_level () in
-syslogger#enable;
-let styles = new Uwobo_styles.styles in
-let usage_string =
-  sprintf
-"
-<html>
-  <head>
-    <title>UWOBO's help message</title>
-  </head>
-  <body>
-    <p>
-    Usage: <kbd>http://hostname:uwoboport/</kbd><em>command</em>
-    </p>
-    <p>
-    Available commands:
-    </p>
-    <p>
-      <b><kbd>help</kbd></b><br />
-      display this help message
-    </p>
-    <p>
-      <b><kbd>add?bind=key,uri[&bind=key,stylesheet[&...]]</kbd></b><br />
-      load a new stylesheet, specified by <em>uri</em>, and bind it to key
-          <em>key</em>
-    </p>
-    <p>
-      <b><kbd>remove?[?keys=key1,key2,...]</kbd></b><br />
-      unload stylesheets specified by <em>key1, key2, ...</em> or all
-          stylesheets if no key was given
-    </p>
-    <p>
-      <b><kbd>reload?[?keys=key1,key2,...]</kbd></b><br />
-      reload stylesheets specified by <em>key1, key2, ...</em> or all
-          stylesheets if no key was given
-    </p>
-    <p>
-      <b><kbd>list</kbd></b><br />
-      return a list of loaded stylesheets
-    </p>
-    <p>
-      <b><kbd>apply?xmluri=uri&keys=key1,key2,...[&param.name=value[&param.name=value[&...]]][&param.key.name=value[&param.key.name=value[&...]]][&name[=value][&prop.name[=value][&...]]]</kbd></b><br />
-      apply a chain of stylesheets, specified by <em>key1, key2, ...</em>, to an
-      input document, specified by <em>uri</em>.<br />
-      Additional parameters can be set for each stylesheet application: global
-      parameters (i.e. parameters passed to all stylesheets) are set using
-      <em>param.name=value</em> syntax, per stylesheet parameters are set using
-      <em>param.key.name=value</em> where <em>key</em> is the key of a loaded
-      stylesheet.<br />
-      Properties of the final chain output can be set too: valueless properties
-      can be set using <em>prop.name</em> syntax, others can be set using
-      <em>prop.name=value</em> syntax.<br />
-      Current supported properties are: %s.
-    </p>
-  </body>
-</html>
-"
-  (String.concat ", " Uwobo_common.supported_properties)
-in
+  (** parse parameters for '/apply' action *)
+let parse_apply_params =
+  let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
+  let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
+  let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
+  List.fold_left
+    (fun (old_params, old_properties) (name, value) ->
+      match name with
+      | name when is_global_param name ->
+          let name = Pcre.replace ~pat:"^param\\." name in
+          ((fun x -> (old_params x) @ [name, value]), old_properties)
+      | name when is_local_param name ->
+          let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
+          let (key, name) = (pieces.(1), pieces.(2)) in
+          ((function
+            | x when x = key -> [name, value] @ (old_params x)
+            | x -> old_params x),
+           old_properties)
+      | name when is_property name ->
+          let name = Pcre.replace ~pat:"^prop\\." name in
+          (old_params, ((name, value) :: old_properties))
+      | _ -> (old_params, old_properties))
+    ((fun _ -> []), []) (* no parameters, no properties *)
+;;
 
-  (* thread action *)
-let callback (req: Http_types.request) outchan =
-    (* perform an 'action' that can be applied to a list of keys or, if no
-    keys was given, to all keys *)
-  let act_on_keys (req: Http_types.request)
-    styles outchan per_key_action all_keys_action logmsg
-    =
-    let log = new Uwobo_logger.processingLogger () in
-    let keys =
-      try
-        Pcre.split ~pat:"," (req#param "keys")
-      with Http_types.Param_not_found _ -> []
-    in
-    (match keys with
-    | [] -> (* no key provided, act on all stylesheets *)
-        log#log "reloading all stylesheets ...";
-        (try all_keys_action () with e -> log#log (Printexc.to_string e))
-    | keys ->
-        List.iter
-          (fun key -> (* act on a single stylesheet *)
-            log#log (sprintf "%s stylesheet %s" logmsg key);
-            (try per_key_action key with e -> log#log (Printexc.to_string e)))
-          keys);
-    Http_daemon.respond ~body:log#asHtml outchan
-  in
-  let parse_apply_params =  (* parse parameters for '/apply' action *)
-    let is_global_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){1}$" x in
-    let is_local_param x = Pcre.pmatch ~pat:"^param(\\.[^.]+){2}$" x in
-    let is_property x = Pcre.pmatch ~pat:"^prop\\.[^.]+$" x in
-    List.fold_left
-      (fun (old_params, old_properties) (name, value) ->
-        match name with
-        | name when is_global_param name ->
-            let name = Pcre.replace ~pat:"^param\\." name in
-            ((fun x -> (old_params x) @ [name, value]), old_properties)
-        | name when is_local_param name ->
-            let pieces = Pcre.extract ~pat:"^param\\.([^.]+)\\.(.*)" name in
-            let (key, name) = (pieces.(1), pieces.(2)) in
-            ((function
-              | x when x = key -> [name, value] @ (old_params x)
-              | x -> old_params x),
-             old_properties)
-        | name when is_property name ->
-            let name = Pcre.replace ~pat:"^prop\\." name in
-            (old_params, ((name, value) :: old_properties))
-        | _ -> (old_params, old_properties))
-      ((fun _ -> []), []) (* no parameters, no properties *)
+  (** send ~cmd (without trailing "\n"!) through ~cmd_pipe, then wait for answer
+  on ~res_pipe (with a timeout of 60 seconds) and send over outchan data
+  received from ~res_pipe *)
+let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan =
+  debug_print (sprintf "Sending command '%s' to grandparent ..." cmd);
+  output_string cmd_pipe (cmd ^ "\n");  (* send command to grandfather *)
+  flush cmd_pipe;
+  let res_pipe_fd = Unix.descr_of_in_channel res_pipe in
+  let (read_fds, _, _) =  (* wait for an answer *)
+    Unix.select [res_pipe_fd] [] [] 60.0
   in
+  (match read_fds with
+  | [fd] when fd = res_pipe_fd -> (* send answer to http client *)
+      Http_daemon.send_basic_headers ~code:200 outchan;
+      Http_daemon.send_CRLF outchan;
+      (try
+        while true do
+          output_string outchan ((input_line res_pipe) ^ "\n")
+        done
+      with End_of_file -> flush outchan)
+  | _ ->  (* no answer received from grandfather *)
+      return_error "Timeout!" outchan)
+;;
+
+let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE) =
+  (Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ")
+;;
+
+exception Restart_HTTP_daemon;;
+
+  (* thread action
+  @param syslogger Uwobo_logger.sysLogger instance used for logginf
+  @param styles Uwobo_styles.styles instance which keeps the stylesheets list
+  @param cmd_pipe output _channel_ used to _write_ update messages
+  @param res_pipe input _channel_ used to _read_ grandparent results
+  @param req http request instance
+  @param outchan output channel connected to http client
+  *)
+let callback
+  ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan
+  =
   try
     syslogger#log `Notice (sprintf "Connection from %s" req#clientAddr);
     syslogger#log `Debug (sprintf "Received request: %s" req#path);
@@ -181,72 +151,60 @@ let callback (req: Http_types.request) outchan =
         if bindings = [] then
           return_error "No [key,stylesheet] binding provided" outchan
         else begin
-          let log = new Uwobo_logger.processingLogger () in
-          List.iter
-            (fun binding -> (* add a <key, stylesheet> binding *)
-              let pieces = Pcre.split ~pat:"," binding in
-              match pieces with
-              | [key; style] ->
-                  log#log (sprintf "adding binding <%s,%s>" key style);
-                  (try
-                    styles#add key style;
-                  with e ->
-                    log#log (Printexc.to_string e))
-              | _ -> log#log (sprintf "invalid binding %s" binding))
-            bindings;
-          Http_daemon.respond ~body:log#asHtml outchan
+          let cmd = sprintf "add %s" (String.concat ";" bindings) in
+          short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
         end)
+    | "/remove" ->
+          let cmd = sprintf "remove %s" (req#param "keys") in
+          short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
+    | "/reload" ->
+          let cmd = sprintf "reload %s" (req#param "keys") in
+          short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
     | "/list" ->
         (let log = new Uwobo_logger.processingLogger () in
         log#log "Stylesheet list:";
         List.iter (fun s -> log#log s) styles#list;
         Http_daemon.respond ~body:log#asHtml outchan)
-    | "/remove" ->
-        act_on_keys
-          req styles outchan
-          styles#remove (fun () -> styles#removeAll) "removing"
-    | "/reload" ->
-        act_on_keys
-          req styles outchan
-          styles#reload (fun () -> styles#reloadAll) "reloading"
     | "/apply" ->
-        if Unix.fork () = 0 then
-          (let logger = new Uwobo_logger.processingLogger () in
-          let xmluri = req#param "xmluri" in
-          let keys = Pcre.split ~pat:"," (req#param "keys") in
-          (* notation: "local" parameters are those defined on a per-stylesheet
-          pasis (i.e. param.key.param=value), "global" parameters are those
-          defined for all stylesheets (i.e. param.param=value) *)
-          let (params, props) = parse_apply_params req#params in
-          syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
-          let domImpl = Gdome.domImplementation () in
-          let input = domImpl#createDocumentFromURI ~uri:xmluri () in
-          syslogger#log `Debug "Applying stylesheet chain ...";
-          try
-            let (write_result, media_type, encoding) = (* out_channel -> unit *)
-              Uwobo_engine.apply
-                ~logger:syslogger ~styles ~keys ~input ~params ~props
-            in
-            let content_type = (* value of Content-Type HTTP response header *)
-              sprintf
-                "%s; charset=%s"
-                (match media_type with None -> default_media_type | Some t -> t)
-                (match encoding with None -> default_encoding | Some e -> e)
-            in
-            syslogger#log
-              `Debug
-              (sprintf
-                "sending output to client (Content-Type: %s)...."
-                content_type);
-            Http_daemon.send_basic_headers ~code:200 outchan;
-            Http_daemon.send_header "Content-Type" content_type outchan;
-            Http_daemon.send_CRLF outchan;
-            write_result outchan
-          with Uwobo_failure errmsg ->
-            return_error
-              (sprintf "Stylesheet chain application failed: %s" errmsg)
-              outchan)
-    | "/help" -> Http_daemon.respond ~body:usage_string outchan
+        let logger = new Uwobo_logger.processingLogger () in
+        let xmluri = req#param "xmluri" in
+        let keys = Pcre.split ~pat:"," (req#param "keys") in
+        (* notation: "local" parameters are those defined on a per-stylesheet
+        pasis (i.e. param.key.param=value), "global" parameters are those
+        defined for all stylesheets (i.e. param.param=value) *)
+        let (params, props) = parse_apply_params req#params in
+        syslogger#log `Debug (sprintf "Parsing input document %s ..." xmluri);
+        let domImpl = Gdome.domImplementation () in
+        let input = domImpl#createDocumentFromURI ~uri:xmluri () in
+        syslogger#log `Debug "Applying stylesheet chain ...";
+        (try
+          let (write_result, media_type, encoding) = (* out_channel -> unit *)
+            let res = Uwobo_engine.apply
+              ~logger:syslogger ~styles ~keys ~input ~params ~props in
+            res
+          in
+          let content_type = (* value of Content-Type HTTP response header *)
+            sprintf "%s; charset=%s"
+              (match media_type with None -> default_media_type | Some t -> t)
+              (match encoding with None -> default_encoding | Some e -> e)
+          in
+          syslogger#log `Debug
+            (sprintf "sending output to client (Content-Type: %s)...."
+              content_type);
+          Http_daemon.send_basic_headers ~code:200 outchan;
+          Http_daemon.send_header "Content-Type" content_type outchan;
+          Http_daemon.send_CRLF outchan;
+          write_result outchan
+        with Uwobo_failure errmsg ->
+          return_error
+            (sprintf "Stylesheet chain application failed: %s" errmsg)
+            outchan)
+    | "/help" ->
+        output_string cmd_pipe "test\n";
+        flush cmd_pipe;
+        debug_print
+          (sprintf "Grandchild: grandparent said '%s'" (input_line res_pipe));
+        Http_daemon.respond ~body:usage_string outchan
     | invalid_request ->
         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
     syslogger#log `Debug (sprintf "%s done!" req#path);
@@ -254,17 +212,126 @@ let callback (req: Http_types.request) outchan =
   | Http_types.Param_not_found attr_name ->
       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
   | exc ->
-      Http_daemon.respond
-        ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc)))
-       outchan
+      return_error ("Uncaught exception: " ^ (Printexc.to_string exc)) outchan
+in
+
+  (* UWOBO's startup *)
+let main () =
+    (* (1) system logger *)
+  let logger_outchan =
+    match logfile with
+    | None -> stderr
+    | Some f ->
+        open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm f
+  in
+  let syslogger =
+    new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan ()
+  in
+  syslogger#enable;
+    (* (2) stylesheets list *)
+  let styles = new Uwobo_styles.styles in
+    (* (3) clean up actions *)
+  let die_nice () = (** at_exit callback *)
+    syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name);
+    syslogger#disable;
+    close_out logger_outchan
+  in
+  syslogger#log `Notice
+    (sprintf "%s started and listening on port %d" daemon_name port);
+  syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
+  Unix.putenv "http_proxy" "";  (* reset http_proxy to avoid libxslt problems *)
+  while true do
+    let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in
+    let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in
+    match Unix.fork () with
+    | child when child > 0 -> (* (5) parent: listen on cmd pipe for updates *)
+        let stop_http_daemon () =  (* kill child *)
+          debug_print (sprintf "Grandparent: killing pid %d" child);
+          Unix.kill child Sys.sigterm;  (* kill child ... *)
+          debug_print "Grandparent: waiting for its zombie ...";
+          ignore (Unix.waitpid [] child);  (* ... and its zombie *)
+          debug_print "Grandparent: murder completed!!!"
+        in
+        at_exit die_nice;
+        Unix.close cmd_pipe_entrance;
+        Unix.close res_pipe_exit;
+        let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in
+        let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in
+        (try
+          while true do
+            (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after
+            child process has been killed *)
+            debug_print "Grandparent: waiting for commands ...";
+            let cmd = input_line cmd_pipe in
+            debug_print (sprintf "Grandparent: received %s command" cmd);
+            (match cmd with  (* command from grandchild *)
+            | "test" ->
+                debug_print "Grandparent: Hello, world!";
+                stop_http_daemon ();
+                output_string res_pipe "Grandparent: Hello, world!\n";
+                flush res_pipe;
+                raise Restart_HTTP_daemon
+            | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *)
+                let bindings =
+                  Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line)
+                in
+                stop_http_daemon ();
+                let log = new Uwobo_logger.processingLogger () in
+                List.iter
+                  (fun binding -> (* add a <key, stylesheet> binding *)
+                    let pieces = Pcre.split ~pat:"," binding in
+                    match pieces with
+                    | [key; style] ->
+                        log#log (sprintf "adding binding <%s,%s>" key style);
+                        (try
+                          styles#add key style;
+                        with e ->
+                          log#log (Printexc.to_string e))
+                    | _ -> log#log (sprintf "invalid binding %s" binding))
+                  bindings;
+                output_string res_pipe log#asHtml;
+                flush res_pipe;
+                raise Restart_HTTP_daemon
+            | line when Pcre.pmatch ~rex:remove_cmd_RE line ->  (* /remove *)
+                stop_http_daemon ();
+                let arg = Pcre.replace ~rex:remove_cmd_RE line in
+                act_on_keys
+                  arg styles res_pipe
+                  styles#remove (fun () -> styles#removeAll)
+                  "removing";
+                raise Restart_HTTP_daemon
+            | line when Pcre.pmatch ~rex:reload_cmd_RE line ->  (* /reload *)
+                stop_http_daemon ();
+                let arg = Pcre.replace ~rex:reload_cmd_RE line in
+                act_on_keys
+                  arg styles res_pipe
+                  styles#reload (fun () -> styles#reloadAll)
+                  "reloading";
+                raise Restart_HTTP_daemon
+            | cmd ->  (* invalid interprocess command received *)
+                syslogger#log `Warning
+                  (sprintf "Ignoring invalid interprocess command: '%s'" cmd))
+          done
+        with Restart_HTTP_daemon ->
+          close_in cmd_pipe;  (* these calls close also fds *)
+          close_out res_pipe;)
+    | 0 ->  (* (6) child: serve http requests *)
+        Unix.close cmd_pipe_exit;
+        Unix.close res_pipe_entrance;
+        let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in
+        let res_pipe = Unix.in_channel_of_descr res_pipe_exit in
+        debug_print "Starting HTTP daemon ...";
+        Http_daemon.start'~port ~mode:`Fork
+          (callback ~syslogger ~styles ~cmd_pipe ~res_pipe ())
+    | _ (* < 0 *) ->  (* fork failed :-((( *)
+        failwith "Can't fork :-("
+  done
 in
 
   (* daemon initialization *)
-syslogger#log
-  `Notice
-  (sprintf "%s started and listening on port %d" daemon_name port);
-syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
-Unix.putenv "http_proxy" "";  (* reset http_proxy to avoid libxslt problems *)
-Http_daemon.start' ~port ~mode:`Thread callback;
-syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name)
+try
+  Sys.catch_break true;
+  main ()
+with Sys.Break -> ()  (* 'die_nice' registered with at_exit *)
+