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 = "/projects/helm/etc/whelp.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 term_str = req#param "expression" in
 264   try
 265     if req#path = "/elim" &&
 266      not (Pcre.pmatch ~rex:identifier_RE term_str ||
 267           Pcre.pmatch ~rex:qualified_mutind_RE term_str) then
 268       raise Not_a_MutInd;
 269     let (context, metasenv) = ([], []) in
 270     let id_to_uris_raw =
 271       try req#param "aliases"
 272       with Http_types.Param_not_found _ -> ""
 273     in
 274     let parse_interpretation_choices choices =
 275       List.map int_of_string (Pcre.split ~pat:" " choices) in
 276     let parse_choices choices_raw =
 277       let choices = Pcre.split ~pat:";" choices_raw in
 278       List.fold_left
 279         (fun f x ->
 280            match Pcre.split ~pat:"\\s" x with
 281              | ""::id::tail
 282              | id::tail when id<>"" ->
 283                  (fun id' ->
 284                     if id = id' then
 285                       Some (List.map
 286                         (fun u -> UriManager.uri_of_string
 287                           (Netencoding.Url.decode u))
 288                         tail)
 289                     else
 290                       f id')
 291              | _ -> failwith "Can't parse choices")
 292         (fun _ -> None)
 293         choices
 294     in
 295     let id_to_uris,_ =
 296       CicNotation2.parse_environment id_to_uris_raw ~include_paths:[]
 297     in
 298     let id_to_choices =
 299       try
 300         parse_choices (req#param "choices")
 301       with Http_types.Param_not_found _ -> (fun _ -> None)
 302     in
 303     let interpretation_choices =
 304       try
 305         let choices_raw = req#param "interpretation_choices" in
 306         if choices_raw = "" then None
 307         else Some (parse_interpretation_choices choices_raw)
 308       with Http_types.Param_not_found _ -> None
 309     in
 310     let module Chat: DisambiguateTypes.Callbacks =
 311       struct
 312         let interactive_user_uri_choice ~selection_mode ?ok
 313           ?enable_button_for_non_vars ~(title: string) ~(msg: string)
 314           ~(id: string) (choices: UriManager.uri list)
 315         =
 316           match id_to_choices id with
 317           | Some choices -> choices
 318           | None -> List.filter nonvar choices
 319
 320         let interactive_interpretation_choice _ _ interpretations =
 321           match interpretation_choices with
 322           | Some l -> l
 323           | None ->
 324               let html_interpretations =
 325                 MooglePp.html_of_interpretations interpretations
 326               in
 327               Http_daemon.send_basic_headers ~code:(`Code 200) outchan ;
 328               Http_daemon.send_CRLF outchan ;
 329               let advanced =
 330                 try
 331                   req#param "advanced"
 332                 with Http_types.Param_not_found _ -> "no"
 333               in
 334               let query_kind = query_kind_of_req req in
 335               iter_file
 336                 (fun line ->
 337                    let processed_line =
 338                      apply_substs
 339                        [ tag "SEARCH_ENGINE_URL", my_own_url;
 340                          tag "ADVANCED", advanced;
 341                          tag "INTERPRETATIONS", html_interpretations;
 342                          tag "CURRENT_CHOICES", req#param "choices";
 343                          tag "EXPRESSION", html_encode (req#param "expression");
 344                          tag "QUERY_KIND", query_kind;
 345                          tag "QUERY_SUMMARY", "disambiguation";
 346                          tag "ACTION", string_tail req#path ]
 347                        line
 348                    in
 349                    output_string outchan (processed_line ^ "\n"))
 350                 choices_TPL;
 351               raise Chat_unfinished
 352
 353         let input_or_locate_uri ~title ?id () =
 354           match id with
 355           | Some id -> raise (Unbound_identifier id)
 356           | None -> assert false
 357       end
 358     in
 359     let module Disambiguate' = Disambiguate.Make(Chat) in
 360     let ast =
 361       CicNotationParser.parse_term (Ulexing.from_utf8_string term_str) in
 362     let (id_to_uris, metasenv, term) =
 363       match
 364         Disambiguate'.disambiguate_term ~dbd ~context ~metasenv
 365           ~aliases:id_to_uris ~universe:None ("",0,ast)
 366       with
 367       | [id_to_uris,metasenv,term,_], _ -> id_to_uris,metasenv,term
 368       | _ -> assert false
 369     in
 370     let uris =
 371       match req#path with
 372       | "/match" -> Whelp.match_term ~dbd term
 373       | "/instance" -> Whelp.instance ~dbd term
 374       | "/hint" ->
 375           let status = ProofEngineTypes.initial_status term metasenv in
 376           let intros = PrimitiveTactics.intros_tac () in
 377           let subgoals = ProofEngineTypes.apply_tactic intros status in
 378           (match subgoals with
 379           | proof, [goal] ->
 380               List.map fst (MetadataQuery.experimental_hint ~dbd (proof, goal))
 381           | _ -> assert false)
 382       | "/elim" ->
 383           let uri =
 384             match term with
 385             | Cic.MutInd (uri, typeno, _) ->
 386                 UriManager.uri_of_uriref uri typeno None
 387             | _ -> raise Not_a_MutInd
 388           in
 389           Whelp.elim ~dbd uri
 390       | _ -> assert false
 391     in
 392     let uris = List.map UriManager.string_of_uri uris in
 393     let id_to_uris =
 394       List.fold_left
 395       (fun env (k,v) -> DisambiguateTypes.Environment.add k v env)
 396         DisambiguateTypes.Environment.empty id_to_uris
 397     in
 398     send_results ~id_to_uris (`Results uris) req outchan
 399   with
 400   | Not_a_MutInd ->
 401       send_results (`Error (MooglePp.pp_error "Not an inductive type"
 402         ("elim requires as input an identifier corresponding to an inductive"
 403          ^ " type")))
 404         req outchan
 405
 406 let callback (dbd, (req: Http_types.request), outchan) =
 407   try
 408     debug_print (sprintf "Received request: %s" req#path);
 409     (match req#path with
 410     | "/getpage" ->
 411           (* TODO implement "is_permitted" *)
 412         (let is_permitted page = not (Pcre.pmatch ~pat:"/" page) in
 413         let page = req#param "url" in
 414         let fname = sprintf "%s/%s" pages_dir page in
 415         let preprocess =
 416           (try
 417             bool_of_string (req#param "preprocess")
 418           with Invalid_argument _ | Http_types.Param_not_found _ -> false)
 419         in
 420         (match page with
 421         | page when is_permitted page && Sys.file_exists fname ->
 422             Http_daemon.send_basic_headers ~code:(`Code 200) outchan;
 423             Http_daemon.send_header "Content-Type" "text/html" outchan;
 424             Http_daemon.send_CRLF outchan;
 425             if preprocess then begin
 426               iter_file
 427                 (fun line ->
 428                   output_string outchan
 429                     ((apply_substs
 430                        ((tag "SEARCH_ENGINE_URL", my_own_url) ::
 431                         (tag "ADVANCED", "no") ::
 432                         (tag "RESULTS", "") ::
 433                         add_param_substs req#params)
 434                        line) ^
 435                     "\n"))
 436                 fname
 437             end else
 438               Http_daemon.send_file ~src:(Http_types.FileSrc fname) outchan
 439         | page -> Http_daemon.respond_forbidden ~url:page outchan))
 440     | "/help" -> Http_daemon.respond ~body:daemon_name outchan
 441     | "/locate" ->
 442         let initial_expression =
 443           try req#param "expression" with Http_types.Param_not_found _ -> ""
 444         in
 445         let expression =
 446           Pcre.replace ~pat:"\\s*$"
 447             (Pcre.replace ~pat:"^\\s*" initial_expression)
 448         in
 449         if expression = "" then
 450           send_results (`Results []) req outchan
 451         else begin
 452           let results = Whelp.locate ~dbd expression in
 453           let results = List.map UriManager.string_of_uri results in
 454           send_results (`Results results) req outchan
 455         end
 456     | "/hint"
 457     | "/elim"
 458     | "/instance"
 459     | "/match" -> exec_action dbd req outchan
 460     | invalid_request ->
 461         Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request))
 462           outchan);
 463     debug_print (sprintf "%s done!" req#path)
 464   with
 465   | Chat_unfinished -> ()
 466   | Http_types.Param_not_found attr_name ->
 467       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 468   | CicNotationParser.Parse_error msg ->
 469       send_results (`Error (MooglePp.pp_error "Parse error" msg)) req outchan
 470   | Stdpp.Exc_located (floc, Stream.Error msg) ->
 471       send_results (`Error (MooglePp.pp_error "Parse error" msg)) req outchan
 472   | Stdpp.Exc_located (floc, exn) ->
 473       let msg = Printexc.to_string exn in
 474       send_results (`Error (MooglePp.pp_error "Unknown error" msg)) req outchan
 475   | Unbound_identifier id ->
 476       send_results (`Error (MooglePp.pp_error "Unbound identifier" id)) req
 477         outchan
 478   | exn ->
 479       let exn_string = Printexc.to_string exn in
 480       debug_print exn_string;
 481       let msg = MooglePp.pp_error "Uncaught exception" exn_string in
 482       send_results (`Error msg) req outchan
 483
 484 let callback dbd req ch =
 485   HExtlib.finally
 486     (fun () -> try close_out ch with Sys_error _ -> ())
 487     callback (dbd, req, ch)
 488
 489 let restore_environment () =
 490   match
 491     Helm_registry.get_opt Helm_registry.string "search_engine.environment_dump"
 492   with
 493   | None -> ()
 494   | Some fname ->
 495       printf "Restoring Cic environment from %s ... " fname; flush stdout;
 496       let ic = open_in fname in
 497       CicEnvironment.restore_from_channel ic;
 498       close_in ic;
 499       printf "done!\n"; flush stdout
 500
 501 let read_notation () =
 502   ignore (CicNotation2.load_notation ~include_paths:[]
 503    (Helm_registry.get "search_engine.notations"));
 504   ignore (CicNotation2.load_notation ~include_paths:[]
 505    (Helm_registry.get "search_engine.interpretations"))
 506
 507 let _ =
 508   printf "%s started and listening on port %d\n" daemon_name port;
 509   printf "Current directory is %s\n" (Sys.getcwd ());
 510   printf "HTML directory is %s\n" pages_dir;
 511   flush stdout;
 512   Unix.putenv "http_proxy" "";
 513   let dbd =
 514     HMysql.quick_connect
 515       ~host:(Helm_registry.get "db.host")
 516       ~database:(Helm_registry.get "db.database")
 517       ~user:(Helm_registry.get "db.user")
 518       ()
 519   in
 520   restore_environment ();
 521   read_notation ();
 522   let d_spec = Http_daemon.daemon_spec ~port ~callback:(callback dbd) () in
 523   Http_daemon.main d_spec;
 524   printf "%s is terminating, bye!\n" daemon_name
 525