helm/interface/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 let url_syntax =
  50     let enable_if =
  51       function
  52           `Not_recognized  -> Neturl.Url_part_not_recognized
  53         | `Allowed         -> Neturl.Url_part_allowed
  54         | `Required        -> Neturl.Url_part_required
  55     in
  56     { Neturl.null_url_syntax with
  57         Neturl.url_enable_scheme = enable_if `Allowed;
  58         Neturl.url_enable_host   = enable_if `Allowed;
  59         Neturl.url_enable_path   = Neturl.Url_part_required;
  60         Neturl.url_accepts_8bits = true;
  61     }
  62 ;;
  63
  64 let file_url_of_id xid =
  65   let file_url_of_sysname sysname =
  66     (* By convention, we can assume that sysname is a URL conforming
  67      * to RFC 1738 with the exception that it may contain non-ASCII
  68      * UTF-8 characters.
  69      *)
  70     try
  71      Neturl.url_of_string url_syntax sysname
  72         (* may raise Malformed_URL *)
  73     with
  74      Neturl.Malformed_URL -> raise Pxp_reader.Not_competent
  75   in
  76   let url =
  77     match xid with
  78        Pxp_types.Anonymous          -> raise Pxp_reader.Not_competent
  79      | Pxp_types.Public (_,sysname) ->
  80         let sysname = resolve sysname in
  81          if sysname <> "" then file_url_of_sysname sysname
  82                           else raise Pxp_reader.Not_competent
  83      | Pxp_types.System sysname     ->
  84         let sysname = resolve sysname in
  85          file_url_of_sysname sysname
  86   in
  87   let scheme =
  88     try Neturl.url_scheme url with Not_found -> "file" in
  89   let host =
  90     try Neturl.url_host url with Not_found -> "" in
  91
  92   if scheme <> "file" then raise Pxp_reader.Not_competent;
  93   if host <> "" && host <> "localhost" then raise Pxp_reader.Not_competent;
  94
  95   url
  96 ;;
  97
  98 let from_file ?system_encoding utf8_filename =
  99
 100   let r =
 101     new Pxp_reader.resolve_as_file
 102       ?system_encoding:system_encoding
 103       ~url_of_id:file_url_of_id
 104       ()
 105   in
 106
 107   let utf8_abs_filename =
 108     if utf8_filename <> "" && utf8_filename.[0] = '/' then
 109       utf8_filename
 110     else
 111       Sys.getcwd() ^ "/" ^ utf8_filename
 112   in
 113
 114   let syntax = { Neturl.ip_url_syntax with Neturl.url_accepts_8bits = true } in
 115   let url = Neturl.make_url
 116               ~scheme:"file"
 117               ~host:"localhost"
 118               ~path:(Neturl.split_path utf8_abs_filename)
 119               syntax
 120   in
 121
 122   let xid = Pxp_types.System (Neturl.string_of_url url) in
 123
 124
 125   Pxp_yacc.ExtID(xid, r)
 126 ;;
 127
 128