helm/searchEngine/searchEngine.ml

   1
   2 (* Copyright (C) 2002, HELM Team.
   3  *
   4  * This file is part of HELM, an Hypertextual, Electronic
   5  * Library of Mathematics, developed at the Computer Science
   6  * Department, University of Bologna, Italy.
   7  *
   8  * HELM is free software; you can redistribute it and/or
   9  * modify it under the terms of the GNU General Public License
  10  * as published by the Free Software Foundation; either version 2
  11  * of the License, or (at your option) any later version.
  12  *
  13  * HELM is distributed in the hope that it will be useful,
  14  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16  * GNU General Public License for more details.
  17  *
  18  * You should have received a copy of the GNU General Public License
  19  * along with HELM; if not, write to the Free Software
  20  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  21  * MA  02111-1307, USA.
  22  *
  23  * For details, see the HELM World-Wide-Web page,
  24  * http://cs.unibo.it/helm/.
  25  *)
  26
  27 let debug = true;;
  28 let debug_print s = if debug then prerr_endline s;;
  29 Http_common.debug := debug;;
  30
  31 open Printf;;
  32
  33 let daemon_name = "Search Engine";;
  34 let default_port = 48085;;
  35 let port_env_var = "SEARCH_ENGINE_PORT";;
  36
  37 let port =
  38   try
  39     int_of_string (Sys.getenv port_env_var)
  40   with
  41   | Not_found -> default_port
  42   | Failure "int_of_string" ->
  43       prerr_endline "Warning: invalid port, reverting to default";
  44       default_port
  45 in
  46 let pp_result result =
  47   let result_string = MQueryUtil.text_of_result result "\n" in
  48   (sprintf "<html><body><pre>%s</pre></body></html>" result_string)
  49 in
  50 let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>" in
  51 let callback req outchan =
  52   try
  53     (* TODO catch exceptions *)
  54     (match req#path with
  55     | "/execute" ->
  56         let query_string = req#param "query" in
  57         let lexbuf = Lexing.from_string query_string in
  58         let query = MQueryTParser.query MQueryTLexer.query_token lexbuf in
  59         let result = MQueryGenerator.execute_query query in
  60         let result_string = MQueryUtil.text_of_result result "\n" in
  61         Http_daemon.respond
  62           ~body:
  63             (sprintf
  64               "<html><body><pre>%s</pre></body></html>"
  65               result_string)
  66           outchan
  67     | "/locate" ->
  68         let id = req#param "id" in
  69         let result = MQueryGenerator.locate id in
  70         Http_daemon.respond ~body:(pp_result result) outchan
  71     | "/searchPattern" ->
  72         let term_string = req#param "term" in
  73         let precision = int_of_string (req#param "precision") in
  74         let lexbuf = Lexing.from_string term_string in
  75         let (dom, mkterm) =
  76           CicTextualParser.main CicTextualLexer.token lexbuf
  77         in
  78         (match dom with
  79         | [] -> (* no free variables *)
  80             let term = mkterm (fun _ -> None) in
  81             let result = MQueryGenerator.searchPattern [] [] term precision in
  82             Http_daemon.respond ~body:(pp_result result) outchan
  83         | _ ->
  84             Http_daemon.respond
  85               ~body:(pp_error
  86                 "identifiers resolution in the environment not yet implemented")
  87               outchan)
  88     | invalid_request ->
  89         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan)
  90   with
  91   | Http_request.Param_not_found attr_name ->
  92       Http_daemon.respond_error
  93         ~status:(`Client_error `Bad_request)
  94         ~body:(sprintf "Parameter '%s' is missing" attr_name)
  95         outchan
  96 in
  97 printf "%s started and listening on port %d\n" daemon_name port;
  98 printf "current directory is %s\n" (Sys.getcwd ());
  99 flush stdout;
 100 Http_daemon.start' ~port callback;
 101 printf "%s is terminating, bye!\n" daemon_name
 102