Added support for NuPRL URIs.

[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 7c5fafa114a5cc5831dc83782f174d04cfa346d6..40f38dc4eec38598258f23e0fbb4a3f817689af0 100644 (file)
--- a/helm/http_getter/http_getter.ml
+++ b/helm/http_getter/http_getter.ml
@@ -79,13 +79,16 @@ let parse_ls_uri =
 
   (* global maps, shared by all threads *)
 
-let xml_map = new Http_getter_map.map Http_getter_env.xml_dbm in
+let cic_map = new Http_getter_map.map Http_getter_env.cic_dbm in
+let nuprl_map = new Http_getter_map.map Http_getter_env.nuprl_dbm in
 let rdf_map = new Http_getter_map.map Http_getter_env.rdf_dbm in
 let xsl_map = new Http_getter_map.map Http_getter_env.xsl_dbm in
 
-let save_maps () = xml_map#close; rdf_map#close; xsl_map#close in
+let save_maps () =
+ cic_map#close; nuprl_map#close; rdf_map#close; xsl_map#close in
 let map_of_uri = function
-  | uri when is_xml_uri uri -> xml_map
+  | uri when is_cic_uri uri -> cic_map
+  | uri when is_nuprl_uri uri -> nuprl_map
   | uri when is_rdf_uri uri -> rdf_map
   | uri when is_xsl_uri uri -> xsl_map
   | uri -> raise (Http_getter_unresolvable_URI uri)
@@ -123,7 +126,7 @@ let return_all_foo_uris map doctype filter outchan =
         output_string outchan (sprintf "\t<uri value=\"%s\" />\n" uri));
   output_string outchan (sprintf "</%s>\n" doctype)
 in
-let return_all_xml_uris = return_all_foo_uris xml_map "alluris" in
+let return_all_xml_uris = return_all_foo_uris cic_map "alluris" in
 let return_all_rdf_uris = return_all_foo_uris rdf_map "allrdfuris" in
 let return_ls =
   let (++) (oldann, oldtypes, oldbody) (newann, newtypes, newbody) =
@@ -171,7 +174,7 @@ let return_ls =
       in
       Hashtbl.replace objs basepart (oldflags ++ newflags)
     in
-    xml_map#iter  (* BLEARGH Dbm module lacks support for fold-like functions *)
+    cic_map#iter  (* BLEARGH Dbm module lacks support for fold-like functions *)
       (fun key _ ->
         match key with
         | uri when Pcre.pmatch ~rex:dir_RE uri ->  (* directory hit *)
@@ -274,8 +277,12 @@ let update_from_server logmsg server_url = (* use global maps *)
         (fun l ->
           try
             (match Pcre.split ~rex:index_line_sep_RE l with
-            | [uri; "gz"] -> xml_map#add uri ((xml_url_of_uri uri) ^ ".xml.gz")
-            | [uri] -> xml_map#add uri ((xml_url_of_uri uri) ^ ".xml")
+            | [uri; "gz"] ->
+               assert (is_cic_uri uri || is_nuprl_uri uri) ;
+               (map_of_uri uri)#add uri ((xml_url_of_uri uri) ^ ".xml.gz")
+            | [uri] ->
+               assert (is_cic_uri uri || is_nuprl_uri uri) ;
+               (map_of_uri uri)#add uri ((xml_url_of_uri uri) ^ ".xml")
             | _ -> log := !log ^ "Ignoring invalid line: " ^ l ^ "<br />\n")
           with Http_getter_invalid_URI uri ->
             log := !log ^ "Ignoring invalid XML URI: " ^ uri ^ "<br />\n")
@@ -350,7 +357,7 @@ let callback (req: Http_types.request) outchan =
         | _ -> assert false)
     | "/update" ->
         (Http_getter_env.reload (); (* reload servers list from servers file *)
-        xml_map#clear; rdf_map#clear; xsl_map#clear;
+        cic_map#clear; nuprl_map#clear; rdf_map#clear; xsl_map#clear;
         let log =
           List.fold_left
             update_from_server
@@ -358,7 +365,7 @@ let callback (req: Http_types.request) outchan =
               (* reverse order: 1st server is the most important one *)
             (List.rev !Http_getter_env.servers)
         in
-        xml_map#sync; rdf_map#sync; xsl_map#sync;
+        cic_map#sync; nuprl_map#sync; rdf_map#sync; xsl_map#sync;
         return_html_msg log outchan)
     | "/getalluris" ->
         return_all_xml_uris