helm/metadata/create2/mk_forward/pxpUriResolver.ml

   1 (* Copyright (C) 2000, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://cs.unibo.it/helm/.
  24  *)
  25
  26 (******************************************************************************)
  27 (*                                                                            *)
  28 (*                               PROJECT HELM                                 *)
  29 (*                                                                            *)
  30 (*                Claudio Sacerdoti Coen <sacerdot@cs.unibo.it>               *)
  31 (*                                 11/10/2000                                 *)
  32 (*                                                                            *)
  33 (*                                                                            *)
  34 (******************************************************************************)
  35
  36 let resolve s =
  37  let starts_with s s' =
  38   if String.length s < String.length s' then
  39    false
  40   else
  41    (String.sub s 0 (String.length s')) = s'
  42  in
  43   if starts_with s "http:" then
  44    ClientHTTP.get_and_save_to_tmp s
  45   else
  46    s
  47 ;;
  48
  49 (*PXP 1.0
  50 let url_syntax =
  51     let enable_if =
  52       function
  53           `Not_recognized  -> Neturl.Url_part_not_recognized
  54         | `Allowed         -> Neturl.Url_part_allowed
  55         | `Required        -> Neturl.Url_part_required
  56     in
  57     { Neturl.null_url_syntax with
  58         Neturl.url_enable_scheme = enable_if `Allowed;
  59         Neturl.url_enable_host   = enable_if `Allowed;
  60         Neturl.url_enable_path   = Neturl.Url_part_required;
  61         Neturl.url_accepts_8bits = true;
  62     }
  63 ;;
  64
  65 exception Unexpected;; (* Added when porting the file to PXP 1.1 *)
  66
  67 let file_url_of_id xid =
  68   let file_url_of_sysname sysname =
  69     (* By convention, we can assume that sysname is a URL conforming
  70      * to RFC 1738 with the exception that it may contain non-ASCII
  71      * UTF-8 characters.
  72      *)
  73     try
  74      Neturl.url_of_string url_syntax sysname
  75         (* may raise Malformed_URL *)
  76     with
  77      Neturl.Malformed_URL -> raise Pxp_reader.Not_competent
  78   in
  79   let url =
  80     match xid with
  81        Pxp_types.Anonymous          -> raise Pxp_reader.Not_competent
  82      | Pxp_types.Public (_,sysname) ->
  83         let sysname = resolve sysname in
  84          if sysname <> "" then file_url_of_sysname sysname
  85                           else raise Pxp_reader.Not_competent
  86      | Pxp_types.System sysname     ->
  87         let sysname = resolve sysname in
  88          file_url_of_sysname sysname
  89      | Pxp_types.Private pid -> raise Unexpected
  90   in
  91   let scheme =
  92     try Neturl.url_scheme url with Not_found -> "file" in
  93   let host =
  94     try Neturl.url_host url with Not_found -> "" in
  95
  96   if scheme <> "file" then raise Pxp_reader.Not_competent;
  97   if host <> "" && host <> "localhost" then raise Pxp_reader.Not_competent;
  98
  99   url
 100 ;;
 101
 102 let from_file ?system_encoding utf8_filename =
 103
 104   let r =
 105     new Pxp_reader.resolve_as_file
 106       ?system_encoding:system_encoding
 107       ~url_of_id:file_url_of_id
 108       ()
 109   in
 110
 111   let utf8_abs_filename =
 112     if utf8_filename <> "" && utf8_filename.[0] = '/' then
 113       utf8_filename
 114     else
 115       Sys.getcwd() ^ "/" ^ utf8_filename
 116   in
 117
 118   let syntax = { Neturl.ip_url_syntax with Neturl.url_accepts_8bits = true } in
 119   let url = Neturl.make_url
 120               ~scheme:"file"
 121               ~host:"localhost"
 122               ~path:(Neturl.split_path utf8_abs_filename)
 123               syntax
 124   in
 125
 126   let xid = Pxp_types.System (Neturl.string_of_url url) in
 127
 128
 129   Pxp_yacc.ExtID(xid, r)
 130 ;;
 131 *)
 132
 133 (*PXP 1.1*)
 134 (* csc_pxp_reader.ml is an exact copy of PXP pxp_reader.ml *)
 135 (* The only reason is to loosen the interface              *)
 136
 137 class resolve_as_file
 138   ?(file_prefix = (`Allowed :> Csc_pxp_reader.spec))
 139   ?(host_prefix = (`Allowed :> Csc_pxp_reader.spec))
 140   ?(system_encoding = `Enc_utf8)
 141   ?(map_private_id = (fun _ -> raise Csc_pxp_reader.Not_competent))
 142   ?(open_private_id = (fun _ -> raise Csc_pxp_reader.Not_competent))
 143   ()
 144   =
 145
 146   let url_syntax =
 147     let enable_if =
 148       function
 149           `Not_recognized  -> Neturl.Url_part_not_recognized
 150         | `Allowed         -> Neturl.Url_part_allowed
 151         | `Required        -> Neturl.Url_part_required
 152     in
 153     { Neturl.null_url_syntax with
 154         Neturl.url_enable_scheme = enable_if file_prefix;
 155         Neturl.url_enable_host   = enable_if host_prefix;
 156         Neturl.url_enable_path   = Neturl.Url_part_required;
 157         Neturl.url_accepts_8bits = true;
 158     }
 159   in
 160
 161   let base_url_syntax =
 162     { Neturl.null_url_syntax with
 163         Neturl.url_enable_scheme = Neturl.Url_part_required;
 164         Neturl.url_enable_host   = Neturl.Url_part_allowed;
 165         Neturl.url_enable_path   = Neturl.Url_part_required;
 166         Neturl.url_accepts_8bits = true;
 167     }
 168   in
 169
 170   let default_base_url =
 171     Neturl.make_url
 172       ~scheme: "file"
 173       ~host:   ""
 174       ~path:   (Neturl.split_path (Sys.getcwd() ^ "/"))
 175       base_url_syntax
 176   in
 177
 178   let file_url_of_id xid =
 179    let module P = Csc_pxp_reader in
 180    let module T = Pxp_types in
 181     let file_url_of_sysname sysname =
 182       (* By convention, we can assume that sysname is a URL conforming
 183        * to RFC 1738 with the exception that it may contain non-ASCII
 184        * UTF-8 characters.
 185        *)
 186       try
 187         Neturl.url_of_string url_syntax sysname
 188           (* may raise Malformed_URL *)
 189       with
 190           Neturl.Malformed_URL -> raise P.Not_competent
 191     in
 192     let url =
 193       match xid with
 194           T.Anonymous          -> raise P.Not_competent
 195         | T.Public (_,sysname) -> let sysname = resolve sysname in
 196                                   if sysname <> "" then file_url_of_sysname sysname
 197                                                  else raise P.Not_competent
 198         | T.System sysname     -> let sysname = resolve sysname in
 199                                   file_url_of_sysname sysname
 200         | T.Private pid        -> map_private_id pid
 201     in
 202     let scheme =
 203       try Neturl.url_scheme url with Not_found -> "file" in
 204     let host =
 205       try Neturl.url_host url with Not_found -> "" in
 206
 207     if scheme <> "file" then raise P.Not_competent;
 208     if host <> "" && host <> "localhost" then raise P.Not_competent;
 209
 210     url
 211   in
 212
 213   let channel_of_file_url xid url =
 214    let module P = Csc_pxp_reader in
 215    let module T = Pxp_types in
 216     match xid with
 217         T.Private pid -> open_private_id pid
 218       | _ ->
 219           ( try
 220               let path_utf8 =
 221                 try Neturl.join_path (Neturl.url_path ~encoded:false url)
 222                 with Not_found -> raise P.Not_competent
 223               in
 224
 225               let path =
 226                 Netconversion.recode_string
 227                   ~in_enc:  `Enc_utf8
 228                   ~out_enc: system_encoding
 229                   path_utf8 in
 230               (* May raise Malformed_code *)
 231
 232               open_in_bin path, None
 233                 (* May raise Sys_error *)
 234
 235             with
 236               | Netconversion.Malformed_code -> assert false
 237                 (* should not happen *)
 238               | Sys_error _ as e ->
 239                   raise (P.Not_resolvable e)
 240           )
 241   in
 242
 243   Csc_pxp_reader.resolve_read_url_channel
 244     ~base_url:       default_base_url
 245     ~url_of_id:      file_url_of_id
 246     ~channel_of_url: channel_of_file_url
 247     ()
 248 ;;
 249
 250 let from_file ?(alt = []) ?system_encoding ?enc utf8_filename =
 251   let r =
 252     new resolve_as_file
 253     ?system_encoding:system_encoding
 254       ()
 255   in
 256
 257   let url = Csc_pxp_reader.make_file_url
 258               ?system_encoding
 259               ?enc
 260               utf8_filename in
 261
 262   let xid = Pxp_types.System (Neturl.string_of_url url) in
 263
 264   Pxp_yacc.ExtID(xid, new Csc_pxp_reader.combine (r :: alt))
 265 ;;
 266