1 (* Copyright (C) 2002-2004, 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/.
31 let debug_print s = if debug then prerr_endline s
32 let _ = Http_common.debug := false
34 exception Chat_unfinished
35 exception Unbound_identifier of string
36 exception Invalid_action of string (* invalid action for "/search" method *)
38 let daemon_name = "Moogle"
39 let configuration_file = "/projects/helm/etc/moogle.conf.xml"
42 "EXPRESSION"; "ACTION"; "ADVANCED"; "ADVANCED_CHECKED"; "SIMPLE_CHECKED";
43 "TITLE"; "NO_CHOICES"; "CURRENT_CHOICES"; "CHOICES"; "MSG"; "ID_TO_URIS";
44 "ID"; "IDEN"; "INTERPRETATIONS"; "INTERPRETATIONS_LABELS"; "RESULTS";
45 "NEW_ALIASES"; "SEARCH_ENGINE_URL"; "PREV_LINK"; "PAGE"; "PAGES"; "NEXT_LINK"
49 let regexps = Hashtbl.create 25 in
51 (fun tag -> Hashtbl.add regexps tag (Pcre.regexp (sprintf "@%s@" tag)))
55 (* First of all we load the configuration *)
56 let _ = Helm_registry.load_from configuration_file
57 let port = Helm_registry.get_int "search_engine.port"
58 let pages_dir = Helm_registry.get "search_engine.html_dir"
60 let interactive_interpretation_choice_TPL = pages_dir ^ "/moogle_chat2.html"
61 let moogle_TPL = pages_dir ^ "/moogle.html"
64 let ic = Unix.open_process_in "hostname -f" in
65 let hostname = input_line ic in
66 ignore (Unix.close_process_in ic);
67 sprintf "http://%s:%d" hostname port
68 let _ = Helm_registry.set "search_engine.my_own_url" my_own_url
70 let bad_request body outchan =
71 Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) ~body
74 (** chain application of Pcre substitutions *)
75 let rec apply_substs substs line =
78 | (rex, templ) :: rest -> apply_substs rest (Pcre.replace ~rex ~templ line)
79 (** fold like function on files *)
80 let fold_file f init fname =
81 let inchan = open_in fname in
82 let rec fold_lines' value =
84 let line = input_line inchan in
85 fold_lines' (f value line)
86 with End_of_file -> value
88 let res = (try fold_lines' init with e -> (close_in inchan; raise e)) in
91 (** iter like function on files *)
92 let iter_file f = fold_file (fun _ line -> f line) ()
93 let javascript_quote s =
94 let rex = Pcre.regexp "'" in
95 let rex' = Pcre.regexp "\"" in
96 Pcre.replace ~rex ~templ:"\\'"
97 (Pcre.replace ~rex:rex' ~templ:"\\\"" s)
99 let len = String.length s in
100 String.sub s 1 (len-1)
102 let add_param_substs params =
105 let key' = (Pcre.extract ~pat:"param\\.(.*)" key).(1) in
106 Pcre.regexp ("@" ^ key' ^ "@"), value)
108 (fun ((key,_) as p) -> Pcre.pmatch ~pat:"^param\\." key)
111 let page_RE = Pcre.regexp "¶m\\.page=\\d+"
113 let send_results results
114 ?(id_to_uris = CicTextualParser2.EnvironmentP3.of_string "")
115 (req: Http_types.request) outchan
117 let page_link anchor page =
119 let this = req#param "this" in
121 if Pcre.pmatch ~rex:page_RE this then
122 Pcre.replace ~rex:page_RE ~templ:(sprintf "¶m.page=%d" page)
125 sprintf "%s¶m.page=%d" this page
127 let target = Pcre.replace ~pat:"&" ~templ:"&" target in
128 sprintf "<a href=\"%s\">%s</a>" target anchor
129 with Http_types.Param_not_found _ -> ""
131 Http_daemon.send_basic_headers ~code:(`Code 200) outchan ;
132 Http_daemon.send_header "Content-Type" "text/xml" outchan;
133 Http_daemon.send_CRLF outchan ;
134 let subst, results_string =
136 | `Results results ->
137 let page = try int_of_string (req#param "page") with _ -> 1 in
138 let results_no = List.length results in
139 let results_per_page =
140 Helm_registry.get_int "search_engine.results_per_page"
143 if results_no mod results_per_page = 0 then
144 results_no / results_per_page
146 results_no / results_per_page + 1
148 ([ tag "PAGE", string_of_int page; tag "PAGES", string_of_int pages ] @
150 if page > 1 then page_link "Prev" (page-1) else "" ] @
152 if page < pages then page_link "Next" (page+1) else "" ]),
153 MooglePp.theory_of_result req page results
155 [ tag "PAGE", ""; tag "PAGES", "";
156 tag "PREV_LINK", ""; tag "NEXT_LINK", "" ],
160 (tag "SEARCH_ENGINE_URL", my_own_url) ::
161 (tag "RESULTS", results_string) ::
162 (tag "ADVANCED", req#param "advanced") ::
163 (tag "EXPRESSION", req#param "expression") ::
164 add_param_substs req#params @
165 (if req#param "advanced" = "no" then
166 [ tag "SIMPLE_CHECKED", "checked='true'";
167 tag "ADVANCED_CHECKED", "" ]
169 [ tag "SIMPLE_CHECKED", "";
170 tag "ADVANCED_CHECKED", "checked='true'" ]) @
176 CicTextualParser2.EnvironmentP3.to_string id_to_uris
180 (* CSC: Bug here: this is a string, not an array! *)
181 ((tag "NEW_ALIASES", "'" ^ javascript_quote new_aliases ^ "'") ::
185 output_string outchan (processed_line ^ "\n"))
188 let exec_action dbh (req: Http_types.request) outchan =
189 let term_str = req#param "expression" in
190 let (context, metasenv) = ([], []) in
192 try req#param "aliases"
193 with Http_types.Param_not_found _ -> ""
195 let parse_interpretation_choices choices =
196 List.map int_of_string (Pcre.split ~pat:" " choices) in
197 let parse_choices choices_raw =
198 let choices = Pcre.split ~pat:";" choices_raw in
201 match Pcre.split ~pat:"\\s" x with
203 | id::tail when id<>"" ->
206 Some (List.map (fun u -> Netencoding.Url.decode u) tail)
209 | _ -> failwith "Can't parse choices")
213 let id_to_uris = CicTextualParser2.EnvironmentP3.of_string id_to_uris_raw in
216 parse_choices (req#param "choices")
217 with Http_types.Param_not_found _ -> (fun _ -> None)
219 let interpretation_choices =
221 let choices_raw = req#param "interpretation_choices" in
222 if choices_raw = "" then None
223 else Some (parse_interpretation_choices choices_raw)
224 with Http_types.Param_not_found _ -> None
226 let module Chat: DisambiguateTypes.Callbacks =
228 let interactive_user_uri_choice ~selection_mode ?ok
229 ?enable_button_for_non_vars ~(title: string) ~(msg: string)
230 ~(id: string) (choices: string list)
232 match id_to_choices id with
233 | Some choices -> choices
234 | None -> assert false
236 let interactive_interpretation_choice interpretations =
237 match interpretation_choices with
240 let html_interpretations =
241 MooglePp.html_of_interpretations interpretations
243 Http_daemon.send_basic_headers ~code:(`Code 200) outchan ;
244 Http_daemon.send_CRLF outchan ;
249 [tag "ADVANCED", req#param "advanced";
250 tag "INTERPRETATIONS", html_interpretations;
251 tag "CURRENT_CHOICES", req#param "choices";
252 tag "EXPRESSION", req#param "expression";
253 tag "ACTION", string_tail req#path ]
256 output_string outchan (processed_line ^ "\n"))
257 interactive_interpretation_choice_TPL;
258 raise Chat_unfinished
260 let input_or_locate_uri ~title ?id () =
262 | Some id -> raise (Unbound_identifier id)
263 | None -> assert false
266 let module Disambiguate' = Disambiguate.Make(Chat) in
267 let ast = CicTextualParser2.parse_term (Stream.of_string term_str) in
268 let (id_to_uris, metasenv, term) =
270 Disambiguate'.disambiguate_term dbh context metasenv ast id_to_uris
272 | [id_to_uris,metasenv,term] -> id_to_uris,metasenv,term
277 | "/match" -> MetadataQuery.match_term ~dbh term
279 let status = ProofEngineTypes.initial_status term metasenv in
280 let intros = PrimitiveTactics.intros_tac () in
281 let subgoals = ProofEngineTypes.apply_tactic intros status in
284 let (uri,metasenv,bo,ty) = proof in
285 List.map fst (MetadataQuery.hint ~dbh (proof, goal))
290 | Cic.MutInd (uri, typeno, _) ->
291 UriManager.string_of_uriref (uri, [typeno])
294 MetadataQuery.elim ~dbh uri
297 send_results ~id_to_uris (`Results uris) req outchan
299 let callback dbh (req: Http_types.request) outchan =
301 debug_print (sprintf "Received request: %s" req#path);
304 (* TODO implement "is_permitted" *)
305 (let is_permitted _ = true in
306 let page = req#param "url" in
309 bool_of_string (req#param "preprocess")
310 with Invalid_argument _ | Http_types.Param_not_found _ -> false)
313 | page when is_permitted page ->
314 (let fname = sprintf "%s/%s" pages_dir page in
315 Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
316 Http_daemon.send_header "Content-Type" "text/html" outchan;
317 Http_daemon.send_CRLF outchan;
318 if preprocess then begin
321 output_string outchan
323 ((tag "SEARCH_ENGINE_URL", my_own_url) ::
324 (tag "ADVANCED", "no") ::
325 (tag "RESULTS", "") ::
326 add_param_substs req#params)
331 Http_daemon.send_file ~src:(Http_types.FileSrc fname) outchan)
332 | page -> Http_daemon.respond_forbidden ~url:page outchan))
333 | "/help" -> Http_daemon.respond ~body:daemon_name outchan
335 let initial_expression =
336 try req#param "expression" with Http_types.Param_not_found _ -> ""
339 Pcre.replace ~pat:"\\s*$"
340 (Pcre.replace ~pat:"^\\s*" initial_expression)
342 if expression = "" then
343 send_results (`Results []) req outchan
345 let results = MetadataQuery.locate ~dbh expression in
346 send_results (`Results results) req outchan
349 | "/match" -> exec_action dbh req outchan
351 Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
353 debug_print (sprintf "%s done!" req#path)
355 | Chat_unfinished -> ()
356 | Http_types.Param_not_found attr_name ->
357 bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
358 | CicTextualParser2.Parse_error msg ->
359 send_results (`Error (MooglePp.pp_error "Parse_error" msg)) req outchan
360 | Unbound_identifier id ->
361 send_results (`Error (MooglePp.pp_error "Unbound identifier" id)) req
364 let exn_string = Printexc.to_string exn in
365 debug_print exn_string;
366 let msg = MooglePp.pp_error "Uncaught exception" exn_string in
367 send_results (`Error msg) req outchan
370 printf "%s started and listening on port %d\n" daemon_name port;
371 printf "Current directory is %s\n" (Sys.getcwd ());
372 printf "HTML directory is %s\n" pages_dir;
374 Unix.putenv "http_proxy" "";
376 new DB.connection ~host:(Helm_registry.get "db.host")
377 ~user:(Helm_registry.get "db.user") (Helm_registry.get "db.database")
379 Http_daemon.start' ~port (callback dbh);
380 printf "%s is terminating, bye!\n" daemon_name