Resolve fixed: when an URI was well-formed but not found in a map, unresolved

[helm.git] / helm / http_getter / http_getter.ml

diff --git a/helm/http_getter/http_getter.ml b/helm/http_getter/http_getter.ml
index 04eaed9c44762189fea00f43199f9736b303f94e..02877b012c55690222fb7c2a87763225706f82bd 100644 (file)
--- a/helm/http_getter/http_getter.ml
+++ b/helm/http_getter/http_getter.ml
@@ -24,14 +24,20 @@
  *  http://cs.unibo.it/helm/.
  *)
 
-(* TODO optimization: precompile regexps *)
-
 open Http_getter_common;;
 open Http_getter_misc;;
 open Http_getter_types;;
 open Http_getter_debugger;;
 open Printf;;
 
+  (* constants *)
+
+let common_headers = [
+  "Cache-Control", "no-cache";
+  "Pragma", "no-cache";
+  "Expires", "0"
+]
+
   (* HTTP queries argument parsing *)
 
 let parse_enc (req: Http_types.request) =
@@ -54,15 +60,19 @@ let parse_output_format (req: Http_types.request) =
   | s when String.lowercase s = "xml" -> Fmt_xml
   | s -> raise (Http_getter_bad_request ("Invalid /ls format: " ^ s))
 ;;
-let parse_ls_uri (req: Http_types.request) =
-  let baseuri = req#param "baseuri" in
-  let subs =
-    Pcre.extract ~pat:"^(\\w+):(.*)$" (Pcre.replace ~pat:"/+$"  baseuri)
-  in
-  match (subs.(1), subs.(2)) with
-  | "cic", uri -> Cic uri
-  | "theory", uri -> Theory uri
-  | _ -> raise (Http_getter_bad_request ("Invalid /ls baseuri: " ^ baseuri))
+let parse_ls_uri =
+  let parse_ls_RE = Pcre.regexp "^(\\w+):(.*)$" in
+  let trailing_slash_RE = Pcre.regexp "/+$" in
+  fun (req: Http_types.request) ->
+    let baseuri = req#param "baseuri" in
+    let subs =
+      Pcre.extract ~rex:parse_ls_RE
+        (Pcre.replace ~rex:trailing_slash_RE  baseuri)
+    in
+    match (subs.(1), subs.(2)) with
+    | "cic", uri -> Cic uri
+    | "theory", uri -> Theory uri
+    | _ -> raise (Http_getter_bad_request ("Invalid /ls baseuri: " ^ baseuri))
 ;;
 
   (* global maps, shared by all threads *)
@@ -78,11 +88,20 @@ let map_of_uri = function
   | uri when is_xsl_uri uri -> xsl_map
   | uri -> raise (Http_getter_unresolvable_URI uri)
 in
-let resolve uri = (map_of_uri uri)#resolve uri in
+let resolve uri =
+  try
+    (map_of_uri uri)#resolve uri
+  with Http_getter_map.Key_not_found _ ->
+    raise (Http_getter_unresolvable_URI uri)
+in
 let register uri =  (map_of_uri uri )#add uri in
 let return_all_foo_uris map doctype filter outchan =
+  (** return all URIs contained in 'map' which satisfy predicate 'filter'; URIs
+  are written in an XMLish format ('doctype' is the XML doctype) onto 'outchan'
+  *)
   Http_daemon.send_basic_headers ~code:200 outchan;
   Http_daemon.send_header "Content-Type" "text/xml" outchan;
+  Http_daemon.send_headers common_headers outchan;
   Http_daemon.send_CRLF outchan;
   output_string
     outchan
@@ -176,7 +195,8 @@ let return_ls =
             objs "")
         in
         Http_daemon.respond
-          ~headers:["Content-Type", "text/plain"] ~body outchan
+          ~headers:(("Content-Type", "text/plain") :: common_headers)
+         ~body outchan
     | Fmt_xml ->
         let body =
           sprintf
@@ -209,27 +229,31 @@ let return_ls =
               objs ""))
         in
         Http_daemon.respond
-          ~headers:["Content-Type", "text/xml"] ~body outchan
+          ~headers:(("Content-Type", "text/xml") :: common_headers)
+         ~body outchan
 in
-let (index_line_sep_RE, index_sep_RE) =
-  (Pcre.regexp "[ \t]+", Pcre.regexp "\n+")
+let (index_line_sep_RE, index_sep_RE, trailing_types_RE,
+    heading_cic_RE, heading_theory_RE,
+    heading_rdf_cic_RE, heading_rdf_theory_RE) =
+  (Pcre.regexp "[ \t]+", Pcre.regexp "\n+", Pcre.regexp "\\.types$",
+  Pcre.regexp "^cic:", Pcre.regexp "^theory:",
+  Pcre.regexp "^helm:rdf.*//cic:", Pcre.regexp "^helm:rdf.*//theory:")
 in
-  (* TODO support 'file://.*' servers *)
 let update_from_server logmsg server_url = (* use global maps *)
   debug_print ("Updating information from " ^ server_url);
   let xml_url_of_uri = function
       (* TODO missing sanity checks on server_url, e.g. it can contains $1 *)
-    | uri when (Pcre.pmatch ~pat:"^cic:" uri) ->
-        Pcre.replace ~pat:"^cic:" ~templ:server_url uri
-    | uri when (Pcre.pmatch ~pat:"^theory:" uri) ->
-        Pcre.replace ~pat:"^theory:" ~templ:server_url uri
+    | uri when (Pcre.pmatch ~rex:heading_cic_RE uri) ->
+        Pcre.replace ~rex:heading_cic_RE ~templ:server_url uri
+    | uri when (Pcre.pmatch ~rex:heading_theory_RE uri) ->
+        Pcre.replace ~rex:heading_theory_RE ~templ:server_url uri
     | uri -> raise (Http_getter_invalid_URI uri)
   in
   let rdf_url_of_uri = function (* TODO as above *)
-    | uri when (Pcre.pmatch ~pat:"^helm:rdf.*//cic:" uri) ->
-        Pcre.replace ~pat:"^helm:rdf.*//cic:" ~templ:server_url uri
-    | uri when (Pcre.pmatch ~pat:"^helm:rdf.*//theory:" uri) ->
-        Pcre.replace ~pat:"^helm:rdf.*//theory:" ~templ:server_url uri
+    | uri when (Pcre.pmatch ~rex:heading_rdf_cic_RE uri) ->
+        Pcre.replace ~rex:heading_rdf_cic_RE ~templ:server_url uri
+    | uri when (Pcre.pmatch ~rex:heading_rdf_theory_RE uri) ->
+        Pcre.replace ~rex:heading_rdf_theory_RE ~templ:server_url uri
     | uri -> raise (Http_getter_invalid_URI uri)
   in
   let log = ref (logmsg ^ "Processing server: " ^ server_url ^ "<br />\n") in
@@ -336,8 +360,8 @@ let callback (req: Http_types.request) outchan =
     | "/getalluris" ->
         return_all_xml_uris
           (fun uri ->
-            (Pcre.pmatch ~pat:"^cic:" uri) &&
-            not (Pcre.pmatch ~pat:"\\.types$" uri))
+            (Pcre.pmatch ~rex:heading_cic_RE uri) &&
+            not (Pcre.pmatch ~rex:trailing_types_RE uri))
           outchan
     | "/getallrdfuris" ->
         (let classs = req#param "class" in