(*
- * Copyright (C) 2000, HELM Team.
+ * Copyright (C) 2003, HELM Team.
*
* This file is part of HELM, an Hypertextual, Electronic
* Library of Mathematics, developed at the Computer Science
* 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) =
| 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 *)
let resolve uri = (map_of_uri uri)#resolve 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
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
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
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
| "/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