]> matita.cs.unibo.it Git - helm.git/blob - helm/software/daemons/whelp/searchEngine.ml
some bug fixes
[helm.git] / helm / software / daemons / whelp / searchEngine.ml
1 (* Copyright (C) 2002-2005, HELM Team.
2  * 
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.
6  * 
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.
11  * 
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.
16  *
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,
20  * MA  02111-1307, USA.
21  * 
22  * For details, see the HELM World-Wide-Web page,
23  * http://cs.unibo.it/helm/.
24  *)
25
26 open Printf
27
28 let debug = true
29 let debug_print s = if debug then prerr_endline s
30 let _ = Http_common.debug := false
31
32 exception Chat_unfinished
33 exception Unbound_identifier of string
34 exception Invalid_action of string  (* invalid action for "/search" method *)
35
36   (** raised by elim when a MutInd is required but not found *)
37 exception Not_a_MutInd
38
39 let daemon_name = "Whelp"
40 let configuration_file = "searchEngine.conf.xml"
41
42 let placeholders = [
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"; "PAGELIST"; "PREV_LINK"; "QUERY_KIND"; "QUERY_SUMMARY"; "RESULTS";
47   "SEARCH_ENGINE_URL"; "SIMPLE_CHECKED"; "TITLE";
48 ]
49
50 let tag =
51   let regexps = Hashtbl.create 25 in
52   List.iter
53     (fun tag -> Hashtbl.add regexps tag (Pcre.regexp (sprintf "@%s@" tag)))
54     placeholders;
55   fun name ->
56     try
57       Hashtbl.find regexps name
58     with Not_found -> assert false
59
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"
64
65 let moogle_TPL = pages_dir ^ "/moogle.html"
66 let choices_TPL = pages_dir ^ "/moogle_chat.html"
67
68 let my_own_url =
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
74
75 let bad_request body outchan =
76   Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) ~body
77     outchan
78
79   (** chain application of Pcre substitutions *)
80 let rec apply_substs substs line =
81   match substs with
82   | [] -> 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 =
88     try 
89       let line = input_line inchan in 
90       fold_lines' (f value line)
91     with End_of_file -> value
92   in
93   let res = (try fold_lines' init with e -> (close_in inchan; raise e)) in
94   close_in inchan;
95   res
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)
103 let string_tail s =
104   let len = String.length s in
105   String.sub s 1 (len-1)
106 let nonvar uri =
107   let s = UriManager.string_of_uri uri in
108   let len = String.length s in
109   let suffix = String.sub s (len-4) 4 in
110   not (suffix  = ".var")
111
112 let add_param_substs params =
113   List.map
114     (fun (key,value) ->
115       let key' = (Pcre.extract ~pat:"param\\.(.*)" key).(1) in
116       Pcre.regexp ("@" ^ key' ^ "@"), value)
117     (List.filter
118       (fun (key,_) -> Pcre.pmatch ~pat:"^param\\." key)
119       params)
120
121 let page_RE = Pcre.regexp "&param\\.page=\\d+"
122 let identifier_RE = Pcre.regexp "^\\s*(\\w|')+\\s*$"
123 let qualified_mutind_RE =
124  Pcre.regexp "^\\s*cic:(/(\\w|')+)+\\.ind#xpointer\\(1/\\d+\\)\\s*$"
125
126 let query_kind_of_req (req: Http_types.request) =
127   match req#path with
128   | "/match" -> "Match"
129   | "/hint" -> "Hint"
130   | "/locate" -> "Locate"
131   | "/elim" -> "Elim"
132   | "/instance" -> "Instance"
133   | _ -> ""
134
135   (* given a uri with a query part in input try to find in it a string
136    * "&param_name=..." (where param_name is given). If found its value will be
137    * set to param_value. If not, a trailing "&param_name=param_value" (where
138    * both are given) is added to the input string *)
139 let patch_param param_name param_value url =
140   let rex = Pcre.regexp (sprintf "&%s=[^&]*" (Pcre.quote param_name)) in
141   if Pcre.pmatch ~rex url then
142     Pcre.replace ~rex ~templ:(sprintf "%s=%s" param_name param_value) url
143   else
144     sprintf "%s&%s=%s" url param_name param_value
145
146   (** HTML encoding, e.g.: "<" -> "&lt;" *)
147 let html_encode = Netencoding.Html.encode_from_latin1
148
149 let fold_n_to_m f n m acc =
150  let rec aux acc =
151   function
152      i when i <= m -> aux (f i acc) (i + 1)
153    | _ -> acc
154  in
155   aux acc n
156
157 let send_results results
158   ?(id_to_uris = DisambiguateTypes.Environment.empty) 
159    (req: Http_types.request) outchan
160   =
161   let query_kind = query_kind_of_req req in
162   let interp = try req#param "interp" with Http_types.Param_not_found _ -> "" in
163   let page_link anchor page =
164     try
165       let this = req#param "this" in
166       let target =
167         (patch_param "param.interp" interp
168            (patch_param "param.page" (string_of_int page)
169               this))
170       in
171       let target = Pcre.replace ~pat:"&" ~templ:"&amp;" target in
172       sprintf "<a href=\"%s\">%s</a>" target anchor
173     with Http_types.Param_not_found _ -> ""
174   in
175   Http_daemon.send_basic_headers ~code:(`Code 200) outchan ;
176   Http_daemon.send_header "Content-Type" "text/xml" outchan;
177   Http_daemon.send_CRLF outchan ;
178   let subst =
179     match results with
180     | `Results results ->
181         let page = try int_of_string (req#param "page") with _ -> 1 in
182         let results_no = List.length results in
183         let results_per_page =
184           Helm_registry.get_int "search_engine.results_per_page"
185         in
186         let pages =
187           if results_no mod results_per_page = 0 then
188             results_no / results_per_page
189           else
190             results_no / results_per_page + 1
191         in
192         let pages = if pages = 0 then 1 else pages in
193         let additional_pages = 3 in
194         let (summary, results) = MooglePp.theory_of_result page results in
195         [ tag "PAGE", string_of_int page;
196           tag "PAGES", string_of_int pages ^ " Pages";
197           tag "PAGELIST",
198           (let inf = page - additional_pages in
199            let sup = page + additional_pages in
200            let superinf = inf - (sup - pages) in
201            let supersup = sup + (1 - inf) in
202            let n,m =
203             if inf >= 1 && sup <= pages then
204              inf,sup
205             else if inf < 1 then
206              1, (if supersup <= pages then supersup else pages)
207             else (* sup > pages *)
208              (if superinf >= 1 then superinf else 1),pages
209            in
210             fold_n_to_m
211              (fun n acc -> acc ^ " " ^
212                           (if n = page then string_of_int n
213                            else page_link (string_of_int n) n))
214              n m "");
215           tag "PREV_LINK", (if page > 1 then page_link "Prev" (page-1) else "");
216           tag "NEXT_LINK",
217             (if page < pages then page_link "Next" (page+1) else "");
218           tag "QUERY_KIND", query_kind;
219           tag "QUERY_SUMMARY", summary;
220           tag "RESULTS", results ]
221     | `Error msg ->
222         [ tag "PAGE", "1";
223           tag "PAGES", "1 Page";
224           tag "PAGELIST", "";
225           tag "PREV_LINK", "";
226           tag "NEXT_LINK", "";
227           tag "QUERY_KIND", query_kind;
228           tag "QUERY_SUMMARY", "error";
229           tag "RESULTS", msg ]
230   in
231   let advanced =
232     try
233       req#param "advanced"
234     with Http_types.Param_not_found _ -> "no"
235   in
236   let subst =
237     (tag "SEARCH_ENGINE_URL", my_own_url) ::
238     (tag "ADVANCED", advanced) ::
239     (tag "EXPRESSION", html_encode (req#param "expression")) ::
240     add_param_substs req#params @
241     (if advanced = "no" then
242       [ tag "SIMPLE_CHECKED", "checked='true'";
243         tag "ADVANCED_CHECKED", "" ]
244     else
245       [ tag "SIMPLE_CHECKED", "";
246         tag "ADVANCED_CHECKED", "checked='true'" ]) @
247     subst
248   in
249   iter_file
250     (fun line ->
251       let new_aliases = DisambiguatePp.pp_environment id_to_uris in
252       let processed_line =
253         apply_substs
254           (* CSC: Bug here: this is a string, not an array! *)
255           ((tag "NEW_ALIASES", "'" ^ javascript_quote new_aliases ^ "'") ::
256             subst) 
257           line
258       in
259       output_string outchan (processed_line ^ "\n"))
260     moogle_TPL
261
262 let exec_action dbd (req: Http_types.request) outchan =
263   let dbd = dbd () in
264   let term_str = req#param "expression" in
265   try
266     if req#path = "/elim" &&
267      not (Pcre.pmatch ~rex:identifier_RE term_str ||
268           Pcre.pmatch ~rex:qualified_mutind_RE term_str) then
269       raise Not_a_MutInd;
270     let (context, metasenv) = ([], []) in
271     let id_to_uris_raw = 
272       try req#param "aliases" 
273       with Http_types.Param_not_found _ -> ""
274     in
275     let parse_interpretation_choices choices =
276       List.map int_of_string (Pcre.split ~pat:" " choices) in
277     let parse_choices choices_raw =
278       let choices = Pcre.split ~pat:";" choices_raw in
279       List.fold_left
280         (fun f x ->
281            match Pcre.split ~pat:"\\s" x with
282              | ""::id::tail
283              | id::tail when id<>"" ->
284                  (fun id' ->
285                     if id = id' then
286                       Some (List.map 
287                         (fun u -> UriManager.uri_of_string
288                           (Netencoding.Url.decode u)) 
289                         tail)
290                     else
291                       f id')
292              | _ -> failwith "Can't parse choices")
293         (fun _ -> None)
294         choices
295     in
296     let id_to_uris,_ = 
297       CicNotation2.parse_environment id_to_uris_raw ~include_paths:[]
298     in
299     let id_to_choices =
300       try
301         parse_choices (req#param "choices")
302       with Http_types.Param_not_found _ -> (fun _ -> None)
303     in
304     let interpretation_choices =
305       try
306         let choices_raw = req#param "interpretation_choices" in
307         if choices_raw = "" then None 
308         else Some (parse_interpretation_choices choices_raw)
309       with Http_types.Param_not_found _ -> None
310     in 
311     let module Chat: DisambiguateTypes.Callbacks =
312       struct
313         let interactive_user_uri_choice ~selection_mode ?ok
314           ?enable_button_for_non_vars ~(title: string) ~(msg: string)
315           ~(id: string) (choices: UriManager.uri list)
316         =
317           match id_to_choices id with
318           | Some choices -> choices
319           | None -> List.filter nonvar choices
320
321         let interactive_interpretation_choice _ _ interpretations =
322           match interpretation_choices with
323           | Some l -> l
324           | None ->
325               let html_interpretations =
326                 MooglePp.html_of_interpretations interpretations
327               in
328               Http_daemon.send_basic_headers ~code:(`Code 200) outchan ;
329               Http_daemon.send_CRLF outchan ;
330               let advanced =
331                 try
332                   req#param "advanced"
333                 with Http_types.Param_not_found _ -> "no"
334               in
335               let query_kind = query_kind_of_req req in
336               iter_file
337                 (fun line ->
338                    let processed_line =
339                      apply_substs
340                        [ tag "SEARCH_ENGINE_URL", my_own_url;
341                          tag "ADVANCED", advanced;
342                          tag "INTERPRETATIONS", html_interpretations;
343                          tag "CURRENT_CHOICES", req#param "choices";
344                          tag "EXPRESSION", html_encode (req#param "expression");
345                          tag "QUERY_KIND", query_kind;
346                          tag "QUERY_SUMMARY", "disambiguation";
347                          tag "ACTION", string_tail req#path ]
348                        line
349                    in
350                    output_string outchan (processed_line ^ "\n"))
351                 choices_TPL;
352               raise Chat_unfinished
353
354         let input_or_locate_uri ~title ?id () =
355           match id with
356           | Some id -> raise (Unbound_identifier id)
357           | None -> assert false
358       end
359     in
360     let module Disambiguate' = Disambiguate.Make(Chat) in
361     let ast =
362       CicNotationParser.parse_term (Ulexing.from_utf8_string term_str) in
363     let (id_to_uris, metasenv, term) =
364       match
365         Disambiguate'.disambiguate_term ~dbd ~context ~metasenv
366           ~aliases:id_to_uris ~universe:None ("",0,ast)
367       with
368       | [id_to_uris,metasenv,term,_], _ -> id_to_uris,metasenv,term
369       | _ -> assert false
370     in
371     let uris =
372       match req#path with
373       | "/match" -> Whelp.match_term ~dbd term
374       | "/instance" -> Whelp.instance ~dbd term
375       | "/hint" ->
376           let status = ProofEngineTypes.initial_status term metasenv [] in
377           let intros = PrimitiveTactics.intros_tac () in
378           let subgoals = ProofEngineTypes.apply_tactic intros status in
379           (match subgoals with
380           | proof, [goal] ->
381               List.map fst (MetadataQuery.experimental_hint ~dbd (proof, goal))
382           | _ -> assert false)
383       | "/elim" ->
384           let uri =
385             match term with
386             | Cic.MutInd (uri, typeno, _) ->
387                 UriManager.uri_of_uriref uri typeno None 
388             | _ -> raise Not_a_MutInd
389           in
390           Whelp.elim ~dbd uri
391       | _ -> assert false
392     in
393     let uris = List.map UriManager.string_of_uri uris in
394     let id_to_uris = 
395       List.fold_left 
396       (fun env (k,v) -> DisambiguateTypes.Environment.add k v env)
397         DisambiguateTypes.Environment.empty id_to_uris
398     in
399     send_results ~id_to_uris (`Results uris) req outchan
400   with
401   | Not_a_MutInd ->
402       send_results (`Error (MooglePp.pp_error "Not an inductive type"
403         ("elim requires as input an identifier corresponding to an inductive"
404          ^ " type")))
405         req outchan
406
407 let callback dbd (req: Http_types.request) outchan =
408   try
409     debug_print (sprintf "Received request: %s" req#path);
410     (match req#path with
411     | "/getpage" ->
412           (* TODO implement "is_permitted" *)
413         (let is_permitted page = not (Pcre.pmatch ~pat:"/" page) in
414         let page = req#param "url" in
415         let fname = sprintf "%s/%s" pages_dir page in
416         let preprocess =
417           (try
418             bool_of_string (req#param "preprocess")
419           with Invalid_argument _ | Http_types.Param_not_found _ -> false)
420         in
421         (match page with
422         | page when is_permitted page && Sys.file_exists fname ->
423             Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
424             Http_daemon.send_header "Content-Type" "text/html" outchan;
425             Http_daemon.send_CRLF outchan;
426             if preprocess then begin
427               iter_file
428                 (fun line ->
429                   output_string outchan
430                     ((apply_substs
431                        ((tag "SEARCH_ENGINE_URL", my_own_url) ::
432                         (tag "ADVANCED", "no") ::
433                         (tag "RESULTS", "") ::
434                         add_param_substs req#params)
435                        line) ^
436                     "\n"))
437                 fname
438             end else
439               Http_daemon.send_file ~src:(Http_types.FileSrc fname) outchan
440         | page -> Http_daemon.respond_forbidden ~url:page outchan))
441     | "/help" -> Http_daemon.respond ~body:daemon_name outchan
442     | "/locate" ->
443         let initial_expression =
444           try req#param "expression" with Http_types.Param_not_found _ -> ""
445         in
446         let expression =
447           Pcre.replace ~pat:"\\s*$"
448             (Pcre.replace ~pat:"^\\s*" initial_expression)
449         in
450         if expression = "" then
451           send_results (`Results []) req outchan
452         else begin
453           let results = Whelp.locate ~dbd:(dbd ()) expression in
454           let results = List.map UriManager.string_of_uri results in
455           send_results (`Results results) req outchan
456         end
457     | "/hint"
458     | "/elim"
459     | "/instance"
460     | "/match" -> exec_action dbd req outchan
461     | invalid_request ->
462         Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
463           outchan);
464     debug_print (sprintf "%s done!" req#path)
465   with
466   | Chat_unfinished -> ()
467   | Http_types.Param_not_found attr_name ->
468       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
469   | CicNotationParser.Parse_error msg ->
470       send_results (`Error (MooglePp.pp_error "Parse error" msg)) req outchan
471   | Stdpp.Exc_located (floc, Stream.Error msg) ->
472       send_results (`Error (MooglePp.pp_error "Parse error" msg)) req outchan
473   | Stdpp.Exc_located (floc, exn) ->
474       let msg = Printexc.to_string exn in
475       send_results (`Error (MooglePp.pp_error "Unknown error" msg)) req outchan
476   | Unbound_identifier id ->
477       send_results (`Error (MooglePp.pp_error "Unbound identifier" id)) req
478         outchan
479   | exn ->
480       let exn_string = Printexc.to_string exn in
481       debug_print exn_string;
482       let msg = MooglePp.pp_error "Uncaught exception" exn_string in
483       send_results (`Error msg) req outchan
484
485 let restore_environment () =
486   match
487     Helm_registry.get_opt Helm_registry.string "search_engine.environment_dump"
488   with
489   | None -> ()
490   | Some fname ->
491       printf "Restoring Cic environment from %s ... " fname; flush stdout;
492       let ic = open_in fname in
493       CicEnvironment.restore_from_channel ic;
494       close_in ic;
495       printf "done!\n"; flush stdout
496
497 let read_notation () =
498   ignore (CicNotation2.load_notation ~include_paths:[]
499    (Helm_registry.get "search_engine.notations"));
500   ignore (CicNotation2.load_notation ~include_paths:[]
501    (Helm_registry.get "search_engine.interpretations"))
502   
503 let _ =
504   printf "%s started and listening on port %d\n" daemon_name port;
505   printf "Current directory is %s\n" (Sys.getcwd ());
506   printf "HTML directory is %s\n" pages_dir;
507   flush stdout;
508   Unix.putenv "http_proxy" "";
509   let dbd () =
510     let dbd = LibraryDb.instance () in
511     MetadataTypes.ownerize_tables "searchEngine";
512     LibraryDb.create_owner_environment ();
513     dbd
514   in
515   restore_environment ();
516   read_notation ();
517   let d_spec = Http_daemon.daemon_spec ~port ~callback:(callback dbd) ~auto_close:true () in
518   Http_daemon.main d_spec;
519   printf "%s is terminating, bye!\n" daemon_name
520