helm/interface/pxpUriResolver.ml

   1 (******************************************************************************)
   2 (*                                                                            *)
   3 (*                               PROJECT HELM                                 *)
   4 (*                                                                            *)
   5 (*                Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>               *)
   6 (*                                 11/10/2000                                 *)
   7 (*                                                                            *)
   8 (*                                                                            *)
   9 (******************************************************************************)
  10
  11 let resolve =
  12  function
  13     "http://localhost:8081/getdtd?url=cic.dtd" ->
  14      Configuration.dtd_dir ^ "/cic.dtd"
  15   | "http://localhost:8081/getdtd?url=maththeory.dtd" ->
  16      Configuration.dtd_dir ^ "/maththeory.dtd"
  17   | "http://localhost:8081/getdtd?url=annotations.dtd" ->
  18      Configuration.dtd_dir ^ "/annotations.dtd"
  19   | s  -> s
  20 ;;
  21
  22 let url_syntax =
  23     let enable_if =
  24       function
  25           `Not_recognized  -> Neturl.Url_part_not_recognized
  26         | `Allowed         -> Neturl.Url_part_allowed
  27         | `Required        -> Neturl.Url_part_required
  28     in
  29     { Neturl.null_url_syntax with
  30         Neturl.url_enable_scheme = enable_if `Allowed;
  31         Neturl.url_enable_host   = enable_if `Allowed;
  32         Neturl.url_enable_path   = Neturl.Url_part_required;
  33         Neturl.url_accepts_8bits = true;
  34     }
  35 ;;
  36
  37 let file_url_of_id xid =
  38   let file_url_of_sysname sysname =
  39     (* By convention, we can assume that sysname is a URL conforming
  40      * to RFC 1738 with the exception that it may contain non-ASCII
  41      * UTF-8 characters.
  42      *)
  43     try
  44      Neturl.url_of_string url_syntax sysname
  45         (* may raise Malformed_URL *)
  46     with
  47      Neturl.Malformed_URL -> raise Pxp_reader.Not_competent
  48   in
  49   let url =
  50     match xid with
  51        Pxp_types.Anonymous          -> raise Pxp_reader.Not_competent
  52      | Pxp_types.Public (_,sysname) ->
  53         let sysname = resolve sysname in
  54          if sysname <> "" then file_url_of_sysname sysname
  55                           else raise Pxp_reader.Not_competent
  56      | Pxp_types.System sysname     ->
  57         let sysname = resolve sysname in
  58          file_url_of_sysname sysname
  59   in
  60   let scheme =
  61     try Neturl.url_scheme url with Not_found -> "file" in
  62   let host =
  63     try Neturl.url_host url with Not_found -> "" in
  64
  65   if scheme <> "file" then raise Pxp_reader.Not_competent;
  66   if host <> "" && host <> "localhost" then raise Pxp_reader.Not_competent;
  67
  68   url
  69 ;;
  70
  71 let from_file ?system_encoding utf8_filename =
  72
  73   let r =
  74     new Pxp_reader.resolve_as_file
  75       ?system_encoding:system_encoding
  76       ~url_of_id:file_url_of_id
  77       ()
  78   in
  79
  80   let utf8_abs_filename =
  81     if utf8_filename <> "" && utf8_filename.[0] = '/' then
  82       utf8_filename
  83     else
  84       Sys.getcwd() ^ "/" ^ utf8_filename
  85   in
  86
  87   let syntax = { Neturl.ip_url_syntax with Neturl.url_accepts_8bits = true } in
  88   let url = Neturl.make_url
  89               ~scheme:"file"
  90               ~host:"localhost"
  91               ~path:(Neturl.split_path utf8_abs_filename)
  92               syntax
  93   in
  94
  95   let xid = Pxp_types.System (Neturl.string_of_url url) in
  96
  97
  98   Pxp_yacc.ExtID(xid, r)
  99 ;;
 100
 101