275
|
1
|
;;; obj/uri/path.lisp --- URI Path merging functions |
|
2
|
|
|
3
|
;; |
|
4
|
|
|
5
|
;;; Code: |
|
6
|
(in-package :obj/uri) |
|
7
|
;; merging and unmerging |
|
8
|
(defmethod merge-uris ((uri string) (base string) &optional place) |
|
9
|
(merge-uris (parse-uri uri) (parse-uri base) place)) |
|
10
|
|
|
11
|
(defmethod merge-uris ((uri uri) (base string) &optional place) |
|
12
|
(merge-uris uri (parse-uri base) place)) |
|
13
|
|
|
14
|
(defmethod merge-uris ((uri string) (base uri) &optional place) |
|
15
|
(merge-uris (parse-uri uri) base place)) |
|
16
|
|
|
17
|
(defmethod merge-uris ((uri uri) (base uri) &optional place) |
|
18
|
;; When PLACE is nil, this function returns a new URI. |
|
19
|
;; When PLACE is non-nil, it is return. |
|
20
|
(tagbody |
|
21
|
(when (and (null (uri-path uri)) |
|
22
|
(null (uri-scheme uri)) |
|
23
|
(null (uri-host uri)) |
|
24
|
(null (uri-userinfo uri)) |
|
25
|
(null (uri-port uri)) |
|
26
|
(null (uri-query uri))) |
|
27
|
(return-from merge-uris |
|
28
|
(let ((new (copy-uri base :place place))) |
|
29
|
(when (uri-query uri) |
|
30
|
(setf (uri-query new) (uri-query uri))) |
|
31
|
(when (uri-fragment uri) |
|
32
|
(setf (uri-fragment new) (uri-fragment uri))) |
|
33
|
new))) |
|
34
|
|
|
35
|
(setq uri (copy-uri uri :place place)) |
|
36
|
|
|
37
|
(when (uri-scheme uri) (go :done)) |
|
38
|
|
|
39
|
(setf (uri-scheme uri) (uri-scheme base)) |
|
40
|
|
|
41
|
;; if URI has a host, we're done |
|
42
|
(when (uri-host uri) (go :done)) |
|
43
|
|
|
44
|
(set-host uri |
|
45
|
(%uri-host base) |
|
46
|
(%uri-ipv6 base) |
|
47
|
(%uri-zone-id base)) |
|
48
|
(setf (uri-userinfo uri) (uri-userinfo base)) |
|
49
|
(setf (uri-port uri) (uri-port base)) |
|
50
|
|
|
51
|
(let ((p (uri-parsed-path uri))) |
|
52
|
(when (null p) |
|
53
|
(setf (uri-path uri) (uri-path base)) |
|
54
|
(go :done)) |
|
55
|
|
|
56
|
(when (and p (eq :absolute (car p))) |
|
57
|
(if* (equal '(:absolute "") p) |
|
58
|
then ;; Canonicalize the way parsing does: |
|
59
|
(setf (uri-path uri) nil) |
|
60
|
elseif (eq :absolute (first p)) |
|
61
|
then ;; this also sets uri-path |
|
62
|
(multiple-value-bind (new changed) |
|
63
|
(canonicalize-path-list p) |
|
64
|
(when changed |
|
65
|
(setf (uri-parsed-path uri) new)))) |
|
66
|
(go :done))) |
|
67
|
|
|
68
|
(let* ((base-path |
|
69
|
(or (uri-parsed-path base) |
|
70
|
;; needed because we canonicalize away a path of just `/': |
|
71
|
'(:absolute ""))) |
|
72
|
(path (uri-parsed-path uri)) |
|
73
|
new-path-list) |
|
74
|
(when (not (eq :absolute (car base-path))) |
|
75
|
(error "Cannot merge ~a and ~a, since the latter is not absolute." |
|
76
|
uri base)) |
|
77
|
|
|
78
|
(setq new-path-list |
|
79
|
(append (butlast base-path) |
|
80
|
(if* path then (cdr path) else '("")))) |
|
81
|
|
|
82
|
(let ((last (last new-path-list))) |
|
83
|
(if* (atom (car last)) |
|
84
|
then (when (string= "." (car last)) |
|
85
|
(setf (car last) "")) |
|
86
|
else (when (string= "." (caar last)) |
|
87
|
(setf (caar last) "")))) |
|
88
|
(setq new-path-list |
|
89
|
(delete "." new-path-list :test #'(lambda (a b) |
|
90
|
(if* (atom b) |
|
91
|
then (string= a b) |
|
92
|
else nil)))) |
|
93
|
|
|
94
|
(let ((npl (cdr new-path-list)) |
|
95
|
index tmp fix-tail) |
|
96
|
(setq fix-tail |
|
97
|
(string= ".." (let ((l (car (last npl)))) |
|
98
|
(if* (atom l) |
|
99
|
then l |
|
100
|
else (car l))))) |
|
101
|
(loop |
|
102
|
(setq index |
|
103
|
(position ".." npl |
|
104
|
:test #'(lambda (a b) |
|
105
|
(string= a |
|
106
|
(if* (atom b) |
|
107
|
then b |
|
108
|
else (car b)))))) |
|
109
|
(when (null index) (return)) |
|
110
|
|
|
111
|
(if* (= 0 index) |
|
112
|
then ;; rfe11852: RFC 3986, in section 5.4.2 (Abnormal |
|
113
|
;; Examples) says parsers; must be careful in handling |
|
114
|
;; cases where there are more ".." segments in a |
|
115
|
;; relative-path reference than there are in the base |
|
116
|
;; URI's path. The examples, between the two RFC's were |
|
117
|
;; changed to show the additional, leading ..'s to be |
|
118
|
;; removed. So, we'll do that now. |
|
119
|
(setq npl (cdr npl)) |
|
120
|
elseif (= 1 index) |
|
121
|
then (setq npl (cddr npl)) |
|
122
|
else (setq tmp npl) |
|
123
|
(dotimes (x (- index 2)) (setq tmp (cdr tmp))) |
|
124
|
(setf (cdr tmp) (cdddr tmp)))) |
|
125
|
(setf (cdr new-path-list) npl) |
|
126
|
(when fix-tail (setq new-path-list (nconc new-path-list '(""))))) |
|
127
|
|
|
128
|
(when (eq :absolute (first new-path-list)) |
|
129
|
(multiple-value-bind (new changed) |
|
130
|
(canonicalize-path-list new-path-list) |
|
131
|
(when changed (setq new-path-list new)))) |
|
132
|
|
|
133
|
;; Also sets uri-path: |
|
134
|
(setf (uri-parsed-path uri) new-path-list)) |
|
135
|
|
|
136
|
:done |
|
137
|
(return-from merge-uris uri))) |
|
138
|
|
|
139
|
(defun canonicalize-path-list (path-list &aux changed) |
|
140
|
;; Return two values: new version of PATH-LIST and an indicator if it was |
|
141
|
;; changed. We are only called when (car path-list) is :absolute. |
|
142
|
(loop while (or (equal "." (second path-list)) |
|
143
|
(equal ".." (second path-list))) |
|
144
|
do (setf (cdr path-list) (cddr path-list)) |
|
145
|
(setq changed t)) |
|
146
|
(values path-list changed)) |
|
147
|
|
|
148
|
(defmethod merge-uris ((urn urn) (base urn) &optional place) |
|
149
|
(if* place |
|
150
|
then (setf (urn-nid place) (urn-nid urn)) |
|
151
|
(setf (urn-nss place) (urn-nss urn)) |
|
152
|
place |
|
153
|
else urn)) |
|
154
|
|
|
155
|
(defmethod merge-uris ((urn urn) (base uri) &optional place) |
|
156
|
(if* place |
|
157
|
then (setf (urn-nid place) (urn-nid urn)) |
|
158
|
(setf (urn-nss place) (urn-nss urn)) |
|
159
|
place |
|
160
|
else urn)) |
|
161
|
|
|
162
|
(defmethod merge-uris ((uri uri) (base urn) &optional place) |
|
163
|
(copy-uri uri :place place)) |
|
164
|
|
|
165
|
(defmethod enough-uri ((uri string) (base string) &optional place) |
|
166
|
(enough-uri (parse-uri uri) (parse-uri base) place)) |
|
167
|
|
|
168
|
(defmethod enough-uri ((uri uri) (base string) &optional place) |
|
169
|
(enough-uri uri (parse-uri base) place)) |
|
170
|
|
|
171
|
(defmethod enough-uri ((uri string) (base uri) &optional place) |
|
172
|
(enough-uri (parse-uri uri) base place)) |
|
173
|
|
|
174
|
(defmethod enough-uri ((uri uri) (base uri) &optional place) |
|
175
|
;; Like ENOUGH-PATHNAME, but for URIs. |
|
176
|
(let ((new-scheme nil) |
|
177
|
(new-host nil) |
|
178
|
(new-ipv6 nil) |
|
179
|
(new-zone-id nil) |
|
180
|
(new-userinfo nil) |
|
181
|
(new-port nil) |
|
182
|
(new-parsed-path nil)) |
|
183
|
|
|
184
|
;; If the scheme and authority are not the same, then return URI. |
|
185
|
(when (or (and (uri-scheme uri) |
|
186
|
(not (equalp (uri-scheme uri) (uri-scheme base)))) |
|
187
|
;; We don't use uri-authority, because it conses a lot. |
|
188
|
(and (uri-host uri) |
|
189
|
(not (equalp (uri-host uri) (uri-host base)))) |
|
190
|
(not (equalp (uri-userinfo uri) (uri-userinfo base))) |
|
191
|
(not (equalp (uri-port uri) (uri-port base)))) |
|
192
|
(return-from enough-uri uri)) |
|
193
|
|
|
194
|
;; For this group, if the slot is nil in URI, then the return value is |
|
195
|
;; copied from from BASE: |
|
196
|
(when (null (uri-scheme uri)) (setq new-scheme (uri-scheme base))) |
|
197
|
(when (null (uri-host uri)) |
|
198
|
;; These are copied as a unit: |
|
199
|
(setq new-host (%uri-host base)) |
|
200
|
(setq new-ipv6 (%uri-ipv6 base)) |
|
201
|
(setq new-zone-id (%uri-zone-id base))) |
|
202
|
(when (null (uri-userinfo uri)) (setq new-userinfo (uri-userinfo base))) |
|
203
|
(when (null (uri-port uri)) (setq new-port (uri-port base))) |
|
204
|
|
|
205
|
;; Now, for the hard one, path. |
|
206
|
;; We essentially do here what enough-namestring does. |
|
207
|
(do* ((base-path (uri-parsed-path base)) |
|
208
|
(path (uri-parsed-path uri)) |
|
209
|
(bp base-path (cdr bp)) |
|
210
|
(p path (cdr p))) |
|
211
|
((or (null bp) (null p)) |
|
212
|
;; If p is nil, that means we have something like |
|
213
|
;; (enough-uri "/foo/bar" "/foo/bar/baz.htm"), so |
|
214
|
;; new-parsed-path will be nil. |
|
215
|
(when (null bp) |
|
216
|
(setq new-parsed-path (copy-list p)) |
|
217
|
(when (not (symbolp (car new-parsed-path))) |
|
218
|
(push :relative new-parsed-path)))) |
|
219
|
(if* (equal (car bp) (car p)) |
|
220
|
thenret ;; skip it |
|
221
|
else (setq new-parsed-path (copy-list p)) |
|
222
|
(when (not (symbolp (car new-parsed-path))) |
|
223
|
(push :relative new-parsed-path)) |
|
224
|
(return))) |
|
225
|
|
|
226
|
(let ((new-path |
|
227
|
(or (when new-parsed-path |
|
228
|
(render-parsed-path new-parsed-path |
|
229
|
;; don't know, so have to assume: |
|
230
|
t)) |
|
231
|
;; can't have a completely empty uri! |
|
232
|
"/"))) |
|
233
|
(copy-uri nil :class (class-of uri) :place place |
|
234
|
;;; these come from base if the original slot was nil |
|
235
|
:scheme new-scheme |
|
236
|
:host new-host |
|
237
|
:ipv6 new-ipv6 |
|
238
|
:zone-id new-zone-id |
|
239
|
:userinfo new-userinfo |
|
240
|
:port new-port |
|
241
|
:path new-path |
|
242
|
:parsed-path new-parsed-path |
|
243
|
;;; never from base... why? is this documented? |
|
244
|
:query (uri-query uri) |
|
245
|
:fragment (uri-fragment uri) |
|
246
|
:plist (copy-list (uri-plist uri)))))) |
|
247
|
|
|
248
|
(defmethod enough-uri ((urn urn) (base urn) &optional place) |
|
249
|
(if* place |
|
250
|
then (setf (urn-nid place) (urn-nid urn)) |
|
251
|
(setf (urn-nss place) (urn-nss urn)) |
|
252
|
place |
|
253
|
else urn)) |
|
254
|
|
|
255
|
(defmethod enough-uri ((urn urn) (base uri) &optional place) |
|
256
|
(declare (ignore place)) |
|
257
|
(error "enough-uri of a URN (~a) and URI (~a)." urn base)) |
|
258
|
|
|
259
|
(defmethod enough-uri ((uri uri) (base urn) &optional place) |
|
260
|
(declare (ignore place)) |
|
261
|
(error "enough-uri of a URI (~a) and URN (~a)." uri base)) |
|
262
|
|
|
263
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|
264
|
|
|
265
|
(defun uri-to-pathname (uri) |
|
266
|
;; On Windows, turn file:///d:/foo/bar.cl into #p"d:/foo/bar.cl" |
|
267
|
;; On UNIX, turn file:///foo/bar.cl into #p"/foo/bar.cl" |
|
268
|
(when (not (eq :file (uri-scheme uri))) |
|
269
|
(error "Only file: URIs can be converted to pathnames: ~s." uri)) |
|
270
|
(when (null (uri-path uri)) (error "URI has no path: ~s." uri)) |
|
271
|
(pathname |
|
272
|
(percent-decode-string |
|
273
|
(uri-path uri) |
|
274
|
nil))) |
|
275
|
|
|
276
|
(defun pathname-to-uri (pathname) |
|
277
|
(when (not (uiop:absolute-pathname-p pathname t)) |
|
278
|
(error "A relative pathname cannot be converted to a URI: ~s." pathname)) |
|
279
|
(parse-uri |
|
280
|
(let ((s (percent-encode-string |
|
281
|
#+mswindows (substitute #\/ #\\ (namestring pathname)) |
|
282
|
#-mswindows (namestring pathname) |
|
283
|
*pchar/-bitvector*))) |
|
284
|
#-mswindows (format nil "file://~a" s) |
|
285
|
#+mswindows (if* (pathname-device pathname) |
|
286
|
then (format nil "file:///~a" s) |
|
287
|
else (format nil "file://~a" s))))) |