1 (* Copyright (C) 2002-2005, HELM Team.
3 * This file is part of HELM, an Hypertextual, Electronic
4 * Library of Mathematics, developed at the Computer Science
5 * Department, University of Bologna, Italy.
7 * HELM is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU General Public License
9 * as published by the Free Software Foundation; either version 2
10 * of the License, or (at your option) any later version.
12 * HELM is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 * GNU General Public License for more details.
17 * You should have received a copy of the GNU General Public License
18 * along with HELM; if not, write to the Free Software
19 * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
22 * For details, see the HELM World-Wide-Web page,
23 * http://cs.unibo.it/helm/.
29 let debug_print s = if debug then prerr_endline s
30 let _ = Http_common.debug := false
32 exception Chat_unfinished
33 exception Unbound_identifier of string
34 exception Invalid_action of string (* invalid action for "/search" method *)
36 (** raised by elim when a MutInd is required but not found *)
37 exception Not_a_MutInd
39 let daemon_name = "Whelp"
40 let configuration_file = "/projects/helm/etc/whelp.conf.xml"
43 "ACTION"; "ADVANCED"; "ADVANCED_CHECKED"; "CHOICES"; "CURRENT_CHOICES";
44 "EXPRESSION"; "ID"; "IDEN"; "ID_TO_URIS"; "INTERPRETATIONS";
45 "INTERPRETATIONS_LABELS"; "MSG"; "NEW_ALIASES"; "NEXT_LINK"; "NO_CHOICES";
46 "PAGE"; "PAGES"; "PREV_LINK"; "QUERY_KIND"; "QUERY_SUMMARY"; "RESULTS";
47 "SEARCH_ENGINE_URL"; "SIMPLE_CHECKED"; "TITLE";
51 let regexps = Hashtbl.create 25 in
53 (fun tag -> Hashtbl.add regexps tag (Pcre.regexp (sprintf "@%s@" tag)))
57 Hashtbl.find regexps name
58 with Not_found -> assert false
60 (* First of all we load the configuration *)
61 let _ = Helm_registry.load_from configuration_file
62 let port = Helm_registry.get_int "search_engine.port"
63 let pages_dir = Helm_registry.get "search_engine.html_dir"
65 let moogle_TPL = pages_dir ^ "/moogle.html"
66 let choices_TPL = pages_dir ^ "/moogle_chat.html"
69 let ic = Unix.open_process_in "hostname -f" in
70 let hostname = input_line ic in
71 ignore (Unix.close_process_in ic);
72 sprintf "http://%s:%d" hostname port
73 let _ = Helm_registry.set "search_engine.my_own_url" my_own_url
75 let bad_request body outchan =
76 Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) ~body
79 (** chain application of Pcre substitutions *)
80 let rec apply_substs substs line =
83 | (rex, templ) :: rest -> apply_substs rest (Pcre.replace ~rex ~templ line)
84 (** fold like function on files *)
85 let fold_file f init fname =
86 let inchan = open_in fname in
87 let rec fold_lines' value =
89 let line = input_line inchan in
90 fold_lines' (f value line)
91 with End_of_file -> value
93 let res = (try fold_lines' init with e -> (close_in inchan; raise e)) in
96 (** iter like function on files *)
97 let iter_file f = fold_file (fun _ line -> f line) ()
98 let javascript_quote s =
99 let rex = Pcre.regexp "'" in
100 let rex' = Pcre.regexp "\"" in
101 Pcre.replace ~rex ~templ:"\\'"
102 (Pcre.replace ~rex:rex' ~templ:"\\\"" s)
104 let len = String.length s in
105 String.sub s 1 (len-1)
107 let len = String.length s in
108 let suffix = String.sub s (len-4) 4 in
109 not (suffix = ".var")
111 let add_param_substs params =
114 let key' = (Pcre.extract ~pat:"param\\.(.*)" key).(1) in
115 Pcre.regexp ("@" ^ key' ^ "@"), value)
117 (fun ((key,_) as p) -> Pcre.pmatch ~pat:"^param\\." key)
120 let page_RE = Pcre.regexp "¶m\\.page=\\d+"
121 let identifier_RE = Pcre.regexp "^\\s*(\\w|')+\\s*$"
122 let qualified_mutind_RE =
123 Pcre.regexp "^\\s*cic:(/(\\w|')+)+\\.ind#xpointer\\(1/\\d+\\)\\s*$"
125 let query_kind_of_req (req: Http_types.request) =
127 | "/match" -> "Match"
129 | "/locate" -> "Locate"
131 | "/instance" -> "Instance"
134 (* given a uri with a query part in input try to find in it a string
135 * "¶m_name=..." (where param_name is given). If found its value will be
136 * set to param_value. If not, a trailing "¶m_name=param_value" (where
137 * both are given) is added to the input string *)
138 let patch_param param_name param_value url =
139 let rex = Pcre.regexp (sprintf "&%s=[^&]*" (Pcre.quote param_name)) in
140 if Pcre.pmatch ~rex url then
141 Pcre.replace ~rex ~templ:(sprintf "%s=%s" param_name param_value) url
143 sprintf "%s&%s=%s" url param_name param_value
145 (** HTML encoding, e.g.: "<" -> "<" *)
146 let html_encode = Netencoding.Html.encode_from_latin1
148 let send_results results
149 ?(id_to_uris = CicTextualParser2.EnvironmentP3.of_string "")
150 (req: Http_types.request) outchan
152 let query_kind = query_kind_of_req req in
153 let interp = try req#param "interp" with Http_types.Param_not_found _ -> "" in
154 let page_link anchor page =
156 let this = req#param "this" in
158 (patch_param "param.interp" interp
159 (patch_param "param.page" (string_of_int page)
162 let target = Pcre.replace ~pat:"&" ~templ:"&" target in
163 sprintf "<a href=\"%s\">%s</a>" target anchor
164 with Http_types.Param_not_found _ -> ""
166 Http_daemon.send_basic_headers ~code:(`Code 200) outchan ;
167 Http_daemon.send_header "Content-Type" "text/xml" outchan;
168 Http_daemon.send_CRLF outchan ;
171 | `Results results ->
172 let page = try int_of_string (req#param "page") with _ -> 1 in
173 let results_no = List.length results in
174 let results_per_page =
175 Helm_registry.get_int "search_engine.results_per_page"
178 if results_no mod results_per_page = 0 then
179 results_no / results_per_page
181 results_no / results_per_page + 1
183 let pages = if pages = 0 then 1 else pages in
184 let (summary, results) = MooglePp.theory_of_result page results in
185 [ tag "PAGE", string_of_int page;
186 tag "PAGES", string_of_int pages;
187 tag "PREV_LINK", (if page > 1 then page_link "Prev" (page-1) else "");
189 (if page < pages then page_link "Next" (page+1) else "");
190 tag "QUERY_KIND", query_kind;
191 tag "QUERY_SUMMARY", summary;
192 tag "RESULTS", results ]
198 tag "QUERY_KIND", query_kind;
199 tag "QUERY_SUMMARY", "error";
205 with Http_types.Param_not_found _ -> "no"
208 (tag "SEARCH_ENGINE_URL", my_own_url) ::
209 (tag "ADVANCED", advanced) ::
210 (tag "EXPRESSION", html_encode (req#param "expression")) ::
211 add_param_substs req#params @
212 (if advanced = "no" then
213 [ tag "SIMPLE_CHECKED", "checked='true'";
214 tag "ADVANCED_CHECKED", "" ]
216 [ tag "SIMPLE_CHECKED", "";
217 tag "ADVANCED_CHECKED", "checked='true'" ]) @
223 CicTextualParser2.EnvironmentP3.to_string id_to_uris
227 (* CSC: Bug here: this is a string, not an array! *)
228 ((tag "NEW_ALIASES", "'" ^ javascript_quote new_aliases ^ "'") ::
232 output_string outchan (processed_line ^ "\n"))
235 let exec_action dbd (req: Http_types.request) outchan =
236 let term_str = req#param "expression" in
238 if req#path = "/elim" &&
239 not (Pcre.pmatch ~rex:identifier_RE term_str ||
240 Pcre.pmatch ~rex:qualified_mutind_RE term_str) then
242 let (context, metasenv) = ([], []) in
244 try req#param "aliases"
245 with Http_types.Param_not_found _ -> ""
247 let parse_interpretation_choices choices =
248 List.map int_of_string (Pcre.split ~pat:" " choices) in
249 let parse_choices choices_raw =
250 let choices = Pcre.split ~pat:";" choices_raw in
253 match Pcre.split ~pat:"\\s" x with
255 | id::tail when id<>"" ->
258 Some (List.map (fun u -> Netencoding.Url.decode u) tail)
261 | _ -> failwith "Can't parse choices")
265 let id_to_uris = CicTextualParser2.EnvironmentP3.of_string id_to_uris_raw in
268 parse_choices (req#param "choices")
269 with Http_types.Param_not_found _ -> (fun _ -> None)
271 let interpretation_choices =
273 let choices_raw = req#param "interpretation_choices" in
274 if choices_raw = "" then None
275 else Some (parse_interpretation_choices choices_raw)
276 with Http_types.Param_not_found _ -> None
278 let module Chat: DisambiguateTypes.Callbacks =
280 let interactive_user_uri_choice ~selection_mode ?ok
281 ?enable_button_for_non_vars ~(title: string) ~(msg: string)
282 ~(id: string) (choices: string list)
284 match id_to_choices id with
285 | Some choices -> choices
286 | None -> List.filter nonvar choices
288 let interactive_interpretation_choice interpretations =
289 match interpretation_choices with
292 let html_interpretations =
293 MooglePp.html_of_interpretations interpretations
295 Http_daemon.send_basic_headers ~code:(`Code 200) outchan ;
296 Http_daemon.send_CRLF outchan ;
300 with Http_types.Param_not_found _ -> "no"
302 let query_kind = query_kind_of_req req in
307 [ tag "SEARCH_ENGINE_URL", my_own_url;
308 tag "ADVANCED", advanced;
309 tag "INTERPRETATIONS", html_interpretations;
310 tag "CURRENT_CHOICES", req#param "choices";
311 tag "EXPRESSION", html_encode (req#param "expression");
312 tag "QUERY_KIND", query_kind;
313 tag "QUERY_SUMMARY", "disambiguation";
314 tag "ACTION", string_tail req#path ]
317 output_string outchan (processed_line ^ "\n"))
319 raise Chat_unfinished
321 let input_or_locate_uri ~title ?id () =
323 | Some id -> raise (Unbound_identifier id)
324 | None -> assert false
327 let module Disambiguate' = Disambiguate.Make(Chat) in
328 let ast = CicTextualParser2.parse_term (Stream.of_string term_str) in
329 let (id_to_uris, metasenv, term) =
331 Disambiguate'.disambiguate_term ~dbd ~context ~metasenv
332 ~aliases:id_to_uris ast
334 | [id_to_uris,metasenv,term,_] -> id_to_uris,metasenv,term
339 | "/match" -> MetadataQuery.match_term ~dbd term
340 | "/instance" -> MetadataQuery.instance ~dbd term
342 let status = ProofEngineTypes.initial_status term metasenv in
343 let intros = PrimitiveTactics.intros_tac () in
344 let subgoals = ProofEngineTypes.apply_tactic intros status in
347 let (uri,metasenv,bo,ty) = proof in
348 List.map fst (MetadataQuery.experimental_hint ~dbd (proof, goal))
353 | Cic.MutInd (uri, typeno, _) ->
354 UriManager.string_of_uriref (uri, [typeno])
355 | _ -> raise Not_a_MutInd
357 MetadataQuery.elim ~dbd uri
360 send_results ~id_to_uris (`Results uris) req outchan
363 send_results (`Error (MooglePp.pp_error "Not an inductive type"
364 ("elim requires as input an identifier corresponding to an inductive"
368 let callback dbd (req: Http_types.request) outchan =
370 debug_print (sprintf "Received request: %s" req#path);
373 (* TODO implement "is_permitted" *)
374 (let is_permitted page = not (Pcre.pmatch ~pat:"/" page) in
375 let page = req#param "url" in
376 let fname = sprintf "%s/%s" pages_dir page in
379 bool_of_string (req#param "preprocess")
380 with Invalid_argument _ | Http_types.Param_not_found _ -> false)
383 | page when is_permitted page && Sys.file_exists fname ->
384 Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
385 Http_daemon.send_header "Content-Type" "text/html" outchan;
386 Http_daemon.send_CRLF outchan;
387 if preprocess then begin
390 output_string outchan
392 ((tag "SEARCH_ENGINE_URL", my_own_url) ::
393 (tag "ADVANCED", "no") ::
394 (tag "RESULTS", "") ::
395 add_param_substs req#params)
400 Http_daemon.send_file ~src:(Http_types.FileSrc fname) outchan
401 | page -> Http_daemon.respond_forbidden ~url:page outchan))
402 | "/help" -> Http_daemon.respond ~body:daemon_name outchan
404 let initial_expression =
405 try req#param "expression" with Http_types.Param_not_found _ -> ""
408 Pcre.replace ~pat:"\\s*$"
409 (Pcre.replace ~pat:"^\\s*" initial_expression)
411 if expression = "" then
412 send_results (`Results []) req outchan
414 let results = MetadataQuery.locate ~dbd expression in
415 send_results (`Results results) req outchan
420 | "/match" -> exec_action dbd req outchan
422 Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
424 debug_print (sprintf "%s done!" req#path)
426 | Chat_unfinished -> ()
427 | Http_types.Param_not_found attr_name ->
428 bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
429 | CicTextualParser2.Parse_error (_, msg) ->
430 send_results (`Error (MooglePp.pp_error "Parse error" msg)) req outchan
431 | Unbound_identifier id ->
432 send_results (`Error (MooglePp.pp_error "Unbound identifier" id)) req
435 let exn_string = Printexc.to_string exn in
436 debug_print exn_string;
437 let msg = MooglePp.pp_error "Uncaught exception" exn_string in
438 send_results (`Error msg) req outchan
440 let restore_environment () =
442 Helm_registry.get_opt Helm_registry.get "search_engine.environment_dump"
446 printf "Restoring Cic environment from %s ... " fname; flush stdout;
447 let ic = open_in fname in
448 CicEnvironment.restore_from_channel ic;
450 printf "done!\n"; flush stdout
453 printf "%s started and listening on port %d\n" daemon_name port;
454 printf "Current directory is %s\n" (Sys.getcwd ());
455 printf "HTML directory is %s\n" pages_dir;
457 Unix.putenv "http_proxy" "";
460 ~host:(Helm_registry.get "db.host")
461 ~database:(Helm_registry.get "db.database")
462 ~user:(Helm_registry.get "db.user")
465 restore_environment ();
466 Http_daemon.start' ~port (callback dbd);
467 printf "%s is terminating, bye!\n" daemon_name