From: Luca Padovani Date: Sat, 22 May 2004 07:00:06 +0000 (+0000) Subject: * updated respond_error messages after API change in ocaml-http 0.0.9 X-Git-Tag: V_0_0_9~13 X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=commitdiff_plain;h=06e36b435676498b570b4e3591a52be726a42fe4;p=helm.git * updated respond_error messages after API change in ocaml-http 0.0.9 --- diff --git a/helm/uwobo/.depend b/helm/uwobo/.depend index 0f1df97cf..a37a2cd19 100644 --- a/helm/uwobo/.depend +++ b/helm/uwobo/.depend @@ -1,7 +1,7 @@ uwobo.cmo: uwobo_common.cmi uwobo_engine.cmi uwobo_logger.cmi \ - uwobo_styles.cmi + uwobo_profiles.cmi uwobo_styles.cmi uwobo.cmx: uwobo_common.cmx uwobo_engine.cmx uwobo_logger.cmx \ - uwobo_styles.cmx + uwobo_profiles.cmx uwobo_styles.cmx uwobo_common.cmo: uwobo_common.cmi uwobo_common.cmx: uwobo_common.cmi uwobo_engine.cmo: uwobo_common.cmi uwobo_logger.cmi uwobo_styles.cmi \ @@ -10,6 +10,8 @@ uwobo_engine.cmx: uwobo_common.cmx uwobo_logger.cmx uwobo_styles.cmx \ uwobo_engine.cmi uwobo_logger.cmo: uwobo_logger.cmi uwobo_logger.cmx: uwobo_logger.cmi +uwobo_profiles.cmo: uwobo_profiles.cmi +uwobo_profiles.cmx: uwobo_profiles.cmi uwobo_styles.cmo: uwobo_common.cmi uwobo_logger.cmi uwobo_styles.cmi uwobo_styles.cmx: uwobo_common.cmx uwobo_logger.cmx uwobo_styles.cmi uwobo_engine.cmi: uwobo_common.cmi uwobo_logger.cmi uwobo_styles.cmi diff --git a/helm/uwobo/Makefile b/helm/uwobo/Makefile index 9cec0e488..e22de9f07 100644 --- a/helm/uwobo/Makefile +++ b/helm/uwobo/Makefile @@ -14,7 +14,7 @@ OCAMLDOC = \ $(shell $(OCAMLFIND) query -i-format gdome2-xslt) \ $(shell $(OCAMLFIND) query -i-format pcre) \ $(shell $(OCAMLFIND) query -i-format unix) -MODULES = uwobo_common uwobo_styles uwobo_logger uwobo_engine +MODULES = uwobo_common uwobo_styles uwobo_profiles uwobo_logger uwobo_engine OBJS = $(patsubst %,%.cmo,$(MODULES)) OBJSOPT = $(patsubst %,%.cmx,$(MODULES)) diff --git a/helm/uwobo/uwobo.ml b/helm/uwobo/uwobo.ml index d680f9e28..b51169c9c 100644 --- a/helm/uwobo/uwobo.ml +++ b/helm/uwobo/uwobo.ml @@ -61,6 +61,17 @@ let get_encoding props = 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 = @@ -166,7 +177,7 @@ let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan = 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 @@ -178,9 +189,12 @@ let short_circuit_grandfather_and_client ~cmd ~cmd_pipe ~res_pipe outchan = 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 *) @@ -340,15 +354,123 @@ let callback 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 ("

" ^ s ^ "

") 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 + ("

" ^ k ^ " = " ^ v ^ "

") 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 ("" ^ value ^ "") 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 ("" ^ (if value then "true" else "false") ^ "") 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 @@ -371,7 +493,7 @@ let callback 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 @@ -384,7 +506,7 @@ let callback 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 -> @@ -503,13 +625,98 @@ let main () = "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; diff --git a/helm/uwobo/uwobo_common.ml b/helm/uwobo/uwobo_common.ml index b4a910f9d..bdb455bc7 100644 --- a/helm/uwobo/uwobo_common.ml +++ b/helm/uwobo/uwobo_common.ml @@ -100,7 +100,7 @@ let usage_string = return a list of loaded stylesheets

- apply?xmluri=uri&keys=key1,key2,...[&errormode={ignore|comment|embed}][&debugmode={ignore|comment|embed}][¶m.name=value[¶m.name=value[&...]]][¶m.key.name=value[¶m.key.name=value[&...]]][&prop.name[=value][&prop.name[=value][&...]]]
+ apply?xmluri=uri&keys=key1,key2,...[&errormode={ignore|comment|embed}][&debugmode={ignore|comment|embed}][&profile=id][&password=password][¶m.name=value[¶m.name=value[&...]]][¶m.key.name=value[¶m.key.name=value[&...]]][&prop.name[=value][&prop.name[=value][&...]]]
apply a chain of stylesheets, specified by key1, key2, ..., to an input document, specified by uri.
Error and debugging modes could be ste to three different values. @@ -114,11 +114,62 @@ let usage_string = param.name=value syntax, per stylesheet parameters are set using param.key.name=value where key is the key of a loaded stylesheet.
+ Moreover, it is possible to specify a profile that is searched for + additional global and local parameters. The parameters stored in the profile + have lower precedence with respect to those provided in the URL. A + password for the profile must be provided if the read permission + of the profile is set to false.
Properties of the final chain output can be set too: valueless properties can be set using prop.name syntax, others can be set using prop.name=value syntax.
Current supported properties are: %s.

+ listprofiles
+ return the list of profiles available +

+ createprofile?[id=id][&orig=orig][&origpassword=origpassword][&readperm={true|false}][&writeperm={true|false}][&adminperm={true|false}][&password=password]
+ creates a new profile. The id of the created profile is id (if provided); otherwise it is a fresh id. + The parameters are inherited from the profile orig, if provided. origpassword is the password of the + profile being copied in case the read permission of that profile is set to false. The defaults for + password and readper,writeperm,adminperm are respectively true, true, true and no password. +

+ removeprofile?id=id[&password=password]
+ completely removes the profile id. The password is required if the profile administrative permission + is set to false. +

+ setprofileparam?id=id[&password=password]&key=key[&value=value]
+ sets the property key to value, if value is provided; otherwise + the parameter is unset. The password is required if the profile writing permission is set to + false. +

+ setpassword?id=id[&oldpassword=oldpassword][&password=password]
+ changes or unset the password. The old password is required if it was set. +

+ setpermission?id=id[&password=password]&permission={read|write|admin}&value={true|false}
+ changes the permission permission. The password is required if the administrative permission + is set to false. +

+ getparams?id=id[&password=password]
+ returns all the params of the profile id. The password is required if the read permission + is set to false. +

+ getparam?id=id[&password=password]&key=key
+ returns the value of the param key of the profile id. The password is required if the read permission + is set to false. +

+ getpermission?id=id[&password=password]&for={read|write|admin}
+ returns the value of the permission key of the profile id. The password is required if the administrative + permission is set to false. +

" @@ -133,7 +184,7 @@ let pp_error = let return_error msg ?(body = "") outchan = Http_daemon.respond ~body:(pp_error msg body) outchan;; let bad_request body outchan = - Http_daemon.respond_error ~code:400 ~body outchan + Http_daemon.respond_error ~code:(`Code 400) ~body outchan ;; (** {2 LibXSLT logging} *) diff --git a/helm/uwobo/uwobo_styles.ml b/helm/uwobo/uwobo_styles.ml index 6b4791e36..7730857ac 100644 --- a/helm/uwobo/uwobo_styles.ml +++ b/helm/uwobo/uwobo_styles.ml @@ -189,7 +189,6 @@ class styles = with Not_found -> (* Cache miss *) -prerr_endline ("##### CACHE MISS: " ^ key) ; let stylesheet = try List.assoc key stylesheets