X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FsearchEngine%2FsearchEngine.ml;h=1f45fe67c8424f6b075f24676d17b404e16792e3;hb=741b3e9014f940fbbd34bee7b606ff7e72170452;hp=622f10bd5a618979fcf19551b1c32a659536cd99;hpb=506b4b7597021c98e34fb65cf9d0bb7879f06e92;p=helm.git diff --git a/helm/searchEngine/searchEngine.ml b/helm/searchEngine/searchEngine.ml index 622f10bd5..1f45fe67c 100644 --- a/helm/searchEngine/searchEngine.ml +++ b/helm/searchEngine/searchEngine.ml @@ -1,4 +1,4 @@ -(* Copyright (C) 2002, HELM Team. +(* Copyright (C) 2002-2004, HELM Team. * * This file is part of HELM, an Hypertextual, Electronic * Library of Mathematics, developed at the Computer Science @@ -28,44 +28,59 @@ module U = MQGUtil module G = MQueryGenerator module C = MQIConn -open Http_types ;; +open Http_types -let debug = true;; -let debug_print s = if debug then prerr_endline s;; -Http_common.debug := true;; -(* Http_common.debug := true;; *) +let debug = true +let debug_print s = if debug then prerr_endline s +let _ = Http_common.debug := true +(* let _ = Http_common.debug := false *) - (** accepted HTTP servers for ask_uwobo method forwarding *) -let valid_servers = - [ "mowgli.cs.unibo.it:58080" ; "mowgli.cs.unibo.it" ; "localhost:58080" ];; +open Printf -let mqi_flags = [] (* default MathQL interpreter options *) +let daemon_name = "Search Engine" -open Printf;; +let string_tail s = + let len = String.length s in + String.sub s 1 (len-1) -let daemon_name = "Search Engine";; -let default_port = 58085;; -let port_env_var = "SEARCH_ENGINE_PORT";; + (* First of all we load the configuration *) +let _ = + let configuration_file = "/projects/helm/etc/searchEngine.conf.xml" in + Helm_registry.load_from configuration_file -let pages_dir = - try - Sys.getenv "SEARCH_ENGINE_HTML_DIR" - with Not_found -> "html" (* relative to searchEngine's document root *) -;; -let interactive_user_uri_choice_TPL = pages_dir ^ "/templateambigpdq1.html";; -let interactive_interpretation_choice_TPL = - pages_dir ^ "/templateambigpdq2.html";; -let constraints_choice_TPL = pages_dir ^ "/constraints_choice_template.html";; -let final_results_TPL = pages_dir ^ "/templateambigpdq3.html";; +let port = Helm_registry.get_int "search_engine.port" + +let pages_dir = Helm_registry.get "search_engine.html_dir" + + (** accepted HTTP servers for ask_uwobo method forwarding *) +let valid_servers= Helm_registry.get_string_list "search_engine.valid_servers" + +let interactive_user_uri_choice_TPL = pages_dir ^ "/moogle_chat1.html" +let interactive_interpretation_choice_TPL = pages_dir ^ "/moogle_chat2.html" +let constraints_choice_TPL = pages_dir ^ "/moogle_constraints_choice.html" +let moogle_TPL = pages_dir ^ "/moogle.html" + +let my_own_url = + let ic = Unix.open_process_in "hostname -f" in + let hostname = input_line ic in + ignore (Unix.close_process_in ic); + sprintf "http://%s:%d" hostname port exception Chat_unfinished +exception Invalid_action of string (* invalid action for "/search" method *) +exception Unbound_identifier of string + +let javascript_quote s = + let rex = Pcre.regexp "'" in + let rex' = Pcre.regexp "\"" in + Pcre.replace ~rex ~templ:"\\'" + (Pcre.replace ~rex:rex' ~templ:"\\\"" s) (* build a bool from a 1-character-string *) let bool_of_string' = function | "0" -> false | "1" -> true | s -> failwith ("Can't parse a boolean from string: " ^ s) -;; (* build an int option from a string *) let int_of_string' = function @@ -75,7 +90,6 @@ let int_of_string' = function Some (int_of_string s) with Failure "int_of_string" -> failwith ("Can't parse an int option from string: " ^ s) -;; (* HTML pretty printers for mquery_generator types *) @@ -88,41 +102,71 @@ let html_of_r_obj (pos, uri) = (U.text_of_depth pos "") else "") -;; let html_of_r_rel pos = sprintf "%s" (U.text_of_position (pos:>T.full_position)) (U.text_of_depth (pos:>T.full_position) "") -;; let html_of_r_sort (pos, sort) = sprintf "%s%s" (U.text_of_sort sort) (U.text_of_position (pos:>T.full_position)) (U.text_of_depth (pos:>T.full_position) "") -;; + +let query_of_req (req: Http_types.request) = + match req#path with + | "/elim" -> "Elim" + | "/match" -> "Match" + | "/hint" -> "Hint" + | "/locate" -> "Locate" + | _ -> assert false (** pretty print a MathQL query result to an HELM theory file *) -let theory_of_result result = +let theory_of_result req result = let results_no = List.length result in if results_no > 0 then let mode = if results_no > 10 then "linkonly" else "typeonly" in let results = let idx = ref (results_no + 1) in List.fold_right - (fun (uri,attrs) i -> + (fun uri i -> decr idx ; - "" ^ string_of_int !idx ^ "." ^ i - ) result "" + sprintf + " + %d. + + %s" + !idx uri mode i) + result "" in - "

Query Results:

" ^ results ^ "
" + sprintf + "
+ + + + + +
%s%d result%s found
+
+
+
+ %s
+
" + (query_of_req req) + results_no (if results_no > 1 then "s" else "") results else - "

Query Results:

No results found!

" -;; - -let pp_result result = - "\nQuery Results\n" ^ theory_of_result result ^ "" -;; + "
no results found
" + +let pp_result req result = + sprintf + " + + Query results + + + %s + " + (theory_of_result req result) (** chain application of Pcre substitutions *) let rec apply_substs substs line = @@ -144,57 +188,55 @@ let fold_file f init fname = (** iter like function on files *) let iter_file f = fold_file (fun _ line -> f line) () -let (title_tag_RE, choices_tag_RE, msg_tag_RE, id_to_uris_RE, id_RE, - interpretations_RE, interpretations_labels_RE, results_RE, new_aliases_RE, - form_RE, variables_initialization_RE) +let (expression_tag_RE, action_tag_RE, advanced_tag_RE, + advanced_checked_RE, simple_checked_RE, + title_tag_RE, no_choices_tag_RE, current_choices_tag_RE, + choices_tag_RE, msg_tag_RE, id_to_uris_RE, id_RE, iden_tag_RE, + interpretations_RE, interpretations_labels_RE, results_RE, new_aliases_RE, + form_RE, variables_initialization_RE, search_engine_url_RE) = - (Pcre.regexp "@TITLE@", Pcre.regexp "@CHOICES@", Pcre.regexp "@MSG@", - Pcre.regexp "@ID_TO_URIS@", Pcre.regexp "@ID@", - Pcre.regexp "@INTERPRETATIONS@", Pcre.regexp "@INTERPRETATIONS_LABELS@", - Pcre.regexp "@RESULTS@", Pcre.regexp "@NEW_ALIASES@", Pcre.regexp "@FORM@", - Pcre.regexp "@VARIABLES_INITIALIZATION@") + (Pcre.regexp "@EXPRESSION@", Pcre.regexp "@ACTION@", Pcre.regexp "@ADVANCED@", + Pcre.regexp "@ADVANCED_CHECKED@", Pcre.regexp "@SIMPLE_CHECKED@", + Pcre.regexp "@TITLE@", Pcre.regexp "@NO_CHOICES@", + Pcre.regexp "@CURRENT_CHOICES@", + Pcre.regexp "@CHOICES@", Pcre.regexp "@MSG@", + Pcre.regexp "@ID_TO_URIS@", Pcre.regexp "@ID@", Pcre.regexp "@IDEN@", + Pcre.regexp "@INTERPRETATIONS@", Pcre.regexp "@INTERPRETATIONS_LABELS@", + Pcre.regexp "@RESULTS@", Pcre.regexp "@NEW_ALIASES@", Pcre.regexp "@FORM@", + Pcre.regexp "@VARIABLES_INITIALIZATION@", Pcre.regexp "@SEARCH_ENGINE_URL@") let server_and_port_url_RE = Pcre.regexp "^http://([^/]+)/.*$" -let port = - try - int_of_string (Sys.getenv port_env_var) - with - | Not_found -> default_port - | Failure "int_of_string" -> - prerr_endline "Warning: invalid port, reverting to default"; - default_port -;; - -let pp_error = sprintf "

Error: %s

";; +(* let pp_error = sprintf "

Error: %s

" *) +let pp_error title msg = + sprintf "
%s: %s
" title msg let bad_request body outchan = - Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan -;; + Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) ~body + outchan -let contype = "Content-Type", "text/html";; +let contype = "Content-Type", "text/html" (* SEARCH ENGINE functions *) let get_constraints term = function - | "/locateInductivePrinciple" -> - CGLocateInductive.universe, + | "/elim" -> + None, (CGLocateInductive.get_constraints term), (None,None,None) - | "/searchPattern" -> + | "/match" -> let constr_obj, constr_rel, constr_sort = CGSearchPattern.get_constraints term in - CGSearchPattern.universe, - (constr_obj, constr_rel, constr_sort), - (Some constr_obj, Some constr_rel, Some constr_sort) - | "/matchConclusion" -> + (Some CGSearchPattern.universe), + (constr_obj, constr_rel, constr_sort), + (Some constr_obj, Some constr_rel, Some constr_sort) + | "/hint" -> let list_of_must, only = CGMatchConclusion.get_constraints [] [] term in (* FG: there is no way to choose the block number ***************************) let block = pred (List.length list_of_must) in - CGMatchConclusion.universe, + (Some CGMatchConclusion.universe), (List.nth list_of_must block, [], []), (Some only, None, None) | _ -> assert false -;; (* format: @@ -267,40 +309,384 @@ let add_user_constraints ~constraints in (must', only') | _ -> failwith ("Can't parse constraint string: " ^ constraints) -in + +let send_results results + ?(id_to_uris = DisambiguatingParser.EnvironmentP3.of_string "") + (req: Http_types.request) outchan + = + Http_daemon.send_basic_headers ~code:(`Code 200) outchan ; + Http_daemon.send_header "Content-Type" "text/xml" outchan; + Http_daemon.send_CRLF outchan ; + let results_string = + match results with + | `Results r -> theory_of_result req r + | `Error msg -> msg + in + let subst = + (search_engine_url_RE, my_own_url) :: + (results_RE, results_string):: + (advanced_tag_RE, req#param "advanced"):: + (expression_tag_RE, req#param "expression"):: + (List.map + (function (key,value) -> + let key' = (Pcre.extract ~pat:"param\\.(.*)" key).(1) in + Pcre.regexp ("@" ^ key' ^ "@"), value) + (List.filter + (fun (key,_) as p-> Pcre.pmatch ~pat:"^param\\." key) + req#params)) @ + (if req#param "advanced" = "no" then + [ simple_checked_RE, "checked='true'"; + advanced_checked_RE, "" ] + else + [ simple_checked_RE, ""; + advanced_checked_RE, "checked='true'" ]) + in + iter_file + (fun line -> + let new_aliases = + DisambiguatingParser.EnvironmentP3.to_string id_to_uris + in + let processed_line = + apply_substs + (* CSC: Bug here: this is a string, not an array! *) + ((new_aliases_RE, "'" ^ javascript_quote new_aliases ^ "'")::subst) + line + in + output_string outchan (processed_line ^ "\n")) + moogle_TPL + +let exec_action mqi_handle (req: Http_types.request) outchan = + let term_string = req#param "expression" in + let (context, metasenv) = ([], []) in + let id_to_uris_raw = + try req#param "aliases" + with Http_types.Param_not_found _ -> "" + in + let parse_interpretation_choices choices = + List.map int_of_string (Pcre.split ~pat:" " choices) in + let parse_choices choices_raw = + let choices = Pcre.split ~pat:";" choices_raw in + List.fold_left + (fun f x -> + match Pcre.split ~pat:"\\s" x with + | ""::id::tail + | id::tail when id<>"" -> + (fun id' -> + if id = id' then + Some (List.map (fun u -> Netencoding.Url.decode u) tail) + else + f id') + | _ -> failwith "Can't parse choices") + (fun _ -> None) + choices + in + let id_to_uris = + DisambiguatingParser.EnvironmentP3.of_string id_to_uris_raw in + let id_to_choices = + try + let choices_raw = req#param "choices" in + parse_choices choices_raw + with Http_types.Param_not_found _ -> (fun _ -> None) + in + let interpretation_choices = + try + let choices_raw = req#param "interpretation_choices" in + if choices_raw = "" then None + else Some (parse_interpretation_choices choices_raw) + with Http_types.Param_not_found _ -> None + in + let module Chat: DisambiguateTypes.Callbacks = + struct + + let interactive_user_uri_choice + ~selection_mode ?ok + ?enable_button_for_non_vars ~(title: string) ~(msg: string) + ~(id: string) (choices: string list) + = + (match id_to_choices id with + | Some choices -> choices + | None -> + if req#param "advanced" = "no" then + let isvar s = + let len = String.length s in + let suffix = String.sub s (len-4) 4 in + not (suffix = ".var") in + List.filter isvar choices + else + let msg = Pcre.replace ~pat:"\'" ~templ:"\\\'" msg in + (match selection_mode with + | `SINGLE -> assert false + | `MULTIPLE -> + Http_daemon.send_basic_headers ~code:(`Code 200) outchan; + Http_daemon.send_CRLF outchan ; + let check_box uri = + "" ^ "" ^ uri ^ "" in +(* aggiungere gli hyperlinks? *) + let check_boxes = + String.concat "
" + (List.map check_box choices) in + iter_file + (fun line -> + let processed_line = + apply_substs + [advanced_tag_RE, req#param "advanced"; + choices_tag_RE, check_boxes; + no_choices_tag_RE, + string_of_int (List.length choices); + iden_tag_RE, id; + current_choices_tag_RE, req#param "choices"; + expression_tag_RE, req#param "expression"; + action_tag_RE, string_tail req#path ] + line + in + output_string outchan (processed_line ^ "\n")) + interactive_user_uri_choice_TPL; + raise Chat_unfinished)) + + let interactive_interpretation_choice interpretations = + match interpretation_choices with + Some l -> prerr_endline "CARRAMBA" ; l + | None -> + let html_interpretations = + let radio_button n = + "" in + let text interp = + String.concat "
" + (List.map + (fun (id, value) -> + sprintf "%s = %s" id value) + interp) in + let rec aux n = + function + [] -> [] + | interp::tl -> + ((radio_button n)^(text interp))::(aux (n+1) tl) in + String.concat "
" (aux 0 interpretations) + in + Http_daemon.send_basic_headers ~code:(`Code 200) outchan ; + Http_daemon.send_CRLF outchan ; + iter_file + (fun line -> + let processed_line = + apply_substs + [advanced_tag_RE, req#param "advanced"; + interpretations_RE, html_interpretations; + current_choices_tag_RE, req#param "choices"; + expression_tag_RE, req#param "expression"; + action_tag_RE, string_tail req#path ] + line + in + output_string outchan (processed_line ^ "\n")) + interactive_interpretation_choice_TPL; + raise Chat_unfinished + + let input_or_locate_uri ~title ?id () = + match id with + | Some id -> raise (Unbound_identifier id) + | None -> assert false + + end + in + let module Disambiguate' = DisambiguatingParser.Make(Chat) in + let (id_to_uris', metasenv', term') = + match + Disambiguate'.disambiguate_term mqi_handle + context metasenv term_string id_to_uris + with + [id_to_uris',metasenv',term'] -> id_to_uris',metasenv',term' + | _ -> assert false + in + let universe, + ((must_obj, must_rel, must_sort) as must'), + ((only_obj, only_rel, only_sort) as only) = + get_constraints term' req#path + in + if + (try ignore (req#param "constraints"); false + with Http_types.Param_not_found _ -> true) && + (req#param "advanced" = "no") && (req#path = "/hint") + then + let dbd = + match mqi_handle.MQIConn.pgc with + | MQIConn.MySQL_C conn -> conn + | _ -> assert false + in + let results = List.map snd (Match_concl.cmatch dbd term') in + send_results (`Results results) ~id_to_uris:id_to_uris' req outchan + else + let must'', only' = + (try + add_user_constraints + ~constraints:(req#param "constraints") + (must', only) + with Http_types.Param_not_found _ -> + if req#param "advanced" = "no" then + (must',only) + else + let variables = + "var aliases = '" ^ id_to_uris_raw ^ "';\n" ^ + "var constr_obj_len = " ^ + string_of_int (List.length must_obj) ^ ";\n" ^ + "var constr_rel_len = " ^ + string_of_int (List.length must_rel) ^ ";\n" ^ + "var constr_sort_len = " ^ + string_of_int (List.length must_sort) ^ ";\n" in + let form = + (if must_obj = [] then "" else + "

Obj constraints

" ^ + "" ^ + (String.concat "\n" (List.map html_of_r_obj must_obj)) ^ + "
" ^ + (* The following three lines to make Javascript create *) + (* the constr_obj[] and obj_depth[] arrays even if we *) + (* have only one real entry. *) + "" ^ + "") ^ + (if must_rel = [] then "" else + "

Rel constraints

" ^ + "" ^ + (String.concat "\n" (List.map html_of_r_rel must_rel)) ^ + "
" ^ + (* The following two lines to make Javascript create *) + (* the constr_rel[] and rel_depth[] arrays even if *) + (* we have only one real entry. *) + "" ^ + "") ^ + (if must_sort = [] then "" else + "

Sort constraints

" ^ + "" ^ + (String.concat "\n" (List.map html_of_r_sort must_sort)) ^ + "
" ^ + (* The following two lines to make Javascript create *) + (* the constr_sort[] and sort_depth[] arrays even if *) + (* we have only one real entry. *) + "" ^ + "") ^ + "

Only constraints

" ^ + "Enforce Only constraints for objects: " ^ + "
" ^ + "Enforce Rel constraints for objects: " ^ + "
" ^ + "Enforce Sort constraints for objects: " ^ + "
" + in + Http_daemon.send_basic_headers ~code:(`Code 200) outchan ; + Http_daemon.send_CRLF outchan ; + iter_file + (fun line -> + let processed_line = + apply_substs + [form_RE, form ; + variables_initialization_RE, variables; + advanced_tag_RE, req#param "advanced"; + current_choices_tag_RE, req#param "choices"; + interpretations_RE, req#param "interpretation_choices"; + expression_tag_RE, req#param "expression"; + action_tag_RE, string_tail req#path] line + in + output_string outchan (processed_line ^ "\n")) + constraints_choice_TPL; + raise Chat_unfinished) + in + let query = + G.query_of_constraints universe must'' only' + in + let results = MQueryInterpreter.execute mqi_handle query in + send_results (`Results (List.map fst results)) + ~id_to_uris:id_to_uris' req outchan (* HTTP DAEMON CALLBACK *) -let callback (req: Http_types.request) outchan = +let build_dynamic_uri url params = + let p = + String.concat "&" (List.map (fun (key,value) -> (key ^ "=" ^ (Netencoding.Url.encode value))) params) in + url ^ "?" ^ p + +let build_uwobo_request (req: Http_types.request) outchan = + prerr_endline ("ECCOLO: " ^ req#param "param.SEARCH_ENGINE_URL"); + let xmluri = build_dynamic_uri ((req#param "param.SEARCH_ENGINE_URL") ^ "/search") req#params in + prerr_endline ("xmluri: " ^ xmluri); + (*let xmluri = Netencoding.Url.encode xmluri in*) + let server_and_port = req#param "param.processorURL" in + let newreq = + build_dynamic_uri + (server_and_port ^ "apply") + (("xmluri",xmluri)::("keys",(req#param "param.thkeys"))::req#params) in + (* if List.mem server_and_port valid_servers then *) + prerr_endline newreq; + if true then + Http_daemon.respond + ~headers:["Content-Type", "text/html"] + ~body:(Http_client.http_get newreq) + outchan + else + Http_daemon.respond + ~body:(pp_error "Untrusted UWOBO server" server_and_port) + outchan + +let proxy url outchan = + let server_and_port = + (Pcre.extract ~rex:server_and_port_url_RE url).(1) + in + if List.mem server_and_port valid_servers then + Http_daemon.respond + ~headers:["Content-Type", "text/html"] + ~body:(Http_client.http_get url) + outchan + else + Http_daemon.respond + ~body:(pp_error "Untrusted UWOBO server" server_and_port) + outchan + +let callback mqi_handle (req: Http_types.request) outchan = try debug_print (sprintf "Received request: %s" req#path); (match req#path with + | "/help" -> Http_daemon.respond ~body:"HELM Search Engine" outchan + | "/locate" -> + let initial_expression = + try req#param "expression" with Http_types.Param_not_found _ -> "" + in + let expression = + Pcre.replace ~pat:"\\s*$" + (Pcre.replace ~pat:"^\\s*" initial_expression) + in + if expression = "" then + send_results (`Results []) req outchan + else + let results = + let query = G.locate expression in + MQueryInterpreter.execute mqi_handle query + in + send_results (`Results (List.map fst results)) req outchan | "/execute" -> - let mqi_handle = C.init mqi_flags debug_print in let query_string = req#param "query" in let lexbuf = Lexing.from_string query_string in let query = MQueryUtil.query_of_text lexbuf in let result = MQueryInterpreter.execute mqi_handle query in - let result_string = pp_result result in - C.close mqi_handle; + let result_string = pp_result req (List.map fst result) in Http_daemon.respond ~body:result_string ~headers:[contype] outchan - | "/locate" -> - let mqi_handle = C.init mqi_flags debug_print in - let id = req#param "id" in - let query = G.locate id in - let result = MQueryInterpreter.execute mqi_handle query in - C.close mqi_handle; - Http_daemon.respond ~headers:[contype] ~body:(pp_result result) outchan +(* Http_daemon.respond ~headers:[contype] ~body:(pp_result req result) outchan *) | "/unreferred" -> - let mqi_handle = C.init mqi_flags debug_print in let target = req#param "target" in let source = req#param "source" in - let query = G.unreferred target source in - let result = MQueryInterpreter.execute mqi_handle query in - C.close mqi_handle; - Http_daemon.respond ~headers:[contype] ~body:(pp_result result) outchan + let query = G.unreferred target source in + let result = MQueryInterpreter.execute mqi_handle query in + Http_daemon.respond ~headers:[contype] + ~body:(pp_result req (List.map fst result)) outchan | "/getpage" -> (* TODO implement "is_permitted" *) + let _ = prerr_endline + (Netencoding.Url.encode "http://mowgli.cs.unibo.it:38080/") in (let is_permitted _ = true in let remove_fragment uri = Pcre.replace ~pat:"#.*" uri in let page = remove_fragment (req#param "url") in @@ -312,7 +698,7 @@ let callback (req: Http_types.request) outchan = (match page with | page when is_permitted page -> (let fname = sprintf "%s/%s" pages_dir (remove_fragment page) in - Http_daemon.send_basic_headers ~code:200 outchan; + Http_daemon.send_basic_headers ~code:(`Code 200) outchan; Http_daemon.send_header "Content-Type" "text/html" outchan; Http_daemon.send_CRLF outchan; if preprocess then begin @@ -320,6 +706,9 @@ let callback (req: Http_types.request) outchan = (fun line -> output_string outchan ((apply_substs + ((search_engine_url_RE, my_own_url) :: + (advanced_tag_RE, "no") :: + (results_RE, "") :: (List.map (function (key,value) -> let key' = @@ -330,311 +719,42 @@ let callback (req: Http_types.request) outchan = (List.filter (fun (key,_) as p-> Pcre.pmatch ~pat:"^param\\." key) req#params) - ) + )) line) ^ "\n")) fname end else Http_daemon.send_file ~src:(FileSrc fname) outchan) | page -> Http_daemon.respond_forbidden ~url:page outchan)) - | "/ask_uwobo" -> - let url = req#param "url" in - let server_and_port = - (Pcre.extract ~rex:server_and_port_url_RE url).(1) - in - if List.mem server_and_port valid_servers then - Http_daemon.respond - ~headers:["Content-Type", "text/html"] - ~body:(Http_client.Convenience.http_get url) - outchan - else - Http_daemon.respond - ~body:(pp_error ("Untrusted UWOBO server: " ^ server_and_port)) - outchan - | "/searchPattern" - | "/matchConclusion" - | "/locateInductivePrinciple" -> - let mqi_handle = C.init mqi_flags debug_print in - let term_string = req#param "term" in - let lexbuf = Lexing.from_string term_string in - let (context, metasenv) = ([], []) in - let (dom, mk_metasenv_and_expr) = - CicTextualParserContext.main - ~context ~metasenv CicTextualLexer.token lexbuf - in - let id_to_uris_raw = req#param "aliases" in - let tokens = Pcre.split ~pat:"\\s" id_to_uris_raw in - let rec parse_tokens keys lookup = function (* TODO spostarla fuori *) - | [] -> keys, lookup - | "alias" :: key :: value :: rest -> - let key' = CicTextualParser0.Id key in - parse_tokens - (key'::keys) - (fun id -> - if id = key' then - Some - (CicTextualParser0.Uri (MQueryMisc.cic_textual_parser_uri_of_string value)) - else lookup id) - rest - | _ -> failwith "Can't parse aliases" - in - let parse_choices choices_raw = - let choices = Pcre.split ~pat:";" choices_raw in - List.fold_left - (fun f x -> - match Pcre.split ~pat:"\\s" x with - | ""::id::tail - | id::tail when id<>"" -> - (fun id' -> -prerr_endline ("#### " ^ id ^ " :="); -List.iter (fun u -> prerr_endline ("<" ^ Netencoding.Url.decode u ^ ">")) tail; - if id = id' then - Some (List.map (fun u -> Netencoding.Url.decode u) tail) - else - f id') - | _ -> failwith "Can't parse choices") - (fun _ -> None) - choices - in - let (id_to_uris : Disambiguate.domain_and_interpretation) = - parse_tokens [] (fun _ -> None) tokens in - let id_to_choices = - try - let choices_raw = req#param "choices" in - parse_choices choices_raw - with Http_types.Param_not_found _ -> (fun _ -> None) - in - let module Chat: Disambiguate.Callbacks = - struct - - let get_metasenv () = - !CicTextualParser0.metasenv - - let set_metasenv metasenv = - CicTextualParser0.metasenv := metasenv - - let output_html = prerr_endline - - let interactive_user_uri_choice - ~selection_mode ?ok - ?enable_button_for_non_vars ~(title: string) ~(msg: string) - ~(id: string) (choices: string list) - = - (match id_to_choices id with - | Some choices -> choices - | None -> - let msg = Pcre.replace ~pat:"\'" ~templ:"\\\'" msg in - (match selection_mode with - | `SINGLE -> assert false - | `EXTENDED -> - Http_daemon.send_basic_headers ~code:200 outchan ; - Http_daemon.send_CRLF outchan ; - iter_file - (fun line -> - let formatted_choices = - String.concat "," - (List.map (fun uri -> sprintf "\'%s\'" uri) choices) - in - let processed_line = - apply_substs - [title_tag_RE, title; - choices_tag_RE, formatted_choices; - msg_tag_RE, msg; - id_to_uris_RE, id_to_uris_raw; - id_RE, id] - line - in - output_string outchan (processed_line ^ "\n")) - interactive_user_uri_choice_TPL; - raise Chat_unfinished)) - - let interactive_interpretation_choice interpretations = - let html_interpretations_labels = - String.concat ", " - (List.map - (fun l -> - "\'" ^ - (String.concat "
" - (List.map - (fun (id, value) -> - (sprintf "alias %s %s" id value)) - l)) ^ - "\'") - interpretations) - in - let html_interpretations = - String.concat ", " - (List.map - (fun l -> - "\'" ^ - (String.concat " " - (List.map - (fun (id, value) -> - (sprintf "alias %s %s" - id - (MQueryMisc.wrong_xpointer_format_from_wrong_xpointer_format' - value))) - l)) ^ - "\'") - interpretations) - in - Http_daemon.send_basic_headers ~code:200 outchan ; - Http_daemon.send_CRLF outchan ; - iter_file - (fun line -> - let processed_line = - apply_substs - [interpretations_RE, html_interpretations; - interpretations_labels_RE, html_interpretations_labels] - line - in - output_string outchan (processed_line ^ "\n")) - interactive_interpretation_choice_TPL; - raise Chat_unfinished - - let input_or_locate_uri ~title = - UriManager.uri_of_string "cic:/Coq/Init/DataTypes/nat_ind.con" - - end - in - let module Disambiguate' = Disambiguate.Make (Chat) in - let (id_to_uris', metasenv', term') = - Disambiguate'.disambiguate_input mqi_handle - context metasenv dom mk_metasenv_and_expr id_to_uris - in - (match metasenv' with - | [] -> - let universe, - ((must_obj, must_rel, must_sort) as must'), - ((only_obj, only_rel, only_sort) as only) = - get_constraints term' req#path - in - let must'', only' = - (try - add_user_constraints - ~constraints:(req#param "constraints") - (must', only) - with Http_types.Param_not_found _ -> - let variables = - "var aliases = '" ^ id_to_uris_raw ^ "';\n" ^ - "var constr_obj_len = " ^ - string_of_int (List.length must_obj) ^ ";\n" ^ - "var constr_rel_len = " ^ - string_of_int (List.length must_rel) ^ ";\n" ^ - "var constr_sort_len = " ^ - string_of_int (List.length must_sort) ^ ";\n" in - let form = - (if must_obj = [] then "" else - "

Obj constraints

" ^ - "" ^ - (String.concat "\n" (List.map html_of_r_obj must_obj)) ^ - "
" ^ - (* The following three lines to make Javascript create *) - (* the constr_obj[] and obj_depth[] arrays even if we *) - (* have only one real entry. *) - "" ^ - "") ^ - (if must_rel = [] then "" else - "

Rel constraints

" ^ - "" ^ - (String.concat "\n" (List.map html_of_r_rel must_rel)) ^ - "
" ^ - (* The following two lines to make Javascript create *) - (* the constr_rel[] and rel_depth[] arrays even if *) - (* we have only one real entry. *) - "" ^ - "") ^ - (if must_sort = [] then "" else - "

Sort constraints

" ^ - "" ^ - (String.concat "\n" (List.map html_of_r_sort must_sort)) ^ - "
" ^ - (* The following two lines to make Javascript create *) - (* the constr_sort[] and sort_depth[] arrays even if *) - (* we have only one real entry. *) - "" ^ - "") ^ - "

Only constraints

" ^ - "Enforce Only constraints for objects: " ^ - "
" ^ - "Enforce Rel constraints for objects: " ^ - "
" ^ - "Enforce Sort constraints for objects: " ^ - "
" - in - Http_daemon.send_basic_headers ~code:200 outchan ; - Http_daemon.send_CRLF outchan ; - iter_file - (fun line -> - let processed_line = - apply_substs - [form_RE, form ; - variables_initialization_RE, variables] line - in - output_string outchan (processed_line ^ "\n")) - constraints_choice_TPL; - raise Chat_unfinished) - in - let query = - G.query_of_constraints (Some universe) must'' only' - in - let results = MQueryInterpreter.execute mqi_handle query in - Http_daemon.send_basic_headers ~code:200 outchan ; - Http_daemon.send_CRLF outchan ; - iter_file - (fun line -> - let new_aliases = - match id_to_uris' with - | (domain, f) -> - String.concat ", " - (List.map - (fun name -> - sprintf "\'alias %s cic:%s\'" - (match name with - CicTextualParser0.Id name -> name - | _ -> assert false (*CSC: completare *)) - (match f name with - | None -> assert false - | Some (CicTextualParser0.Uri t) -> - MQueryMisc.string_of_cic_textual_parser_uri - t - | _ -> assert false (*CSC: completare *))) - domain) - in - let processed_line = - apply_substs - [results_RE, theory_of_result results ; - new_aliases_RE, new_aliases] - line - in - output_string outchan (processed_line ^ "\n")) - final_results_TPL - | _ -> (* unable to instantiate some implicit variable *) - Http_daemon.respond - ~headers:[contype] - ~body:"some implicit variables are still unistantiated :-(" - outchan); - C.close mqi_handle + (* OLD | "/ask_uwobo" -> proxy (req#param "url") outchan *) + | "/ask_uwobo" -> build_uwobo_request req outchan + | "/hint" | "/match" | "/elim" -> exec_action mqi_handle req outchan | invalid_request -> - Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan); + Http_daemon.respond_error ~code:(`Status (`Client_error `Bad_request)) + outchan); debug_print (sprintf "%s done!" req#path) with | Chat_unfinished -> prerr_endline "Chat unfinished, Try again!" | Http_types.Param_not_found attr_name -> bad_request (sprintf "Parameter '%s' is missing" attr_name) outchan - | exc -> - Http_daemon.respond - ~body:(pp_error ("Uncaught exception: " ^ (Printexc.to_string exc))) - outchan -in -printf "%s started and listening on port %d\n" daemon_name port; -printf "Current directory is %s\n" (Sys.getcwd ()); -printf "HTML directory is %s\n" pages_dir; -flush stdout; -Unix.putenv "http_proxy" ""; -Http_daemon.start' ~port callback; -printf "%s is terminating, bye!\n" daemon_name + | CicTextualParser2.Parse_error msg -> + send_results (`Error (pp_error "Parse_error" msg)) req outchan + | Unbound_identifier id -> + send_results (`Error (pp_error "Unbound identifier" id)) req outchan + | exn -> + let exn_string = Printexc.to_string exn in + debug_print exn_string; + let msg = pp_error "Uncaught exception" exn_string in + send_results (`Error msg) req outchan + +let _ = + printf "%s started and listening on port %d\n" daemon_name port; + printf "Current directory is %s\n" (Sys.getcwd ()); + printf "HTML directory is %s\n" pages_dir; + flush stdout; + Unix.putenv "http_proxy" ""; + let mqi_handle = C.init ~log:debug_print () in + Http_daemon.start' ~port (callback mqi_handle); + C.close mqi_handle; + printf "%s is terminating, bye!\n" daemon_name