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