helm/searchEngine/searchEngine.ml

   1 (* Copyright (C) 2002, 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 module T = MQGTypes
  27 module U = MQGUtil
  28 module G = MQueryGenerator
  29 module C = MQIConn
  30
  31 open Http_types ;;
  32
  33 let debug = true;;
  34 let debug_print s = if debug then prerr_endline s;;
  35 Http_common.debug := true;;
  36 (* Http_common.debug := true;; *)
  37
  38 open Printf;;
  39
  40 let daemon_name = "Search Engine";;
  41
  42   (* First of all we load the configuration *)
  43 let _ =
  44  let configuration_file = "searchEngine.conf.xml" in
  45   Helm_registry.load_from configuration_file
  46 ;;
  47
  48 let port = Helm_registry.get_int "search_engine.port";;
  49
  50 let pages_dir = Helm_registry.get "search_engine.html_dir";;
  51
  52   (** accepted HTTP servers for ask_uwobo method forwarding *)
  53 let valid_servers= Helm_registry.get_string_list "search_engine.valid_servers";;
  54
  55 let interactive_user_uri_choice_TPL = pages_dir ^ "/templateambigpdq1.html";;
  56 let interactive_interpretation_choice_TPL =
  57   pages_dir ^ "/templateambigpdq2.html";;
  58 let constraints_choice_TPL = pages_dir ^ "/constraints_choice_template.html";;
  59 (* let final_results_TPL = pages_dir ^ "/templateambigpdq3.html";; *)
  60 let final_results_TPL = pages_dir ^ "/moogle.html";;
  61
  62 let my_own_url =
  63  let ic = Unix.open_process_in "hostname -f" in
  64  let hostname = input_line ic in
  65  ignore (Unix.close_process_in ic);
  66  sprintf "http://%s:%d" hostname port
  67 ;;
  68
  69 exception Chat_unfinished
  70 exception Invalid_action of string  (* invalid action for "/search" method *)
  71
  72 let javascript_quote s =
  73  let rex = Pcre.regexp "'" in
  74  let rex' = Pcre.regexp "\"" in
  75   Pcre.replace ~rex ~templ:"\\'"
  76    (Pcre.replace ~rex:rex' ~templ:"\\\"" s)
  77 ;;
  78
  79   (* build a bool from a 1-character-string *)
  80 let bool_of_string' = function
  81   | "0" -> false
  82   | "1" -> true
  83   | s -> failwith ("Can't parse a boolean from string: " ^ s)
  84 ;;
  85
  86   (* build an int option from a string *)
  87 let int_of_string' = function
  88   | "_" -> None
  89   | s ->
  90       try
  91         Some (int_of_string s)
  92       with Failure "int_of_string" ->
  93         failwith ("Can't parse an int option from string: " ^ s)
  94 ;;
  95
  96   (* HTML pretty printers for mquery_generator types *)
  97
  98 let html_of_r_obj (pos, uri) =
  99   sprintf
 100     "<tr><td><input type='checkbox' name='constr_obj' checked='on'/></td><td>%s</td><td>%s</td><td>%s</td></tr>"
 101     uri (U.text_of_position pos)
 102     (if U.is_main_position pos then
 103       sprintf "<input name='obj_depth' size='2' type='text' value='%s' />"
 104         (U.text_of_depth pos "")
 105     else
 106       "<input type=\"hidden\" name=\"obj_depth\" />")
 107 ;;
 108
 109 let html_of_r_rel pos =
 110   sprintf
 111     "<tr><td><input type='checkbox' name='constr_rel' checked='on'/></td><td>%s</td><td><input name='rel_depth' size='2' type='text' value='%s' /></td></tr>"
 112     (U.text_of_position (pos:>T.full_position)) (U.text_of_depth (pos:>T.full_position) "")
 113 ;;
 114
 115 let html_of_r_sort (pos, sort) =
 116   sprintf
 117     "<tr><td><input type='checkbox' name='constr_sort' checked='on'/></td><td>%s</td><td>%s</td><td><input name='sort_depth' size='2' type='text' value='%s'/></td></tr>"
 118     (U.text_of_sort sort) (U.text_of_position (pos:>T.full_position)) (U.text_of_depth (pos:>T.full_position) "")
 119 ;;
 120
 121   (** pretty print a MathQL query result to an HELM theory file *)
 122 let theory_of_result result =
 123  let results_no = List.length result in
 124   if results_no > 0 then
 125    let mode = if results_no > 10 then "linkonly" else "typeonly" in
 126    let results =
 127     let idx = ref (results_no + 1) in
 128      List.fold_right
 129       (fun (uri,attrs) i ->
 130         decr idx ;
 131         "<tr><td valign=\"top\">" ^ string_of_int !idx ^ ".</td><td><ht:OBJECT uri=\"" ^ uri ^ "\" mode=\"" ^ mode ^ "\"/></td></tr>" ^  i
 132       ) result ""
 133    in
 134     "<h1>Query Results:</h1><table xmlns:ht=\"http://www.cs.unibo.it/helm/namespaces/helm-theory\">" ^ results ^ "</table>"
 135   else
 136     "<h1>Query Results:</h1><p>No results found!</p>"
 137 ;;
 138
 139 let pp_result result =
 140  "<html xmlns:ht=\"http://www.cs.unibo.it/helm/namespaces/helm-theory\">\n<head><title>Query Results</title><style> A { text-decoration: none } </style></head>\n<body>" ^ theory_of_result result ^ "</body></html>"
 141 ;;
 142
 143   (** chain application of Pcre substitutions *)
 144 let rec apply_substs substs line =
 145   match substs with
 146   | [] -> line
 147   | (rex, templ) :: rest -> apply_substs rest (Pcre.replace ~rex ~templ line)
 148   (** fold like function on files *)
 149 let fold_file f init fname =
 150   let inchan = open_in fname in
 151   let rec fold_lines' value =
 152     try
 153       let line = input_line inchan in
 154       fold_lines' (f value line)
 155     with End_of_file -> value
 156   in
 157   let res = (try fold_lines' init with e -> (close_in inchan; raise e)) in
 158   close_in inchan;
 159   res
 160   (** iter like function on files *)
 161 let iter_file f = fold_file (fun _ line -> f line) ()
 162
 163 let (title_tag_RE, choices_tag_RE, msg_tag_RE, id_to_uris_RE, id_RE,
 164     interpretations_RE, interpretations_labels_RE, results_RE, new_aliases_RE,
 165     form_RE, variables_initialization_RE, search_engine_url_RE)
 166   =
 167   (Pcre.regexp "@TITLE@", Pcre.regexp "@CHOICES@", Pcre.regexp "@MSG@",
 168   Pcre.regexp "@ID_TO_URIS@", Pcre.regexp "@ID@",
 169   Pcre.regexp "@INTERPRETATIONS@", Pcre.regexp "@INTERPRETATIONS_LABELS@",
 170   Pcre.regexp "@RESULTS@", Pcre.regexp "@NEW_ALIASES@", Pcre.regexp "@FORM@",
 171   Pcre.regexp "@VARIABLES_INITIALIZATION@", Pcre.regexp "@SEARCH_ENGINE_URL@")
 172 let server_and_port_url_RE = Pcre.regexp "^http://([^/]+)/.*$"
 173
 174 let pp_error = sprintf "<html><body><h1>Error: %s</h1></body></html>";;
 175
 176 let bad_request body outchan =
 177   Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan
 178 ;;
 179
 180 let contype = "Content-Type", "text/html";;
 181
 182 (* SEARCH ENGINE functions *)
 183
 184 let get_constraints term =
 185  function
 186     | "/locateInductivePrinciple" ->
 187       None,
 188       (CGLocateInductive.get_constraints term),
 189       (None,None,None)
 190     | "/searchPattern" ->
 191      let constr_obj, constr_rel, constr_sort =
 192        CGSearchPattern.get_constraints term in
 193      (Some CGSearchPattern.universe),
 194      (constr_obj, constr_rel, constr_sort),
 195      (Some constr_obj, Some constr_rel, Some constr_sort)
 196     | "/matchConclusion" ->
 197      let list_of_must, only = CGMatchConclusion.get_constraints [] [] term in
 198 (* FG: there is no way to choose the block number ***************************)
 199      let block = pred (List.length list_of_must) in
 200       (Some CGMatchConclusion.universe),
 201       (List.nth list_of_must block, [], []), (Some only, None, None)
 202     | _ -> assert false
 203 ;;
 204
 205 (*
 206   format:
 207     <must_obj> ':' <must_rel> ':' <must_sort> ':' <only_obj> ':' <only_rel> ':' <only_sort>
 208
 209     <must_*> ::= ('0'|'1') ('_'|<int>) (',' ('0'|'1') ('_'|<int>))*
 210     <only> ::= '0'|'1'
 211 *)
 212 let add_user_constraints ~constraints
 213  ((obj, rel, sort), (only_obj, only_rel, only_sort))
 214 =
 215   let parse_must s =
 216     let l = Pcre.split ~pat:"," s in
 217     (try
 218       List.map
 219         (fun s ->
 220           let subs = Pcre.extract ~pat:"^(.)(\\d+|_)$" s in
 221           (bool_of_string' subs.(1), int_of_string' subs.(2)))
 222         l
 223      with
 224       Not_found -> failwith ("Can't parse constraint string: " ^ constraints)
 225     )
 226   in
 227     (* to be used on "obj" *)
 228   let add_user_must33 user_must must =
 229     List.map2
 230      (fun (b, i) (p, u) ->
 231        if b then Some (U.set_full_position p i, u) else None)
 232      user_must must
 233   in
 234     (* to be used on "rel" *)
 235   let add_user_must22 user_must must =
 236     List.map2
 237      (fun (b, i) p -> if b then Some (U.set_main_position p i) else None)
 238      user_must must
 239   in
 240     (* to be used on "sort" *)
 241   let add_user_must32 user_must must =
 242     List.map2
 243      (fun (b, i) (p, s)-> if b then Some (U.set_main_position p i, s) else None)
 244      user_must must
 245   in
 246   match Pcre.split ~pat:":" constraints with
 247   | [user_obj;user_rel;user_sort;user_only_obj;user_only_rel;user_only_sort] ->
 248       let
 249        (user_obj,user_rel,user_sort,user_only_obj,user_only_rel,user_only_sort)
 250       =
 251         (parse_must user_obj,
 252         parse_must user_rel,
 253         parse_must user_sort,
 254         bool_of_string' user_only_obj,
 255         bool_of_string' user_only_rel,
 256         bool_of_string' user_only_sort)
 257       in
 258       let only' =
 259        (if user_only_obj  then only_obj else None),
 260        (if user_only_rel  then only_rel else None),
 261        (if user_only_sort then only_sort else None)
 262       in
 263       let must' =
 264        let rec filter_some =
 265         function
 266            [] -> []
 267          | None::tl -> filter_some tl
 268          | (Some x)::tl -> x::(filter_some tl)
 269        in
 270         filter_some (add_user_must33 user_obj obj),
 271         filter_some (add_user_must22 user_rel rel),
 272         filter_some (add_user_must32 user_sort sort)
 273       in
 274       (must', only')
 275   | _ -> failwith ("Can't parse constraint string: " ^ constraints)
 276 in
 277
 278 let send_results results
 279   ?(id_to_uris = DisambiguatingParser.EnvironmentP3.of_string "") req outchan
 280   =
 281   Http_daemon.send_basic_headers ~code:200 outchan ;
 282   Http_daemon.send_header "Content-Type" "text/xml" outchan;
 283   Http_daemon.send_CRLF outchan ;
 284   let subst =
 285     (search_engine_url_RE, my_own_url) ::
 286     (results_RE, theory_of_result results)::
 287     (List.map
 288       (function (key,value) ->
 289         let key' = (Pcre.extract ~pat:"param\\.(.*)" key).(1) in
 290         Pcre.regexp ("@" ^ key' ^ "@"), value)
 291       (List.filter
 292               (fun (key,_) as p-> Pcre.pmatch ~pat:"^param\\." key)
 293               req#params))
 294     in
 295     iter_file
 296       (fun line ->
 297         let new_aliases =
 298           DisambiguatingParser.EnvironmentP3.to_string id_to_uris
 299         in
 300         let processed_line =
 301           apply_substs
 302             (* CSC: Bug here: this is a string, not an array! *)
 303             ((new_aliases_RE, "'" ^ javascript_quote new_aliases ^ "'")::subst)
 304             line
 305         in
 306         output_string outchan (processed_line ^ "\n"))
 307       final_results_TPL
 308 in
 309
 310 (* HTTP DAEMON CALLBACK *)
 311
 312 let build_dynamic_uri url params =
 313   let p =
 314     String.concat "&" (List.map  (fun (key,value) -> (key ^ "=" ^ (Netencoding.Url.encode value))) params) in
 315   url ^ "?" ^ p
 316 in
 317
 318 let build_uwobo_request (req: Http_types.request) outchan =
 319   prerr_endline ("ECCOLO: " ^ req#param "param.SEARCH_ENGINE_URL");
 320   let xmluri = build_dynamic_uri ((req#param "param.SEARCH_ENGINE_URL") ^ "/search") req#params in
 321   prerr_endline ("xmluri: " ^ xmluri);
 322   (*let xmluri = Netencoding.Url.encode xmluri in*)
 323   let server_and_port = req#param "param.processorURL" in
 324   let newreq =
 325     build_dynamic_uri
 326       (server_and_port ^ "apply")
 327       (("xmluri",xmluri)::("keys",(req#param "param.thkeys"))::req#params) in
 328   (* if List.mem server_and_port valid_servers then *)
 329   prerr_endline newreq;
 330   if true then
 331     Http_daemon.respond
 332       ~headers:["Content-Type", "text/html"]
 333       ~body:(Http_client.http_get newreq)
 334       outchan
 335   else
 336     Http_daemon.respond
 337       ~body:(pp_error ("Untrusted UWOBO server: " ^ server_and_port ^
 338       (String.concat "\n" valid_servers)))
 339       outchan
 340 in
 341
 342 let proxy url outchan =
 343   let server_and_port =
 344     (Pcre.extract ~rex:server_and_port_url_RE url).(1)
 345   in
 346   if List.mem server_and_port valid_servers then
 347     Http_daemon.respond
 348       ~headers:["Content-Type", "text/html"]
 349       ~body:(Http_client.http_get url)
 350       outchan
 351   else
 352     Http_daemon.respond
 353       ~body:(pp_error ("Untrusted UWOBO server: " ^ server_and_port))
 354       outchan
 355 in
 356
 357 let callback mqi_handle (req: Http_types.request) outchan =
 358   try
 359     debug_print (sprintf "Received request: %s" req#path);
 360     (match req#path with
 361     | "/help" -> Http_daemon.respond ~body:"HELM Search Engine" outchan
 362     | "/search" ->
 363         let initial_expression =
 364           try req#param "expression" with Http_types.Param_not_found _ -> ""
 365         in
 366         let expression =
 367           Pcre.replace ~pat:"\\s*$"
 368             (Pcre.replace ~pat:"^\\s*" initial_expression)
 369         in
 370         if expression = "" then
 371           send_results [] req outchan
 372         else
 373           (try
 374             let results =
 375               match req#param "action" with
 376               | "locate" ->
 377                   prerr_endline ("EXPRESSION : " ^ expression);
 378                   let query = G.locate expression in
 379                   MQueryInterpreter.execute mqi_handle query
 380               | "hint" -> failwith "NOT IMPLEMENTED"  (* TODO *)
 381               | "match" -> failwith "NOT IMPLEMENTED" (* TODO *)
 382               | "elim" -> failwith "NOT IMPLEMENTED"  (* TODO *)
 383               | action -> raise (Invalid_action action)
 384             in
 385             send_results results req outchan
 386           with Invalid_action action ->
 387               Http_daemon.respond_error ~status:(`Client_error `Bad_request)
 388                 ~body:("Invalid action " ^ action) outchan)
 389     | "/execute" ->
 390         let query_string = req#param "query" in
 391         let lexbuf = Lexing.from_string query_string in
 392         let query = MQueryUtil.query_of_text lexbuf in
 393         let result = MQueryInterpreter.execute mqi_handle query in
 394         let result_string = pp_result result in
 395         Http_daemon.respond ~body:result_string ~headers:[contype] outchan
 396 (*  Http_daemon.respond ~headers:[contype] ~body:(pp_result result) outchan *)
 397     | "/unreferred" ->
 398         let target = req#param "target" in
 399         let source = req#param "source" in
 400         let query = G.unreferred target source in
 401         let result = MQueryInterpreter.execute mqi_handle query in
 402         Http_daemon.respond ~headers:[contype] ~body:(pp_result result) outchan
 403     | "/getpage" ->
 404         (* TODO implement "is_permitted" *)
 405         (let is_permitted _ = true in
 406         let remove_fragment uri = Pcre.replace ~pat:"#.*" uri in
 407         let page = remove_fragment (req#param "url") in
 408         let preprocess =
 409           (try
 410             bool_of_string (req#param "preprocess")
 411           with Invalid_argument _ | Http_types.Param_not_found _ -> false)
 412         in
 413         (match page with
 414         | page when is_permitted page ->
 415             (let fname = sprintf "%s/%s" pages_dir (remove_fragment page) in
 416             Http_daemon.send_basic_headers ~code:200 outchan;
 417             Http_daemon.send_header "Content-Type" "text/html" outchan;
 418             Http_daemon.send_CRLF outchan;
 419             if preprocess then begin
 420               iter_file
 421                 (fun line ->
 422                   output_string outchan
 423                     ((apply_substs
 424                        ((search_engine_url_RE, my_own_url) ::
 425                        (List.map
 426                          (function (key,value) ->
 427                            let key' =
 428                             (Pcre.extract ~pat:"param\\.(.*)" key).(1)
 429                            in
 430                             Pcre.regexp ("@" ^ key' ^ "@"), value
 431                          )
 432                          (List.filter
 433                            (fun (key,_) as p-> Pcre.pmatch ~pat:"^param\\." key)
 434                            req#params)
 435                        ))
 436                        line) ^
 437                     "\n"))
 438                 fname
 439             end else
 440               Http_daemon.send_file ~src:(FileSrc fname) outchan)
 441         | page -> Http_daemon.respond_forbidden ~url:page outchan))
 442     (* OLD | "/ask_uwobo" -> proxy (req#param "url") outchan *)
 443     | "/ask_uwobo" -> build_uwobo_request req outchan
 444     | "/searchPattern"
 445     | "/matchConclusion"
 446     | "/locateInductivePrinciple" ->
 447         let term_string = req#param "term" in
 448         let (context, metasenv) = ([], []) in
 449         let id_to_uris_raw = req#param "aliases" in
 450         let parse_interpretation_choices choices =
 451          List.map int_of_string (Pcre.split ~pat:" " choices) in
 452         let parse_choices choices_raw =
 453           let choices = Pcre.split ~pat:";" choices_raw in
 454           List.fold_left
 455             (fun f x ->
 456               match Pcre.split ~pat:"\\s" x with
 457               | ""::id::tail
 458               | id::tail when id<>"" ->
 459                   (fun id' ->
 460                     if id = id' then
 461                       Some (List.map (fun u -> Netencoding.Url.decode u) tail)
 462                     else
 463                       f id')
 464               | _ -> failwith "Can't parse choices")
 465             (fun _ -> None)
 466             choices
 467         in
 468         let id_to_uris =
 469          DisambiguatingParser.EnvironmentP3.of_string id_to_uris_raw in
 470         let id_to_choices =
 471           try
 472             let choices_raw = req#param "choices" in
 473             parse_choices choices_raw
 474           with Http_types.Param_not_found _ -> (fun _ -> None)
 475         in
 476         let interpretation_choices =
 477           try
 478             let choices_raw = req#param "interpretation_choices" in
 479             Some (parse_interpretation_choices choices_raw)
 480           with Http_types.Param_not_found _ -> None
 481         in
 482         let module Chat: DisambiguateTypes.Callbacks =
 483           struct
 484
 485             let interactive_user_uri_choice
 486               ~selection_mode ?ok
 487               ?enable_button_for_non_vars ~(title: string) ~(msg: string)
 488               ~(id: string) (choices: string list)
 489               =
 490                 (match id_to_choices id with
 491                 | Some choices -> choices
 492                 | None ->
 493                   let msg = Pcre.replace ~pat:"\'" ~templ:"\\\'" msg in
 494                   (match selection_mode with
 495                   | `SINGLE -> assert false
 496                   | `MULTIPLE ->
 497                       Http_daemon.send_basic_headers ~code:200 outchan ;
 498                       Http_daemon.send_CRLF outchan ;
 499                       iter_file
 500                         (fun line ->
 501                           let formatted_choices =
 502                             String.concat ","
 503                               (List.map (fun uri -> sprintf "\'%s\'" uri) choices)
 504                           in
 505                           let processed_line =
 506                             apply_substs
 507                               [title_tag_RE, title;
 508                                choices_tag_RE, formatted_choices;
 509                                msg_tag_RE, msg;
 510                                id_to_uris_RE, id_to_uris_raw;
 511                                id_RE, id]
 512                               line
 513                           in
 514                           output_string outchan (processed_line ^ "\n"))
 515                         interactive_user_uri_choice_TPL;
 516                       raise Chat_unfinished))
 517
 518             let interactive_interpretation_choice interpretations =
 519              match interpretation_choices with
 520                 Some l -> prerr_endline "CARRAMBA" ; l
 521               | None ->
 522                 let html_interpretations_labels =
 523                   String.concat ", "
 524                     (List.map
 525                       (fun l ->
 526                         "\'" ^
 527                         (String.concat "<br />"
 528                           (List.map
 529                             (fun (id, value) ->
 530                               let id = javascript_quote id in
 531                               let value = javascript_quote value in
 532                                sprintf "%s = %s" id value)
 533                             l)) ^
 534                         "\'")
 535                     interpretations)
 536                 in
 537                 let html_interpretations =
 538                  let rec aux n =
 539                   function
 540                      [] -> []
 541                    | _::tl -> ("'" ^ string_of_int n ^ "'")::(aux (n+1) tl)
 542                  in
 543                   String.concat ", " (aux 0 interpretations)
 544                 in
 545                 Http_daemon.send_basic_headers ~code:200 outchan ;
 546                 Http_daemon.send_CRLF outchan ;
 547                 iter_file
 548                   (fun line ->
 549                     let processed_line =
 550                       apply_substs
 551                         [interpretations_RE, html_interpretations;
 552                          interpretations_labels_RE, html_interpretations_labels]
 553                         line
 554                     in
 555                     output_string outchan (processed_line ^ "\n"))
 556                   interactive_interpretation_choice_TPL;
 557                 raise Chat_unfinished
 558
 559             let input_or_locate_uri ~title ?id () =
 560              assert false
 561
 562           end
 563         in
 564         let module Disambiguate' = DisambiguatingParser.Make(Chat) in
 565         let (id_to_uris', metasenv', term') =
 566          match
 567           Disambiguate'.disambiguate_term mqi_handle
 568             context metasenv term_string id_to_uris
 569          with
 570             [id_to_uris',metasenv',term'] -> id_to_uris',metasenv',term'
 571           | _ -> assert false
 572         in
 573           let universe,
 574               ((must_obj, must_rel, must_sort) as must'),
 575               ((only_obj, only_rel, only_sort) as only) =
 576             get_constraints term' req#path
 577           in
 578           let must'', only' =
 579             (try
 580               add_user_constraints
 581                 ~constraints:(req#param "constraints")
 582                 (must', only)
 583             with Http_types.Param_not_found _ ->
 584               let variables =
 585                "var aliases = '" ^ id_to_uris_raw ^ "';\n" ^
 586                "var constr_obj_len = " ^
 587                 string_of_int (List.length must_obj) ^ ";\n" ^
 588                "var constr_rel_len = " ^
 589                 string_of_int (List.length must_rel) ^ ";\n" ^
 590                "var constr_sort_len = " ^
 591                 string_of_int (List.length must_sort) ^ ";\n" in
 592               let form =
 593                 (if must_obj = [] then "" else
 594                   "<h4>Obj constraints</h4>" ^
 595                   "<table>" ^
 596                   (String.concat "\n" (List.map html_of_r_obj must_obj)) ^
 597                   "</table>" ^
 598                   (* The following three lines to make Javascript create *)
 599                   (* the constr_obj[] and obj_depth[] arrays even if we  *)
 600                   (* have only one real entry.                           *)
 601                   "<input type=\"hidden\" name=\"constr_obj\" />" ^
 602                   "<input type=\"hidden\" name=\"obj_depth\" />") ^
 603                 (if must_rel = [] then "" else
 604                  "<h4>Rel constraints</h4>" ^
 605                  "<table>" ^
 606                  (String.concat "\n" (List.map html_of_r_rel must_rel)) ^
 607                  "</table>" ^
 608                   (* The following two lines to make Javascript create *)
 609                   (* the constr_rel[] and rel_depth[] arrays even if   *)
 610                   (* we have only one real entry.                      *)
 611                   "<input type=\"hidden\" name=\"constr_rel\" />" ^
 612                   "<input type=\"hidden\" name=\"rel_depth\" />") ^
 613                 (if must_sort = [] then "" else
 614                   "<h4>Sort constraints</h4>" ^
 615                   "<table>" ^
 616                   (String.concat "\n" (List.map html_of_r_sort must_sort)) ^
 617                   "</table>" ^
 618                   (* The following two lines to make Javascript create *)
 619                   (* the constr_sort[] and sort_depth[] arrays even if *)
 620                   (* we have only one real entry.                      *)
 621                   "<input type=\"hidden\" name=\"constr_sort\" />" ^
 622                   "<input type=\"hidden\" name=\"sort_depth\" />") ^
 623                   "<h4>Only constraints</h4>" ^
 624                   "Enforce Only constraints for objects: " ^
 625                     "<input type='checkbox' name='only_obj'" ^
 626                     (if only_obj = None then "" else " checked='yes'") ^ " /><br />" ^
 627                   "Enforce Rel constraints for objects: " ^
 628                     "<input type='checkbox' name='only_rel'" ^
 629                     (if only_rel = None then "" else " checked='yes'") ^ " /><br />" ^
 630                   "Enforce Sort constraints for objects: " ^
 631                     "<input type='checkbox' name='only_sort'" ^
 632                     (if only_sort = None then "" else " checked='yes'") ^ " /><br />"
 633               in
 634               Http_daemon.send_basic_headers ~code:200 outchan ;
 635               Http_daemon.send_CRLF outchan ;
 636               iter_file
 637                 (fun line ->
 638                   let processed_line =
 639                     apply_substs
 640                      [form_RE, form ;
 641                       variables_initialization_RE, variables] line
 642                   in
 643                   output_string outchan (processed_line ^ "\n"))
 644                 constraints_choice_TPL;
 645                 raise Chat_unfinished)
 646           in
 647           let query =
 648            G.query_of_constraints universe must'' only'
 649           in
 650           let results = MQueryInterpreter.execute mqi_handle query in
 651           send_results results ~id_to_uris:id_to_uris' req outchan
 652     | invalid_request ->
 653         Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan);
 654     debug_print (sprintf "%s done!" req#path)
 655   with
 656   | Chat_unfinished -> prerr_endline "Chat unfinished, Try again!"
 657   | Http_types.Param_not_found attr_name ->
 658       bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan
 659   | exc ->
 660       let msg = sprintf "Uncaught exception: %s" (Printexc.to_string exc) in
 661        debug_print msg ;
 662        Http_daemon.respond ~body:(pp_error msg) outchan
 663 in
 664 printf "%s started and listening on port %d\n" daemon_name port;
 665 printf "Current directory is %s\n" (Sys.getcwd ());
 666 printf "HTML directory is %s\n" pages_dir;
 667 flush stdout;
 668 Unix.putenv "http_proxy" "";
 669 let mqi_handle = C.init ~log:debug_print () in
 670 Http_daemon.start' ~port (callback mqi_handle);
 671 C.close mqi_handle;
 672 printf "%s is terminating, bye!\n" daemon_name