X-Git-Url: http://matita.cs.unibo.it/gitweb/?a=blobdiff_plain;f=helm%2FsearchEngine%2FsearchEngine.ml;h=ecedf5ab7635a24dcef27f968d41fb2b2f4b0215;hb=11b9b274291baa8c5462b2ce3e2a5f93a39c9d57;hp=15fb92de786e6d110842ea8cc073a60343626a08;hpb=5a80860a63d656e3737f9ad383b300166cdecaa9;p=helm.git diff --git a/helm/searchEngine/searchEngine.ml b/helm/searchEngine/searchEngine.ml index 15fb92de7..ecedf5ab7 100644 --- a/helm/searchEngine/searchEngine.ml +++ b/helm/searchEngine/searchEngine.ml @@ -23,36 +23,111 @@ * http://cs.unibo.it/helm/. *) +open Http_types ;; + let debug = true;; let debug_print s = if debug then prerr_endline s;; Http_common.debug := true;; +(* Http_common.debug := true;; *) -open Printf;; + (** accepted HTTP servers for ask_uwobo method forwarding *) +let valid_servers = [ "mowgli.cs.unibo.it:58080" ; "mowgli.cs.unibo.it" ; "localhost:58080" ] ;; -let postgresConnectionString = - try - Sys.getenv "POSTGRESQL_CONNECTION_STRING" - with - Not_found -> "host=mowgli.cs.unibo.it dbname=helm_mowgli_new_schema user=helm" -;; +let mqi_flags = [] (* default MathQL interpreter options *) + +open Printf;; let daemon_name = "Search Engine";; let default_port = 58085;; let port_env_var = "SEARCH_ENGINE_PORT";; -let pages_dir = "html";; (* relative to searchEngine's document root *) +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 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";; exception Chat_unfinished - (** pretty print a MathQL query result to a string *) -let text_of_result result sep = - let res_string = ref "" in - let app = function s -> res_string := !res_string ^ s in - MQueryUtil.text_of_result app result sep ; - !res_string + (* 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 + | "_" -> None + | s -> + try + Some (int_of_string s) + with Failure "int_of_string" -> + failwith ("Can't parse an int option from string: " ^ s) +;; + +let is_concl_pos pos = + pos = "http://www.cs.unibo.it/helm/schemas/schema-helm#MainConclusion" + or + pos = "http://www.cs.unibo.it/helm/schemas/schema-helm#InConclusion" +;; + +let is_main_pos pos = + pos = "http://www.cs.unibo.it/helm/schemas/schema-helm#MainConclusion" + or + pos = "http://www.cs.unibo.it/helm/schemas/schema-helm#MainHypothesis" +;; + + (* HTML pretty printers for mquery_generator types *) + +let html_of_r_obj (uri, pos, depth) = + sprintf + "%s%s%s" + uri (Str.string_after pos ((String.rindex pos '#') + 1)) + (if is_main_pos pos then + sprintf "" + (match depth with Some i -> string_of_int i | None -> "") + else + "") +;; + +let html_of_r_rel (pos, depth) = + sprintf + "%s" + pos (match depth with Some i -> string_of_int i | None -> "") +;; + +let html_of_r_sort (pos, depth, sort) = + sprintf + "%s%s" + sort pos (match depth with Some i -> string_of_int i | None -> "") +;; + + (** pretty print a MathQL query result to an HELM theory file *) +let theory_of_result 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 -> + decr idx ; + "" ^ string_of_int !idx ^ "." ^ i + ) result "" + in + "

Query Results:

" ^ results ^ "
" + else + "

Query Results:

No results found!

" +;; + +let pp_result result = + "\nQuery Results\n" ^ theory_of_result result ^ "" ;; (** chain application of Pcre substitutions *) @@ -76,11 +151,17 @@ let fold_file f init fname = 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) = + interpretations_RE, interpretations_labels_RE, results_RE, new_aliases_RE, + form_RE, variables_initialization_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 "@RESULTS@", Pcre.regexp "@NEW_ALIASES@", Pcre.regexp "@FORM@", + Pcre.regexp "@VARIABLES_INITIALIZATION@") +let server_and_port_url_RE = Pcre.regexp "^http://([^/]+)/.*$" + +exception NotAnInductiveDefinition let port = try @@ -91,11 +172,6 @@ let port = prerr_endline "Warning: invalid port, reverting to default"; default_port in -let pp_result result = - let res_string = text_of_result result "\n" in - (sprintf "\n\n\n\n
%s
\n\n" - res_string) -in let pp_error = sprintf "

Error: %s

