helm/searchEngine/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 let daemon_name = "Moogle"
  37 let configuration_file =
  38   "/projects/helm/daemons/searchEngine.debug/moogle.conf.xml"
  39
  40 let placeholders = [
  41   "ACTION"; "ADVANCED"; "ADVANCED_CHECKED"; "CHOICES"; "CURRENT_CHOICES";
  42   "EXPRESSION"; "ID"; "IDEN"; "ID_TO_URIS"; "INTERPRETATIONS";
  43   "INTERPRETATIONS_LABELS"; "MSG"; "NEW_ALIASES"; "NEXT_LINK"; "NO_CHOICES";
  44   "PAGE"; "PAGES"; "PREV_LINK"; "QUERY_KIND"; "QUERY_SUMMARY"; "RESULTS";
  45   "SEARCH_ENGINE_URL"; "SIMPLE_CHECKED"; "TITLE";
  46 ]
  47
  48 let tag =
  49   let regexps = Hashtbl.create 25 in
  50   List.iter
  51     (fun tag -> Hashtbl.add regexps tag (Pcre.regexp (sprintf "@%s@" tag)))
  52     placeholders;
  53   fun name ->
  54     try
  55       Hashtbl.find regexps name
  56     with Not_found -> assert false
  57
  58   (* First of all we load the configuration *)
  59 let _ = Helm_registry.load_from configuration_file
  60 let port = Helm_registry.get_int "search_engine.port"
  61 let pages_dir = Helm_registry.get "search_engine.html_dir"
  62
  63 let interactive_interpretation_choice_TPL = pages_dir ^ "/moogle_chat2.html"
  64 let moogle_TPL = pages_dir ^ "/moogle.html"
  65
  66 let my_own_url =
  67  let ic = Unix.open_process_in "hostname -f" in
  68  let hostname = input_line ic in
  69  ignore (Unix.close_process_in ic);
  70  sprintf "http://%s:%d" hostname port
  71 let _ = Helm_registry.set "search_engine.my_own_url" my_own_url
  72
  73 let bad_request body outchan =
  74   Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) ~body
  75     outchan
  76
  77   (** chain application of Pcre substitutions *)
  78 let rec apply_substs substs line =
  79   match substs with
  80   | [] -> line
  81   | (rex, templ) :: rest -> apply_substs rest (Pcre.replace ~rex ~templ line)
  82   (** fold like function on files *)
  83 let fold_file f init fname =
  84   let inchan = open_in fname in
  85   let rec fold_lines' value =
  86     try
  87       let line = input_line inchan in
  88       fold_lines' (f value line)
  89     with End_of_file -> value
  90   in
  91   let res = (try fold_lines' init with e -> (close_in inchan; raise e)) in
  92   close_in inchan;
  93   res
  94   (** iter like function on files *)
  95 let iter_file f = fold_file (fun _ line -> f line) ()
  96 let javascript_quote s =
  97  let rex = Pcre.regexp "'" in
  98  let rex' = Pcre.regexp "\"" in
  99   Pcre.replace ~rex ~templ:"\\'"
 100    (Pcre.replace ~rex:rex' ~templ:"\\\"" s)
 101 let string_tail s =
 102   let len = String.length s in
 103   String.sub s 1 (len-1)
 104 let nonvar s =
 105   let len = String.length s in
 106   let suffix = String.sub s (len-4) 4 in
 107   not (suffix  = ".var")
 108
 109 let add_param_substs params =
 110   List.map
 111     (fun (key,value) ->
 112       let key' = (Pcre.extract ~pat:"param\\.(.*)" key).(1) in
 113       Pcre.regexp ("@" ^ key' ^ "@"), value)
 114     (List.filter
 115       (fun ((key,_) as p) -> Pcre.pmatch ~pat:"^param\\." key)
 116       params)
 117
 118 let page_RE = Pcre.regexp "&param\\.page=\\d+"
 119
 120 let query_kind_of_req (req: Http_types.request) =
 121   match req#path with
 122   | "/match" -> "Match"
 123   | "/hint" -> "Hint"
 124   | "/locate" -> "Locate"
 125   | "/elim" -> "Elim"
 126   | _ -> assert false
 127
 128 let send_results results
 129   ?(id_to_uris = CicTextualParser2.EnvironmentP3.of_string "")
 130    (req: Http_types.request) outchan
 131   =
 132   let query_kind = query_kind_of_req req in
 133   let page_link anchor page =
 134     try
 135       let this = req#param "this" in
 136       let target =
 137         if Pcre.pmatch ~rex:page_RE this then
 138           Pcre.replace ~rex:page_RE ~templ:(sprintf "&param.page=%d" page)
 139             this
 140         else
 141           sprintf "%s&param.page=%d" this page
 142       in
 143       let target = Pcre.replace ~pat:"&" ~templ:"&amp;" target in
 144       sprintf "<a href=\"%s\">%s</a>" target anchor
 145     with Http_types.Param_not_found _ -> ""
 146   in
 147   Http_daemon.send_basic_headers ~code:(`Code 200) outchan ;
 148   Http_daemon.send_header "Content-Type" "text/xml" outchan;
 149   Http_daemon.send_CRLF outchan ;
 150   let subst =
 151     match results with
 152     | `Results results ->
 153         let page = try int_of_string (req#param "page") with _ -> 1 in
 154         let results_no = List.length results in
 155         let results_per_page =
 156           Helm_registry.get_int "search_engine.results_per_page"
 157         in
 158         let pages =
 159           if results_no mod results_per_page = 0 then
 160             results_no / results_per_page
 161           else
 162             results_no / results_per_page + 1
 163         in
 164         let pages = if pages = 0 then 1 else pages in
 165         let (summary, results) = MooglePp.theory_of_result page results in
 166         [ tag "PAGE", string_of_int page;
 167           tag "PAGES", string_of_int pages;
 168           tag "PREV_LINK", (if page > 1 then page_link "Prev" (page-1) else "");
 169           tag "NEXT_LINK",
 170             (if page < pages then page_link "Next" (page+1) else "");
 171           tag "QUERY_KIND", query_kind;
 172           tag "QUERY_SUMMARY", summary;
 173           tag "RESULTS", results ]
 174     | `Error msg ->
 175         [ tag "PAGE", "1";
 176           tag "PAGES", "1";
 177           tag "PREV_LINK", "";
 178           tag "NEXT_LINK", "";
 179           tag "QUERY_KIND", query_kind;
 180           tag "QUERY_SUMMARY", "error";
 181           tag "RESULTS", msg ]
 182   in
 183   let advanced =
 184     try
 185       req#param "advanced"
 186     with Http_types.Param_not_found _ -> "no"
 187   in
 188   let subst =
 189     (tag "SEARCH_ENGINE_URL", my_own_url) ::
 190     (tag "ADVANCED", advanced) ::
 191     (tag "EXPRESSION", req#param "expression") ::
 192     add_param_substs req#params @
 193     (if advanced = "no" then
 194       [ tag "SIMPLE_CHECKED", "checked='true'";
 195         tag "ADVANCED_CHECKED", "" ]
 196     else
 197       [ tag "SIMPLE_CHECKED", "";
 198         tag "ADVANCED_CHECKED", "checked='true'" ]) @
 199     subst
 200   in
 201   iter_file
 202     (fun line ->
 203       let new_aliases =
 204         CicTextualParser2.EnvironmentP3.to_string id_to_uris
 205       in
 206       let processed_line =
 207         apply_substs
 208           (* CSC: Bug here: this is a string, not an array! *)
 209           ((tag "NEW_ALIASES", "'" ^ javascript_quote new_aliases ^ "'") ::
 210             subst)
 211           line
 212       in
 213       output_string outchan (processed_line ^ "\n"))
 214     moogle_TPL
 215
 216 let exec_action dbd (req: Http_types.request) outchan =
 217   let term_str = req#param "expression" in
 218   let (context, metasenv) = ([], []) in
 219   let id_to_uris_raw =
 220     try req#param "aliases"
 221     with Http_types.Param_not_found _ -> ""
 222   in
 223   let parse_interpretation_choices choices =
 224     List.map int_of_string (Pcre.split ~pat:" " choices) in
 225   let parse_choices choices_raw =
 226     let choices = Pcre.split ~pat:";" choices_raw in
 227     List.fold_left
 228       (fun f x ->
 229          match Pcre.split ~pat:"\\s" x with
 230            | ""::id::tail
 231            | id::tail when id<>"" ->
 232                (fun id' ->
 233                   if id = id' then
 234                     Some (List.map (fun u -> Netencoding.Url.decode u) tail)
 235                   else
 236                     f id')
 237            | _ -> failwith "Can't parse choices")
 238       (fun _ -> None)
 239       choices
 240   in
 241   let id_to_uris = CicTextualParser2.EnvironmentP3.of_string id_to_uris_raw in
 242   let id_to_choices =
 243     try
 244       parse_choices (req#param "choices")
 245     with Http_types.Param_not_found _ -> (fun _ -> None)
 246   in
 247   let interpretation_choices =
 248     try
 249       let choices_raw = req#param "interpretation_choices" in
 250       if choices_raw = "" then None
 251       else Some (parse_interpretation_choices choices_raw)
 252     with Http_types.Param_not_found _ -> None
 253   in
 254   let module Chat: DisambiguateTypes.Callbacks =
 255     struct
 256       let interactive_user_uri_choice ~selection_mode ?ok
 257         ?enable_button_for_non_vars ~(title: string) ~(msg: string)
 258         ~(id: string) (choices: string list)
 259       =
 260         match id_to_choices id with
 261         | Some choices -> choices
 262         | None -> List.filter nonvar choices
 263
 264       let interactive_interpretation_choice interpretations =
 265         match interpretation_choices with
 266         | Some l -> l
 267         | None ->
 268             let html_interpretations =
 269               MooglePp.html_of_interpretations interpretations
 270             in
 271             Http_daemon.send_basic_headers ~code:(`Code 200) outchan ;
 272             Http_daemon.send_CRLF outchan ;
 273             let advanced =
 274               try
 275                 req#param "advanced"
 276               with Http_types.Param_not_found _ -> "no"
 277             in
 278             iter_file
 279               (fun line ->
 280                  let processed_line =
 281                    apply_substs
 282                      [tag "ADVANCED", advanced;
 283                       tag "INTERPRETATIONS", html_interpretations;
 284                       tag "CURRENT_CHOICES", req#param "choices";
 285                       tag "EXPRESSION", req#param "expression";
 286                       tag "ACTION", string_tail req#path ]
 287                       line
 288                  in
 289                  output_string outchan (processed_line ^ "\n"))
 290               interactive_interpretation_choice_TPL;
 291             raise Chat_unfinished
 292
 293       let input_or_locate_uri ~title ?id () =
 294         match id with
 295         | Some id -> raise (Unbound_identifier id)
 296         | None -> assert false
 297     end
 298   in
 299   let module Disambiguate' = Disambiguate.Make(Chat) in
 300   let ast = CicTextualParser2.parse_term (Stream.of_string term_str) in
 301   let (id_to_uris, metasenv, term) =
 302     match
 303       Disambiguate'.disambiguate_term dbd context metasenv ast id_to_uris
 304     with
 305     | [id_to_uris,metasenv,term,_] -> id_to_uris,metasenv,term
 306     | _ -> assert false
 307   in
 308   let uris =
 309     match req#path with
 310     | "/match" -> MetadataQuery.match_term ~dbd term
 311     | "/hint" ->
 312         let status = ProofEngineTypes.initial_status term metasenv in
 313         let intros = PrimitiveTactics.intros_tac () in
 314         let subgoals = ProofEngineTypes.apply_tactic intros status in
 315         (match subgoals with
 316         | proof, [goal] ->
 317             let (uri,metasenv,bo,ty) = proof in
 318             List.map fst (MetadataQuery.hint ~dbd (proof, goal))
 319         | _ -> assert false)
 320     | "/elim" ->
 321         let uri =
 322           match term with
 323           | Cic.MutInd (uri, typeno, _) ->
 324               UriManager.string_of_uriref (uri, [typeno])
 325           | _ -> assert false
 326         in
 327         MetadataQuery.elim ~dbd uri
 328     | _ -> assert false
 329   in
 330   send_results ~id_to_uris (`Results uris) req outchan
 331
 332 let callback dbd (req: Http_types.request) outchan =
 333   try
 334     debug_print (sprintf "Received request: %s" req#path);
 335     (match req#path with
 336     | "/getpage" ->
 337           (* TODO implement "is_permitted" *)
 338         (let is_permitted _ = true in
 339         let page = req#param "url" in
 340         let preprocess =
 341           (try
 342             bool_of_string (req#param "preprocess")
 343           with Invalid_argument _ | Http_types.Param_not_found _ -> false)
 344         in
 345         (match page with
 346         | page when is_permitted page ->
 347             (let fname = sprintf "%s/%s" pages_dir page in
 348             Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
 349             Http_daemon.send_header "Content-Type" "text/html" outchan;
 350             Http_daemon.send_CRLF outchan;
 351             if preprocess then begin
 352               iter_file
 353                 (fun line ->
 354                   output_string outchan
 355                     ((apply_substs
 356                        ((tag "SEARCH_ENGINE_URL", my_own_url) ::
 357                         (tag "ADVANCED", "no") ::
 358                         (tag "RESULTS", "") ::
 359                         add_param_substs req#params)
 360                        line) ^
 361                     "\n"))
 362                 fname
 363             end else
 364               Http_daemon.send_file ~src:(Http_types.FileSrc fname) outchan)
 365         | page -> Http_daemon.respond_forbidden ~url:page outchan))
 366     | "/help" -> Http_daemon.respond ~body:daemon_name outchan
 367     | "/locate" ->
 368         let initial_expression =
 369           try req#param "expression" with Http_types.Param_not_found _ -> ""
 370         in
 371         let expression =
 372           Pcre.replace ~pat:"\\s*$"
 373             (Pcre.replace ~pat:"^\\s*" initial_expression)
 374         in
 375         if expression = "" then
 376           send_results (`Results []) req outchan
 377         else begin
 378           let results = MetadataQuery.locate ~dbd expression in
 379           send_results (`Results results) req outchan
 380         end
 381     | "/hint"
 382     | "/elim"
 383     | "/match" -> exec_action dbd req outchan
 384     | invalid_request ->
 385         Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
 386           outchan);
 387     debug_print (sprintf "%s done!" req#path)
 388   with
 389   | Chat_unfinished -> ()
 390   | Http_types.Param_not_found attr_name ->
 391       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 392   | CicTextualParser2.Parse_error (_, msg) ->
 393       send_results (`Error (MooglePp.pp_error "Parse_error" msg)) req outchan
 394   | Unbound_identifier id ->
 395       send_results (`Error (MooglePp.pp_error "Unbound identifier" id)) req
 396         outchan
 397   | exn ->
 398       let exn_string = Printexc.to_string exn in
 399       debug_print exn_string;
 400       let msg = MooglePp.pp_error "Uncaught exception" exn_string in
 401       send_results (`Error msg) req outchan
 402
 403 let _ =
 404   printf "%s started and listening on port %d\n" daemon_name port;
 405   printf "Current directory is %s\n" (Sys.getcwd ());
 406   printf "HTML directory is %s\n" pages_dir;
 407   flush stdout;
 408   Unix.putenv "http_proxy" "";
 409   let dbd =
 410     Mysql.quick_connect
 411       ~host:(Helm_registry.get "db.host")
 412       ~database:(Helm_registry.get "db.database")
 413       ~user:(Helm_registry.get "db.user")
 414       ()
 415   in
 416   Http_daemon.start' ~port (callback dbd);
 417   printf "%s is terminating, bye!\n" daemon_name
 418