Not_found -> default_encoding
;;
+let string_of_param_option (req: Http_types.request) name =
+ try
+ req#param name
+ with
+ 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 =
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 *)
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
+ | "/setprofileparam" ->
+ 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>" ^ k ^ " = " ^ v ^ "</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 "true" else "false") ^ "</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
+ 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 () ;
+ 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 () ;
+ 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 ;
+ 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 = "true" = 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 ;
+ 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;
projects / helm.git / blobdiff