2 * Copyright (C) 2003-2004:
3 * Stefano Zacchiroli <zack@cs.unibo.it>
4 * for the HELM Team http://helm.cs.unibo.it/
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.
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.
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.
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,
25 * For details, see the HELM World-Wide-Web page,
26 * http://helm.cs.unibo.it/
31 open Http_getter_common
33 open Http_getter_types
34 open Http_getter_debugger
38 let common_headers = [
39 "Cache-Control", "no-cache";
44 (* HTTP queries argument parsing *)
46 (* parse encoding ("format" parameter), default is Enc_normal *)
47 let parse_enc (req: Http_types.request) =
49 (match req#param "format" with
50 | "normal" -> Enc_normal
52 | s -> raise (Bad_request ("Invalid format: " ^ s)))
53 with Http_types.Param_not_found _ -> Enc_normal
55 (* parse "patch_dtd" parameter, default is true *)
56 let parse_patch (req: Http_types.request) =
58 (match req#param "patch_dtd" with
59 | s when String.lowercase s = "yes" -> true
60 | s when String.lowercase s = "no" -> false
61 | s -> raise (Bad_request ("Invalid patch_dtd value: " ^ s)))
62 with Http_types.Param_not_found _ -> true
64 (* parse output format ("format" parameter), no default value *)
65 let parse_output_format (req: Http_types.request) =
66 match req#param "format" with
67 | s when String.lowercase s = "txt" -> Fmt_text
68 | s when String.lowercase s = "xml" -> Fmt_xml
69 | s -> raise (Bad_request ("Invalid /ls format: " ^ s))
71 (* parse "baseuri" format for /ls method, no default value *)
73 let parse_ls_RE = Pcre.regexp "^(\\w+):(.*)$" in
74 let trailing_slash_RE = Pcre.regexp "/+$" in
76 raise (Bad_request ("Invalid /ls baseuri: " ^ uri))
78 fun (req: Http_types.request) ->
79 let baseuri = req#param "baseuri" in
82 Pcre.extract ~rex:parse_ls_RE
83 (Pcre.replace ~rex:trailing_slash_RE baseuri)
85 (match (subs.(1), subs.(2)) with
86 | "cic", uri -> Cic uri
87 | "theory", uri -> Theory uri
88 | _ -> wrong_uri baseuri)
89 with Not_found -> wrong_uri baseuri
91 (* parse "position" argument, default is 0 *)
92 let parse_position (req: Http_types.request) =
94 let res = int_of_string (req#param "position") in
96 raise (Failure "int_of_string");
99 | Http_types.Param_not_found _ -> 0
100 | Failure "int_of_string" ->
102 (sprintf "position must be a non negative integer (%s given)"
103 (req#param "position")))
105 let parse_rdf_class (req: Http_types.request) =
106 match req#param "class" with
107 | "forward" -> `Forward
108 | "backward" -> `Backward
109 | c -> raise (Bad_request ("Invalid RDF class: " ^ c))
111 let return_all_foo_uris doctype uris outchan =
112 Http_daemon.send_basic_headers ~code:200 outchan;
113 Http_daemon.send_header "Content-Type" "text/xml" outchan;
114 Http_daemon.send_headers common_headers outchan;
115 Http_daemon.send_CRLF outchan;
119 "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>
120 <!DOCTYPE %s SYSTEM \"%s/getdtd?uri=%s.dtd\">
125 Http_getter_env.my_own_url
129 (fun uri -> output_string outchan (sprintf "\t<uri value=\"%s\" />\n" uri))
131 output_string outchan (sprintf "</%s>\n" doctype)
133 let return_all_xml_uris outchan =
134 return_all_foo_uris "alluris" (Http_getter.getalluris ()) outchan
135 let return_all_rdf_uris classs outchan =
136 return_all_foo_uris "allrdfuris" (Http_getter.getallrdfuris classs) outchan
138 let return_ls xmluri fmt outchan =
139 let ls_items = Http_getter.ls xmluri in
140 let buf = Buffer.create 10240 in
145 | Ls_section dir -> bprintf buf "dir, %s\n" dir
147 bprintf buf "object, %s, <%s,%s,%s,%s>\n"
148 obj.uri (if obj.ann then "YES" else "NO")
149 (string_of_ls_flag obj.types)
150 (string_of_ls_flag obj.body)
151 (string_of_ls_flag obj.proof_tree))
154 Buffer.add_string buf "<?xml version=\"1.0\" encoding=\"ISO-8859-1\"?>\n";
155 bprintf buf "<!DOCTYPE ls SYSTEM \"%s/getdtd?uri=ls.dtd\">\n"
156 Http_getter_env.my_own_url;
157 Buffer.add_string buf "<ls>\n";
160 | Ls_section dir -> bprintf buf "<section>%s</section>\n" dir
163 "<object name=\"%s\">
164 \t<ann value=\"%s\" />
165 \t<types value=\"%s\" />
166 \t<body value=\"%s\" />
167 \t<proof_tree value=\"%s\" />
170 obj.uri (if obj.ann then "YES" else "NO")
171 (string_of_ls_flag obj.types)
172 (string_of_ls_flag obj.body)
173 (string_of_ls_flag obj.proof_tree))
175 Buffer.add_string buf "</ls>\n");
176 let body = Buffer.contents buf in
178 ~headers:(("Content-Type", "text/plain") :: common_headers)
181 let return_help outchan = return_html_raw (Http_getter.help ()) outchan
183 let return_resolve uri outchan =
186 (sprintf "<url value=\"%s\" />\n" (Http_getter.resolve uri))
188 with Unresolvable_URI uri ->
189 return_xml_raw "<unresolved />\n" outchan
191 let return_list_servers outchan =
193 (sprintf "<html><body><table>\n%s\n</table></body></html>"
196 (fun (pos, server) ->
197 sprintf "<tr><td>%d</td><td>%s</td></tr>" pos server)
198 (Http_getter.list_servers ()))))
203 let callback (req: Http_types.request) outchan =
205 debug_print ("Connection from " ^ req#clientAddr);
206 debug_print ("Received request: " ^ req#path);
208 | "/help" -> return_help outchan
210 let uri = req#param "uri" in
211 Http_getter_cache.respond_xml ~url:(Http_getter.resolve uri) ~uri
212 ~enc:(parse_enc req) ~patch:(parse_patch req) outchan
214 Http_getter_cache.respond_xsl
215 ~url:(Http_getter.resolve (req#param "uri"))
216 ~patch:(parse_patch req) outchan
218 Http_getter_cache.respond_dtd ~patch:(parse_patch req)
219 ~url:(Http_getter_env.dtd_dir ^ "/" ^ (req#param "uri")) outchan
220 | "/resolve" -> return_resolve (req#param "uri") outchan
222 Http_getter.register ~uri:(req#param "uri") ~url:(req#param "url");
223 return_html_msg "Register done" outchan
225 Http_getter.clean_cache ();
226 return_html_msg "Done." outchan
228 Http_getter_env.reload (); (* reload servers list from servers file *)
229 let log = Http_getter.update () in
230 return_html_msg (Ui_logger.html_of_html_msg log) outchan
231 | "/list_servers" -> return_list_servers outchan
233 let name = req#param "url" in
234 let position = parse_position req in
235 let log = Http_getter.add_server ~position name in
237 (sprintf "Added server %s in position %d)<br />\n%s"
238 name position (Ui_logger.html_of_html_msg log))
240 | "/remove_server" ->
241 let position = parse_position req in
244 Http_getter.remove_server position
245 with Invalid_argument _ ->
246 raise (Bad_request (sprintf "no server with position %d" position))
249 (sprintf "Removed server at position %d<br />\n%s"
250 position (Ui_logger.html_of_html_msg log))
252 | "/getalluris" -> return_all_xml_uris outchan
253 | "/getallrdfuris" -> return_all_rdf_uris (parse_rdf_class req) outchan
254 | "/ls" -> return_ls (parse_ls_uri req) (parse_output_format req) outchan
256 Http_daemon.respond ~body:Http_getter_const.empty_xml outchan
258 Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
259 debug_print "Done!\n"
261 | Http_types.Param_not_found attr_name ->
262 return_400 (sprintf "Parameter '%s' is missing" attr_name) outchan
263 | Bad_request msg -> return_html_error msg outchan
264 | Internal_error msg -> return_html_internal_error msg outchan
265 | Shell.Subprocess_error l ->
266 return_html_internal_error
267 (String.concat "<br />\n"
270 sprintf "Command '%s' returned %s"
271 cmd (string_of_proc_status code))
276 ("Uncaught exception: " ^ (Printexc.to_string exc))
282 print_string (Http_getter_env.env_to_string ());
284 at_exit Http_getter.close_maps;
285 Sys.catch_break true;
288 ~timeout:(Some 600) ~port:Http_getter_env.port ~mode:`Thread callback
289 with Sys.Break -> () (* 'close_maps' already registered with 'at_exit' *)