]> matita.cs.unibo.it Git - helm.git/blob - helm/metadata/create2/mk_forward/pxpUriResolver.ml
New procedure to create metadata committed and old procedure removed.
[helm.git] / 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