let debug_print s = if debug then prerr_endline s ;;
Http_common.debug := false ;;
+let configuration_file = "/projects/helm/etc/uwobo.conf.xml";;
+
+ (* First of all we load the configuration *)
+let _ =
+ Helm_registry.load_from configuration_file
+;;
+
+let save_configuration () =
+ if not (Helm_registry.has "uwobo.cloned") then
+ Helm_registry.save_to configuration_file
+;;
+
(* other settings *)
let daemon_name = "UWOBO OCaml" ;;
-let default_log_base_file = "log/uwobo" ;; (* relative to execution dir *)
-let log_extension = ".log" ;;
-let default_port = 58080 ;;
-let port_env_var = "UWOBO_PORT" ;;
-let log_env_var = "UWOBO_LOG_FILE" ;; (* The extension _pid.log will be added *)
let default_media_type = "text/html" ;;
let default_encoding = "utf8" ;;
Not_found -> default_encoding
;;
-let port =
+let string_of_param_option (req: Http_types.request) name =
try
- int_of_string (Sys.getenv port_env_var)
+ req#param name
with
- | Not_found -> default_port
- | Failure "int_of_string" ->
- prerr_endline "Warning: invalid port number" ;
- exit (-1)
-;;
+ Http_types.Param_not_found _ -> "#"
+
+let string_option_of_string =
+ function
+ "#" -> None
+ | s -> Some s
+
+let port = Helm_registry.get_int "uwobo.port";;
+
let logfilename_of_port port =
- let basename =
- try
- Sys.getenv log_env_var
- with
- Not_found -> default_log_base_file
- in
- basename ^ "_" ^ string_of_int port ^ log_extension
+ let basename = Helm_registry.get "uwobo.log_basename" in
+ let extension = Helm_registry.get "uwobo.log_extension" in
+ basename ^ "_" ^ string_of_int port ^ extension
;;
+
let logfile = logfilename_of_port port;;
let logfile_perm = 0o640 ;;
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_basic_headers ~code:(`Code 200) outchan;
Http_daemon.send_header "Content-Type" "text/html" outchan;
Http_daemon.send_CRLF outchan;
(try
return_error "Timeout!" outchan)
;;
-let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE, kill_cmd_RE) =
+let (add_cmd_RE, remove_cmd_RE, reload_cmd_RE, kill_cmd_RE,
+ createprofile_cmd_RE, removeprofile_cmd_RE, setprofileparam_cmd_RE,
+ setpassword_cmd_RE, setpermission_cmd_RE) =
(Pcre.regexp "^add ", Pcre.regexp "^remove ", Pcre.regexp "^reload ",
- Pcre.regexp "^kill")
+ Pcre.regexp "^kill", Pcre.regexp "^createprofile ", Pcre.regexp "^removeprofile ",
+ Pcre.regexp "^setprofileparam ", Pcre.regexp "^setpassword ", Pcre.regexp "^setpermission ")
;;
(** raised by child processes when HTTP daemon process have to be restarted *)
(* It can raise Failure "Connection refused" *)
(* It can raise Failure "Port already in use" *)
let start_new_session cmd_pipe res_pipe outchan port logfile =
- let environment =
- (* Here I am loosing the current value of port_env_var; *)
- (* this should not matter *)
- Unix.putenv port_env_var (string_of_int port) ;
- Unix.environment ()
- in
- (* Let's check that the port is free *)
- (try
- ignore
- (Http_client.Convenience.http_head_message
- ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ;
- raise (Failure "Port already in use")
- with
- Failure "Connection refused" -> ()
- ) ;
- match Unix.fork () with
- 0 ->
- Unix.handle_unix_error
- (function () ->
- (* 1. We close all the open pipes to avoid duplicating them *)
- Unix.close (Unix.descr_of_out_channel cmd_pipe) ;
- Unix.close (Unix.descr_of_in_channel res_pipe) ;
- Unix.close (Unix.descr_of_out_channel outchan) ;
- (* 2. We redirect stdout and stderr to the logfile *)
- Unix.close Unix.stdout ;
- assert
- (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
- 0o664 = Unix.stdout) ;
- Unix.close Unix.stderr ;
- assert
- (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
- 0o664 = Unix.stderr) ;
- prerr_endline "***** Starting a new session" ;
- (* 3. We exec a new copy of uwobo *)
- Unix.execve Sys.executable_name [||] environment ;
- (* It should never reach this point *)
- assert false
- ) ()
- | child when child > 0 ->
- (* let's check if the new UWOBO started correctly *)
- Unix.sleep 5 ;
- (* It can raise Failure "Connection refused" *)
- ignore
- (Http_client.Convenience.http_head_message
- ("http://127.0.0.1:" ^ string_of_int port ^ "/help"))
- | _ -> failwith "Can't fork :-("
+ (* Let's check that the port is free *)
+ (try
+ ignore
+ (Http_client.http_get
+ ("http://127.0.0.1:" ^ string_of_int port ^ "/help")) ;
+ raise (Failure "Port already in use")
+ with
+ Unix.Unix_error (Unix.ECONNREFUSED, _, _) -> ()
+ ) ;
+ match Unix.fork () with
+ 0 ->
+ Unix.handle_unix_error
+ (function () ->
+ (* 1. We close all the open pipes to avoid duplicating them *)
+ Unix.close (Unix.descr_of_out_channel cmd_pipe) ;
+ Unix.close (Unix.descr_of_in_channel res_pipe) ;
+ Unix.close (Unix.descr_of_out_channel outchan) ;
+ (* 2. We redirect stdout and stderr to the logfile *)
+ Unix.close Unix.stdout ;
+ assert
+ (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
+ 0o664 = Unix.stdout) ;
+ Unix.close Unix.stderr ;
+ assert
+ (Unix.openfile logfile [Unix.O_WRONLY ; Unix.O_APPEND ; Unix.O_CREAT]
+ 0o664 = Unix.stderr) ;
+ prerr_endline "***** Starting a new session" ;
+
+ (* 3. We set up a new environment *)
+ let environment =
+ (* Here I am loosing the current value of port_env_var; *)
+ (* this should not matter *)
+ Unix.putenv "uwobo__port" (string_of_int port) ;
+ Unix.putenv "uwobo__cloned" "1" ;
+ Unix.environment ()
+ in
+ (* 4. We exec a new copy of uwobo *)
+ Unix.execve Sys.executable_name [||] environment ;
+ (* It should never reach this point *)
+ assert false
+ ) ()
+ | child when child > 0 ->
+ (* let's check if the new UWOBO started correctly *)
+ Unix.sleep 5 ;
+ (* It can raise Failure "Connection refused" *)
+ (try
+ ignore
+ (Http_client.http_get
+ ("http://127.0.0.1:" ^ string_of_int port ^ "/help"))
+ with Unix.Unix_error (Unix.ECONNREFUSED, _, _) ->
+ raise (Failure "Connection refused"))
+ | _ -> failwith "Can't fork :-("
;;
(* request handler action
logger#log "Stylesheets list:";
List.iter (fun s -> logger#log s) l);
respond_html logger#asHtml outchan)
+ | "/listprofiles" ->
+ let profile_list = Uwobo_profiles.list () in
+ respond_html ("<html><body><ul>" ^ String.concat "" (List.map (fun s -> "<li>" ^ s ^ "</li>") profile_list) ^ "</ul></body></html>") outchan
+ | "/createprofile" ->
+ let cmd = sprintf "createprofile %s,%s,%s,%s,%s,%s,%s"
+ (string_of_param_option req "id")
+ (string_of_param_option req "orig")
+ (string_of_param_option req "origpassword")
+ (string_of_param_option req "readperm")
+ (string_of_param_option req "writeperm")
+ (string_of_param_option req "adminperm")
+ (string_of_param_option req "password")
+ in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
+ | "/removeprofile" ->
+ let cmd = sprintf "removeprofile %s,%s"
+ (req#param "id")
+ (string_of_param_option req "password")
+ in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
+ | "/setparam" ->
+ let cmd = sprintf "setprofileparam %s,%s,%s,%s"
+ (string_of_param_option req "id")
+ (string_of_param_option req "password")
+ (req#param "key")
+ (string_of_param_option req "value")
+ in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
+ | "/setpassword" ->
+ let cmd = sprintf "setpassword %s,%s,%s"
+ (req#param "id")
+ (string_of_param_option req "password")
+ (string_of_param_option req "oldpassword")
+ in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
+ | "/setpermission" ->
+ begin
+ match req#param "for" with
+ "read"
+ | "write"
+ | "admin" as forwhat ->
+ let cmd = sprintf "setpermission %s,%s,%s,%s"
+ (req#param "id")
+ (string_of_param_option req "password")
+ forwhat
+ (req#param "value")
+ in
+ short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan
+ | _ -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan
+ end
+ | "/getparams" ->
+ let pid = req#param "id" in
+ let password = try Some (req#param "password") with _ -> None in
+ let res = Uwobo_profiles.get_params pid ?password () in
+ respond_html
+ ("<html><body><ul>" ^
+ String.concat "" (List.map (fun k,v -> "<li><key>" ^ k ^ "</key> = <value>" ^ v ^ "</value></li>") res) ^
+ "</ul></body></html>") outchan
+ | "/getparam" ->
+ let pid = req#param "id" in
+ let password = try Some (req#param "password") with _ -> None in
+ let key = req#param "key" in
+ let value = Uwobo_profiles.get_param pid ?password ~key () in
+ respond_html ("<html><body>" ^ value ^ "</body></html>") outchan
+ | "/getpermission" ->
+ let pid = req#param "id" in
+ let password = try Some (req#param "password") with _ -> None in
+ let forwhat =
+ match req#param "for" with
+ "read" -> Some `Read
+ | "write" -> Some `Write
+ | "admin" -> Some `Admin
+ | _ -> None
+ in
+ begin
+ match forwhat with
+ Some forwhat ->
+ let value = Uwobo_profiles.get_permission pid ?password forwhat in
+ respond_html ("<html><body>" ^ (if value then "public" else "private") ^ "</body></html>") outchan
+ | None -> Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan ;
+ end
| "/apply" ->
let logger = new Uwobo_logger.processingLogger () in
veillogger#clearMsgs;
+ let profile = try Some (req#param "profile") with _ -> None in
+ let password = try Some (req#param "password") with _ -> None 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
+ let (user_params, props) = parse_apply_params req#params in
+ let profile_params =
+ match profile with
+ None -> []
+ | Some profile -> Uwobo_profiles.get_params profile ?password () in
+ let params =
+ (* user provided parameters override the profile parameters *)
+ let is_global_param x = Pcre.pmatch ~pat:"^(\\.[^.]+){1}$" ("." ^ x) in
+ let is_local_param x = Pcre.pmatch ~pat:"^(\\.[^.]+){2}$" ("." ^ x) in
+ let add key value params =
+ if List.mem_assoc key params then params else params @ [key,value]
+ in
+ List.fold_left
+ (fun old_params (name, value) ->
+ match name with
+ | name when is_global_param name ->
+ (fun x -> add name value (old_params x))
+ | name when is_local_param name ->
+ let pieces = Pcre.extract ~pat:"^([^.]+)\\.(.*)" name in
+ let (key, name) = (pieces.(1), pieces.(2)) in
+ (function
+ | x when x = key -> add name value (old_params x)
+ | x -> old_params x)
+ | _ -> assert false)
+ user_params profile_params
+ in
let (libxslt_errormode, libxslt_debugmode) =
parse_libxslt_msgs_mode req
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_basic_headers ~code:(`Code 200) outchan;
Http_daemon.send_header "Content-Type" content_type outchan;
Http_daemon.send_CRLF outchan;
write_result outchan
outchan)
| "/help" -> respond_html usage_string outchan
| invalid_request ->
- Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
+ Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) outchan);
syslogger#log `Debug (sprintf "%s done!" req#path);
with
| Http_types.Param_not_found attr_name ->
"reloading";
output_string res_pipe (logger#asHtml);
raise Restart_HTTP_daemon
+ | line when Pcre.pmatch ~rex:createprofile_cmd_RE line -> (* /createprofile *)
+ stop_http_daemon ();
+ let params =
+ List.map string_option_of_string (Pcre.split ~pat:"," (Pcre.replace ~rex:createprofile_cmd_RE line))
+ in
+ begin
+ match params with
+ [id; clone; clone_password; read_perm; write_perm; admin_perm; password] ->
+ let bool_option_of_string_option =
+ function
+ Some "true" -> Some true
+ | Some _ -> Some false
+ | None -> None
+ in
+ let pid =
+ Uwobo_profiles.create
+ ?id
+ ?clone
+ ?clone_password
+ ?read_perm:(bool_option_of_string_option read_perm)
+ ?write_perm:(bool_option_of_string_option write_perm)
+ ?admin_perm:(bool_option_of_string_option admin_perm)
+ ?password
+ ()
+ in
+ save_configuration () ;
+ output_string res_pipe ("Profile " ^ pid ^ " created. Hi " ^ pid) ;
+ raise Restart_HTTP_daemon
+ | _ -> assert false
+ end
+ | line when Pcre.pmatch ~rex:removeprofile_cmd_RE line -> (* /removeprofile *)
+ stop_http_daemon ();
+ let pid, password =
+ match Pcre.split ~pat:"," (Pcre.replace ~rex:removeprofile_cmd_RE line) with
+ [pid; password] -> pid, (string_option_of_string password)
+ | _ -> assert false
+ in
+ Uwobo_profiles.remove pid ?password () ;
+ save_configuration () ;
+ output_string res_pipe "Done" ;
+ raise Restart_HTTP_daemon
+ | line when Pcre.pmatch ~rex:setprofileparam_cmd_RE line -> (* /setprofileparam *)
+ stop_http_daemon ();
+ let pid, password, key, value =
+ match Pcre.split ~pat:"," (Pcre.replace ~rex:setprofileparam_cmd_RE line) with
+ [pid; password; key; value] ->
+ pid, (string_option_of_string password), key, (string_option_of_string value)
+ | _ -> assert false
+ in
+ Uwobo_profiles.set_param pid ?password ~key ~value () ;
+ save_configuration () ;
+ output_string res_pipe "Done" ;
+ raise Restart_HTTP_daemon
+ | line when Pcre.pmatch ~rex:setpassword_cmd_RE line -> (* /setpassword *)
+ stop_http_daemon ();
+ let pid, old_password, password =
+ match Pcre.split ~pat:"," (Pcre.replace ~rex:setpassword_cmd_RE line) with
+ [pid; old_password; password] ->
+ pid, (string_option_of_string old_password), (string_option_of_string password)
+ | _ -> assert false
+ in
+ Uwobo_profiles.set_password pid ?old_password password ;
+ save_configuration () ;
+ output_string res_pipe "Done" ;
+ raise Restart_HTTP_daemon
+ | line when Pcre.pmatch ~rex:setpermission_cmd_RE line -> (* /setpermission *)
+ stop_http_daemon ();
+ let permission_of_string =
+ function
+ "read" -> `Read
+ | "write" -> `Write
+ | "admin" -> `Admin
+ | _ -> assert false
+ and bool_of_string s = "public" = s
+ in
+ let pid, password, forwhat, value =
+ match Pcre.split ~pat:"," (Pcre.replace ~rex:setpermission_cmd_RE line) with
+ [pid; password; forwhat; value] ->
+ pid, (string_option_of_string password), (permission_of_string forwhat), (bool_of_string value)
+ | _ -> assert false
+ in
+ Uwobo_profiles.set_permission pid ?password forwhat value ;
+ save_configuration () ;
+ output_string res_pipe "Done" ;
+ 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;)
+ with
+ Restart_HTTP_daemon ->
+ close_in cmd_pipe; (* these calls close also fds *)
+ close_out res_pipe
+ | e -> (* Should we return a 404 error here? Maybe... (how?) *)
+ output_string res_pipe (Printexc.to_string e);
+ close_in cmd_pipe; (* these calls close also fds *)
+ close_out res_pipe)
| 0 -> (* (5) child: serve http requests *)
Unix.close cmd_pipe_exit;
Unix.close res_pipe_entrance;