" in let bad_request body outchan = Http_daemon.respond_error ~status:(`Client_error `Bad_request) ~body outchan @@ -104,7 +180,117 @@ let contype = "Content-Type", "text/html" in (* SEARCH ENGINE functions *) -let refine_constraints (x, y, z) = (x, y, z), (Some x, Some y, Some z) in +let refine_constraints (constr_obj, constr_rel, constr_sort) = + function + "/searchPattern" -> + (constr_obj, constr_rel, constr_sort), + (Some constr_obj, Some constr_rel, Some constr_sort) + | "/matchConclusion" -> + let constr_obj' = + List.map + (function (uri,pos,_) -> (uri,pos,None)) + (List.filter + (function (uri,pos,depth) as constr -> is_concl_pos pos) + constr_obj) + in + (*CSC: we must select the must constraints here!!! *) + (constr_obj',[],[]),(Some constr_obj', None, None) + | _ -> assert false +in + +let get_constraints term = + function + "/locateInductivePrinciple" -> + let uri = + match term with + Cic.MutInd (uri,t,_) -> MQueryUtil.string_of_uriref (uri,[t]) + | _ -> raise NotAnInductiveDefinition + in + let constr_obj = + [uri,"http://www.cs.unibo.it/helm/schemas/schema-helm#InHypothesis", + None ; + uri,"http://www.cs.unibo.it/helm/schemas/schema-helm#MainHypothesis", + Some 0 + ] + in + let constr_rel = + ["http://www.cs.unibo.it/helm/schemas/schema-helm#MainConclusion", + None] in + let constr_sort = + ["http://www.cs.unibo.it/helm/schemas/schema-helm#MainHypothesis", + Some 1, "http://www.cs.unibo.it/helm/schemas/schema-helm#Prop"] + in + (constr_obj, constr_rel, constr_sort), (None,None,None) + | req_path -> + let must = MQueryLevels2.get_constraints term in + refine_constraints must req_path +in + +(* + format: + ':' ':' ':' ':' ':' + + ::= ('0'|'1') ('_'|) (',' ('0'|'1') ('_'|))* + ::= '0'|'1' +*) +let add_user_constraints ~constraints + ((obj, rel, sort), (only_obj, only_rel, only_sort)) += + let parse_must s = + let l = Pcre.split ~pat:"," s in + (try + List.map + (fun s -> + let subs = Pcre.extract ~pat:"^(.)(\\d+|_)$" s in + (bool_of_string' subs.(1), int_of_string' subs.(2))) + l + with + Not_found -> failwith ("Can't parse constraint string: " ^ constraints) + ) + in + (* to be used on "obj" *) + let add_user_must33 user_must must = + List.map2 + (fun (b, i) (p1, p2, p3) -> if b then (p1, p2, i) else (p1, p2, None)) + user_must must + in + (* to be used on "rel" *) + let add_user_must22 user_must must = + List.map2 + (fun (b, i) (p1, p2) -> if b then (p1, i) else (p1, None)) + user_must must + in + (* to be used on "sort" *) + let add_user_must32 user_must must = + List.map2 + (fun (b, i) (p1, p2, p3) -> if b then (p1, i, p3) else (p1, None, p3)) + user_must must + in + match Pcre.split ~pat:":" constraints with + | [user_obj;user_rel;user_sort;user_only_obj;user_only_rel;user_only_sort] -> + let + (user_obj,user_rel,user_sort,user_only_obj,user_only_rel,user_only_sort) + = + (parse_must user_obj, + parse_must user_rel, + parse_must user_sort, + bool_of_string' user_only_obj, + bool_of_string' user_only_rel, + bool_of_string' user_only_sort) + in + let only' = + (if user_only_obj then only_obj else None), + (if user_only_rel then only_rel else None), + (if user_only_sort then only_sort else None) + in + let must' = + add_user_must33 user_obj obj, + add_user_must22 user_rel rel, + add_user_must32 user_sort sort + in + (must', only') + | _ -> failwith ("Can't parse constraint string: " ^ constraints) +in (* HTTP DAEMON CALLBACK *) @@ -113,30 +299,77 @@ let callback (req: Http_types.request) outchan = debug_print (sprintf "Received request: %s" req#path); (match req#path with | "/execute" -> + let mqi_handle = MQIConn.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 = MQueryGenerator.execute_query query in - let result_string = text_of_result result "\n" in - Http_daemon.respond - ~body: - (sprintf "
%s
" result_string) - ~headers:[contype] outchan + let result = MQueryInterpreter.execute mqi_handle query in + let result_string = pp_result result in + MQIConn.close mqi_handle; + Http_daemon.respond ~body:result_string ~headers:[contype] outchan | "/locate" -> + let mqi_handle = MQIConn.init mqi_flags debug_print in let id = req#param "id" in - let result = MQueryGenerator.locate id in + let query = MQueryGenerator.locate id in + let result = MQueryInterpreter.execute mqi_handle query in + MQIConn.close mqi_handle; Http_daemon.respond ~headers:[contype] ~body:(pp_result result) outchan | "/getpage" -> (* TODO implement "is_permitted" *) (let is_permitted _ = true in let remove_fragment uri = Pcre.replace ~pat:"#.*" uri in let page = remove_fragment (req#param "url") in - match page with + let preprocess = + (try + bool_of_string (req#param "preprocess") + with Invalid_argument _ | Http_types.Param_not_found _ -> false) + in + (match page with | page when is_permitted page -> - Http_daemon.respond_file - ~fname:(sprintf "%s/%s" pages_dir (remove_fragment page)) outchan - | page -> Http_daemon.respond_forbidden ~url:page outchan) - | "/searchPattern" -> + (let fname = sprintf "%s/%s" pages_dir (remove_fragment page) in + Http_daemon.send_basic_headers ~code:200 outchan; + Http_daemon.send_header "Content-Type" "text/html" outchan; + Http_daemon.send_CRLF outchan; + if preprocess then begin + iter_file + (fun line -> + output_string outchan + ((apply_substs + (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) + ) + 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 = MQIConn.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 @@ -149,13 +382,15 @@ let callback (req: Http_types.request) outchan = let rec parse_tokens keys lookup = function (* TODO spostarla fuori *) | [] -> keys, lookup | "alias" :: key :: value :: rest -> - parse_tokens - (key::keys) - (fun id -> - if id = key then - Some (MQueryMisc.cic_textual_parser_uri_of_string value) - else lookup id) - 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 = @@ -166,6 +401,8 @@ let callback (req: Http_types.request) outchan = | ""::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 @@ -174,7 +411,8 @@ let callback (req: Http_types.request) outchan = (fun _ -> None) choices in - let id_to_uris = parse_tokens [] (fun _ -> None) tokens 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 @@ -184,6 +422,12 @@ let callback (req: Http_types.request) outchan = 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 @@ -194,15 +438,17 @@ let callback (req: Http_types.request) outchan = (match id_to_choices id with | Some choices -> choices | None -> - let msg = Pcre.replace ~pat:"\"" ~templ:"\\\"" msg in + 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) + (List.map (fun uri -> sprintf "\'%s\'" uri) choices) in let processed_line = apply_substs @@ -213,7 +459,7 @@ let callback (req: Http_types.request) outchan = id_RE, id] line in - output_string outchan processed_line) + output_string outchan (processed_line ^ "\n")) interactive_user_uri_choice_TPL; raise Chat_unfinished)) @@ -222,20 +468,20 @@ let callback (req: Http_types.request) outchan = 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) -> @@ -244,9 +490,11 @@ let callback (req: Http_types.request) outchan = (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 = @@ -255,7 +503,7 @@ let callback (req: Http_types.request) outchan = interpretations_labels_RE, html_interpretations_labels] line in - output_string outchan processed_line) + output_string outchan (processed_line ^ "\n")) interactive_interpretation_choice_TPL; raise Chat_unfinished @@ -266,14 +514,88 @@ let callback (req: Http_types.request) outchan = in let module Disambiguate' = Disambiguate.Make (Chat) in let (id_to_uris', metasenv', term') = - Disambiguate'.disambiguate_input + Disambiguate'.disambiguate_input mqi_handle context metasenv dom mk_metasenv_and_expr id_to_uris in (match metasenv' with | [] -> - let must = MQueryLevels2.get_constraints term' in - let must',only = refine_constraints must in - let results = MQueryGenerator.searchPattern must' only in + let ((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 = MQueryGenerator.searchPattern 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 = @@ -282,29 +604,32 @@ let callback (req: Http_types.request) outchan = String.concat ", " (List.map (fun name -> - sprintf "\"alias %s cic:%s\"" - 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 t -> + | Some (CicTextualParser0.Uri t) -> MQueryMisc.string_of_cic_textual_parser_uri - t)) + t + | _ -> assert false (*CSC: completare *))) domain) in let processed_line = apply_substs - [results_RE, text_of_result results "\n"; + [results_RE, theory_of_result results ; new_aliases_RE, new_aliases] line in - output_string outchan processed_line) + 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) - + outchan); + MQIConn.close mqi_handle | invalid_request -> Http_daemon.respond_error ~status:(`Client_error `Bad_request) outchan); debug_print (sprintf "%s done!" req#path) @@ -318,12 +643,10 @@ let callback (req: Http_types.request) outchan = outchan in printf "%s started and listening on port %d\n" daemon_name port; -printf "current directory is %s\n" (Sys.getcwd ()); +printf "Current directory is %s\n" (Sys.getcwd ()); +printf "HTML directory is %s\n" pages_dir; flush stdout; Unix.putenv "http_proxy" ""; -Mqint.set_database Mqint.postgres_db; -Mqint.init postgresConnectionString; Http_daemon.start' ~port callback; -Mqint.close (); printf "%s is terminating, bye!\n" daemon_name