]> matita.cs.unibo.it Git - helm.git/blob - daemons/uwobo/uwobo.ml
added generation of quick reference card of tactic syntax
[helm.git] / 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         pasis (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 let callback
570   ~syslogger ~styles ~cmd_pipe ~res_pipe () (req: Http_types.request) outchan
571 =
572   HExtlib.finally
573     (fun () -> try close_out outchan with Sys_error _ -> ())
574     (callback ~syslogger ~styles ~cmd_pipe ~res_pipe () req) outchan
575
576   (* UWOBO's startup *)
577 let main () =
578     (* (1) system logger *)
579   let logger_outchan =
580    debug_print (sprintf "Logging to file %s" logfile);
581    open_out_gen [Open_wronly; Open_append; Open_creat] logfile_perm logfile
582   in
583   let syslogger =
584     new Uwobo_logger.sysLogger ~level:debug_level ~outchan:logger_outchan ()
585   in
586   syslogger#enable;
587     (* (2) stylesheets list *)
588   let styles = new Uwobo_styles.styles in
589     (* (3) clean up actions *)
590   let last_process = ref true in
591   let http_child = ref None in
592   let die_nice () = (** at_exit callback *)
593     if !last_process then begin
594       (match !http_child with
595       | None -> ()
596       | Some pid -> Unix.kill pid Sys.sigterm);
597       syslogger#log `Notice (sprintf "%s is terminating, bye!" daemon_name);
598       syslogger#disable;
599       close_out logger_outchan
600     end
601   in
602   at_exit die_nice;
603   ignore (Sys.signal Sys.sigterm
604     (Sys.Signal_handle (fun _ -> raise Sys.Break)));
605   syslogger#log `Notice
606     (sprintf "%s started and listening on port %d" daemon_name port);
607   syslogger#log `Notice (sprintf "current directory is %s" (Sys.getcwd ()));
608   Unix.putenv "http_proxy" "";  (* reset http_proxy to avoid libxslt problems *)
609   while true do
610     let (cmd_pipe_exit, cmd_pipe_entrance) = Unix.pipe () in
611     let (res_pipe_exit, res_pipe_entrance) = Unix.pipe () in
612     match Unix.fork () with
613     | child when child > 0 -> (* (4) parent: listen on cmd pipe for updates *)
614         http_child := Some child;
615         let stop_http_daemon () =  (* kill child *)
616           debug_print (sprintf "UWOBOmaster: killing pid %d" child);
617           Unix.kill child Sys.sigterm;  (* kill child ... *)
618           ignore (Unix.waitpid [] child);  (* ... and its zombie *)
619         in
620         Unix.close cmd_pipe_entrance;
621         Unix.close res_pipe_exit;
622         let cmd_pipe = Unix.in_channel_of_descr cmd_pipe_exit in
623         let res_pipe = Unix.out_channel_of_descr res_pipe_entrance in
624         (try
625           while true do
626             (* INVARIANT: 'Restart_HTTP_daemon' exception is raised only after
627             child process has been killed *)
628             debug_print "UWOBOmaster: waiting for commands ...";
629             let cmd = input_line cmd_pipe in
630             debug_print (sprintf "UWOBOmaster: received %s command" cmd);
631             (match cmd with  (* command from grandchild *)
632             | "test" ->
633                 stop_http_daemon ();
634                 output_string res_pipe "UWOBOmaster: Hello, world!\n";
635                 flush res_pipe;
636                 raise Restart_HTTP_daemon
637             | line when Pcre.pmatch ~rex:kill_cmd_RE line -> (* /kill *)
638                 exit 0
639             | line when Pcre.pmatch ~rex:add_cmd_RE line -> (* /add *)
640                 let bindings =
641                   Pcre.split ~pat:";" (Pcre.replace ~rex:add_cmd_RE line)
642                 in
643                 stop_http_daemon ();
644                 let logger = new Uwobo_logger.processingLogger () in
645                 List.iter
646                   (fun binding -> (* add a <key, stylesheet> binding *)
647                     let pieces = Pcre.split ~pat:"," binding in
648                     match pieces with
649                     | [key; style] ->
650                         logger#log (sprintf "adding binding <%s,%s>" key style);
651                         veillogger#clearMsgs;
652                         (try
653                           veillogger#clearMsgs;
654                           styles#add key style;
655                           log_libxslt_msgs logger veillogger;
656                         with e ->
657                           logger#log (Printexc.to_string e))
658                     | _ -> logger#log (sprintf "invalid binding %s" binding))
659                   bindings;
660                 output_string res_pipe logger#asHtml;
661                 flush res_pipe;
662                 raise Restart_HTTP_daemon
663             | line when Pcre.pmatch ~rex:remove_cmd_RE line ->  (* /remove *)
664                 stop_http_daemon ();
665                 let arg = Pcre.replace ~rex:remove_cmd_RE line in
666                 let logger = new Uwobo_logger.processingLogger () in
667                 veillogger#clearMsgs;
668                 act_on_keys
669                   arg styles logger
670                   styles#remove (fun () -> styles#removeAll) styles#keys
671                   "removing";
672                 log_libxslt_msgs logger veillogger;
673                 output_string res_pipe (logger#asHtml);
674                 raise Restart_HTTP_daemon
675             | line when Pcre.pmatch ~rex:reload_cmd_RE line ->  (* /reload *)
676                 stop_http_daemon ();
677                 let arg = Pcre.replace ~rex:reload_cmd_RE line in
678                 let logger = new Uwobo_logger.processingLogger () in
679                 veillogger#clearMsgs;
680                 act_on_keys
681                   arg styles logger
682                   styles#reload (fun () -> styles#reloadAll) styles#keys
683                   "reloading";
684                 output_string res_pipe (logger#asHtml);
685                 raise Restart_HTTP_daemon
686             | line when Pcre.pmatch ~rex:createprofile_cmd_RE line -> (* /createprofile *)
687               stop_http_daemon ();
688                 begin
689                   match (Pcre.split ~pat:"," (Pcre.replace ~rex:createprofile_cmd_RE line)) with
690                       id::clone::clone_password::read_perm::write_perm::admin_perm::password::pv_list ->
691                         let bool_option_of_string_option =
692                           function
693                               Some "true" -> Some true
694                             | Some _ -> Some false
695                             | None -> None
696                         in
697                         let pid =
698                           Uwobo_profiles.create
699                             ?id:(string_option_of_string id)
700                             ?clone:(string_option_of_string clone)
701                             ?clone_password:(string_option_of_string clone_password)
702                             ?read_perm:(bool_option_of_string_option (string_option_of_string read_perm))
703                             ?write_perm:(bool_option_of_string_option (string_option_of_string write_perm))
704                             ?admin_perm:(bool_option_of_string_option (string_option_of_string admin_perm))
705                             ?password:(string_option_of_string password)
706                             ()
707                         in
708                         let pv_list' = (deserialize_param_list pv_list) in
709                           List.iter
710                             (fun (key, value) ->
711                                Uwobo_profiles.set_param
712                                pid ?password:(string_option_of_string password) ~key ~value ())
713                             pv_list' ;
714                           save_configuration () ;
715                           output_string res_pipe ("Profile " ^ pid ^ " created. Hi " ^ pid) ;
716                           raise Restart_HTTP_daemon
717                     | _ -> assert false
718                 end
719             | line when Pcre.pmatch ~rex:removeprofile_cmd_RE line -> (* /removeprofile *)
720               stop_http_daemon ();
721               let pid, password =
722                 match Pcre.split ~pat:"," (Pcre.replace ~rex:removeprofile_cmd_RE line) with
723                     [pid; password] -> pid, (string_option_of_string password)
724                   | _ -> assert false
725               in
726                 Uwobo_profiles.remove pid ?password () ;
727                 save_configuration () ;
728                 output_string res_pipe "Done" ;
729                 raise Restart_HTTP_daemon
730             | line when Pcre.pmatch ~rex:setparams_cmd_RE line -> (* /setparams *)
731               stop_http_daemon () ;
732                 let pid, password, pv_list =
733                   match Pcre.split ~pat:"," (Pcre.replace ~rex:setparams_cmd_RE line) with
734                       pid::password::pv_list ->
735                         pid, (string_option_of_string password), (deserialize_param_list pv_list)
736                     | _ -> assert false
737                 in
738                   List.iter
739                     (fun (key, value) -> Uwobo_profiles.set_param pid ?password ~key ~value ())
740                     pv_list ;
741                   save_configuration () ;
742                   output_string res_pipe "Done" ;
743                   raise Restart_HTTP_daemon
744             | line when Pcre.pmatch ~rex:setprofileparam_cmd_RE line -> (* /setprofileparam *)
745               stop_http_daemon ();
746               let pid, password, key, value =
747                 match Pcre.split ~pat:"," (Pcre.replace ~rex:setprofileparam_cmd_RE line) with
748                     [pid; password; key; value] ->
749                       pid, (string_option_of_string password), key, (string_option_of_string value)
750                   | _ -> assert false
751               in
752                 Uwobo_profiles.set_param pid ?password ~key ~value () ;
753                 save_configuration () ;
754                 output_string res_pipe "Done" ;
755                 raise Restart_HTTP_daemon
756             | line when Pcre.pmatch ~rex:setpassword_cmd_RE line -> (* /setpassword *)
757               stop_http_daemon ();
758               let pid, old_password, password =
759                 match Pcre.split ~pat:"," (Pcre.replace ~rex:setpassword_cmd_RE line) with
760                     [pid; old_password; password] ->
761                       pid, (string_option_of_string old_password), (string_option_of_string password)
762                   | _ -> assert false
763               in
764                 Uwobo_profiles.set_password pid ?old_password password ;
765                 save_configuration () ;
766                 output_string res_pipe "Done" ;
767                 raise Restart_HTTP_daemon
768             | line when Pcre.pmatch ~rex:setpermission_cmd_RE line -> (* /setpermission *)
769               stop_http_daemon ();
770               let permission_of_string =
771                 function
772                     "read" -> `Read
773                   | "write" -> `Write
774                   | "admin" -> `Admin
775                   | _ -> assert false
776               and bool_of_string s = "public" = s
777               in
778               let pid, password, forwhat, value =
779                 match Pcre.split ~pat:"," (Pcre.replace ~rex:setpermission_cmd_RE line) with
780                     [pid; password; forwhat; value] ->
781                       pid, (string_option_of_string password), (permission_of_string forwhat), (bool_of_string value)
782                   | _ -> assert false
783               in
784                 Uwobo_profiles.set_permission pid ?password forwhat value ;
785                 save_configuration () ;
786                 output_string res_pipe "Done" ;
787                 raise Restart_HTTP_daemon
788             | cmd ->  (* invalid interprocess command received *)
789                 syslogger#log `Warning
790                   (sprintf "Ignoring invalid interprocess command: '%s'" cmd))
791           done
792         with
793          | Restart_HTTP_daemon ->
794             close_in cmd_pipe;  (* these calls close also fds *)
795             close_out res_pipe
796          | Sys.Break as exn -> raise exn
797          | e -> (* Should we return a 404 error here? Maybe... (how?) *)
798             output_string res_pipe (Printexc.to_string e);
799             close_in cmd_pipe;  (* these calls close also fds *)
800             close_out res_pipe)
801     | 0 ->  (* (5) child: serve http requests *)
802         Unix.close cmd_pipe_exit;
803         Unix.close res_pipe_entrance;
804         last_process := false;
805         let cmd_pipe = Unix.out_channel_of_descr cmd_pipe_entrance in
806         let res_pipe = Unix.in_channel_of_descr res_pipe_exit in
807         debug_print (sprintf "Starting HTTP daemon on port %d ..." port);
808           (* next invocation doesn't return, process will keep on serving HTTP
809           requests until it will get killed by father *)
810         let d_spec = Http_daemon.daemon_spec
811             ~port ~mode:`Fork
812             ~callback:(callback ~syslogger ~styles ~cmd_pipe ~res_pipe ()) ()
813         in
814         Http_daemon.main d_spec
815     | _ (* < 0 *) ->  (* fork failed :-((( *)
816         failwith "Can't fork :-("
817   done
818 ;;
819
820   (* daemon initialization *)
821 try
822   Sys.catch_break true;
823   main ()
824 with Sys.Break -> ()  (* 'die_nice' registered with at_exit *)
825 ;;
826