Coverage report: /home/ellis/comp/core/lib/obj/uri/parse.lisp

KindCoveredAll%
expression129197 65.5
branch3152 59.6
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; obj/uri/parse.lisp --- URI Parsers
2
 
3
 ;;
4
 
5
 ;;; Code:
6
 (in-package :obj/uri)
7
 
8
 (eval-when (:compile-toplevel :execute :load-toplevel)
9
   ;; Generate the parser for URI or IRI.  The only difference is the name
10
   ;; of the parser and for IRIs the binding of %iri-mode to T.
11
   (defmacro gen-xri-parser (name irip)
12
     `(defun ,name (string
13
                    &aux ,@(when irip '((%iri-mode t)))
14
                         (end (length string))
15
                         (.pct-encoded. nil)
16
                         real-host ipv6 zone-id)
17
        (declare (optimize (safety 0))
18
                 (fixnum end)) 
19
 
20
        (check-xri-string string)
21
 
22
        (multiple-value-bind (i scheme userinfo host port path query fragment)
23
            (state-absolute-uri string 0 end)
24
          (when i
25
            (if* (and host (consp host))
26
               then (setq real-host (first host))
27
                    (setq ipv6 (second host))
28
                    (setq zone-id (third host))
29
               else (setq real-host host))
30
            (when port
31
              (setq port (xval string port))
32
              (setq port (parse-integer port :radix 10)))
33
            (return-from ,name
34
              (values (xval string scheme)
35
                      (xval string real-host)
36
                      (xval string userinfo)
37
                      port
38
                      (xval string path)
39
                      (xval string query)
40
                      ;; This is only non-nil for URNs
41
                      (xval string fragment)
42
                      .pct-encoded.
43
                      (xval string ipv6)
44
                      (xval string zone-id)))))
45
 
46
        (multiple-value-bind (i scheme userinfo host port path query fragment)
47
            (state-uri-reference string 0 end)
48
          (when i
49
            (if* (and host (consp host))
50
               then (setq real-host (first host))
51
                    (setq ipv6 (second host))
52
                    (setq zone-id (third host))
53
               else (setq real-host host))
54
            (when port
55
              (setq port (xval string port))
56
              (setq port (parse-integer port :radix 10)))
57
            (return-from ,name
58
              (values (xval string scheme)
59
                      (xval string real-host)
60
                      (xval string userinfo)
61
                      port
62
                      (xval string path)
63
                      (xval string query)
64
                      (xval string fragment)
65
                      .pct-encoded.
66
                      (xval string ipv6)
67
                      (xval string zone-id)))))
68
        (uri-parse-error string "Couldn't parse uri: ~s." string))))
69
 
70
 (defun uri-parse-error (string format-string &rest format-arguments)
71
   (error 'uri-parse-error
72
          :string string
73
          :format-control format-string
74
          :format-arguments format-arguments))
75
 
76
 (gen-xri-parser parse-uri-string-rfc3986 nil)
77
 (gen-xri-parser parse-iri-string-rfc3987 :iri-mode)
78
 
79
 ;; TODO fix string escapes
80
 (defun parse-uri (thing &key (class 'uri) (escape t))
81
   ;; Parse THING into a URI object, an instance of CLASS.
82
   ;;
83
   ;; If ESCAPE is non-nil, then decode percent-encoded characters in places
84
   ;; where they can legally appear, into the raw characters.  The exception
85
   ;; to this is when those characters are reserved for the component in
86
   ;; which they appear, and in this case the percent-encoded character
87
   ;; stays encoded.
88
 
89
   (when (uri-p thing) (return-from parse-uri thing))
90
 
91
   (multiple-value-bind (scheme host userinfo port path query fragment
92
                         pct-encoded ipv6 zone-id)
93
       (parse-uri-string-rfc3986 thing)
94
     (when scheme
95
       (setq scheme
96
         (cond
97
          ;; Ordered from most common to least, and the set of known schemes
98
          ;; hardwired for efficiency.
99
          ((string-equal scheme "https") :https)
100
          ((string-equal scheme "http") :http)
101
          ((string-equal scheme "ssh") :ssh)
102
          ((string-equal scheme "ftp") :ftp)
103
          ((string-equal scheme "file") :file)
104
          ((string-equal scheme "urn") :urn)
105
          ((string-equal scheme "telnet") :telnet)
106
          (t
107
           (intern (funcall
108
                    (case *print-case*
109
                      ((:upcase)
110
                       #'string-upcase)
111
                      ((:downcase)
112
                       #'string-downcase))
113
                    scheme)
114
                   (load-time-value (find-package :keyword)))))))
115
 
116
     (when (and scheme (eq :urn scheme))
117
       (return-from parse-uri
118
         (make-instance 'urn :scheme scheme :nid host :nss path
119
                        :query query :fragment fragment
120
                        :r-component userinfo)))
121
 
122
     (when (and escape host)
123
       (setq host (percent-decode-string host *reg-name-bitvector*)))
124
     (when (and escape userinfo)
125
       (setq userinfo (percent-decode-string userinfo *userinfo-bitvector*)))
126
     (when port
127
       (when (not (numberp port)) (error "port is not a number: ~s." port))
128
       (when (not (plusp port))
129
         (error "port is not a positive integer: ~d." port))
130
       ;; Use `eql' instead of `=' so that scheme's other than the small set
131
       ;; below are possible.
132
       (when (eql port (case scheme
133
                         (:http 80)
134
                         (:https 443)
135
                         (:ftp 21)
136
                         (:telnet 23)))
137
         (setq port nil)))
138
     (when (= 0 (length path))
139
       (setq path nil))
140
     (when (and escape path)
141
       (setq path (percent-decode-string path *pchar-bitvector*)))
142
     (when (and escape query)
143
       (setq query
144
         (percent-decode-string query
145
                                (if* *strict-parse*
146
                                   then *decode-query-bitvector-strict*
147
                                   else *decode-query-bitvector-non-strict*))))
148
     (when (and escape fragment)
149
       (setq fragment
150
         (percent-decode-string fragment
151
                                (if* *strict-parse*
152
                                   then *fragment-bitvector-strict*
153
                                   else *fragment-bitvector-non-strict*))))
154
     (if* (eq 'uri class)
155
        then ;; allow the compiler to optimize the make-instance call:
156
             (make-instance 'uri
157
               :scheme scheme
158
               :host host
159
               :ipv6 ipv6
160
               :zone-id zone-id
161
               :userinfo userinfo
162
               :port port
163
               :path path
164
               :query query
165
               :fragment fragment
166
               :escaped (when escape pct-encoded))
167
        else ;; do it the slow way:
168
             (make-instance class
169
               :scheme scheme
170
               :host host
171
               :userinfo userinfo
172
               :port port
173
               :path path
174
               :query query
175
               :fragment fragment
176
               :escaped (when escape pct-encoded)))))
177
 
178
   (defmacro gen-string-to-xri (name parser class)
179
     `(defun ,name (string)
180
        ;; Parse STRING as a xRI and either signal an error if it cannot be
181
        ;; parsed or return the xRI object.  This function differs from
182
        ;; parse-uri in that the query is not decoded.  The knowledge of how
183
        ;; to properly decode the query is outside the bounds of RFC 3986/7.
184
        (multiple-value-bind (scheme host userinfo port path query fragment
185
                         pct-encoded ;; non-nil if any %xx in any slot
186
                         ipv6 zone-id)
187
       (,parser string)
188
 
189
     (when scheme
190
       (setq scheme
191
         (cond
192
          ;; Ordered from most common to least, and the set of known schemes
193
          ;; hardwired for efficiency.
194
          ((string-equal scheme "https") :https)
195
          ((string-equal scheme "http") :http)
196
          ((string-equal scheme "ftp") :ftp)
197
          ((string-equal scheme "file") :file)
198
          ((string-equal scheme "urn") :urn)
199
          ((string-equal scheme "telnet") :telnet)
200
          (t
201
           (intern (funcall
202
                    (case *print-case*
203
                      ((:upcase)
204
                       #'string-upcase)
205
                      ((:downcase)
206
                       #'string-downcase))
207
                    scheme)
208
                   (load-time-value (find-package :keyword)))))))
209
 
210
     (when (and scheme (eq :urn scheme))
211
       (return-from ,name
212
         ;; NOTE: for now, we treat URNs like parse-uri, and do no
213
         ;; decoding.
214
         (make-instance 'urn :scheme scheme :nid host :nss path
215
                        :query query :fragment fragment
216
                        :r-component userinfo)))
217
 
218
     (when (and pct-encoded host)
219
       (setq host (percent-decode-string host *reg-name-bitvector*)))
220
 
221
     (when (and pct-encoded userinfo)
222
       (setq userinfo (percent-decode-string userinfo *userinfo-bitvector*)))
223
 
224
     (when port
225
       (when (not (numberp port)) (error "port is not a number: ~s." port))
226
       (when (not (plusp port))
227
         (error "port is not a positive integer: ~d." port))
228
       ;; Use `eql' instead of `=' so that scheme's other than the small set
229
       ;; below are possible.
230
       (when (eql port (case scheme
231
                         (:http 80)
232
                         (:https 443)
233
                         (:ftp 21)
234
                         (:telnet 23)))
235
         (setq port nil)))
236
 
237
     (when (= 0 (length path))
238
       (setq path nil))
239
     (when (and pct-encoded path)
240
       (setq path (percent-decode-string path *pchar-bitvector*)))
241
 
242
     ;; query is left alone
243
 
244
     (when (and pct-encoded fragment)
245
       (setq fragment
246
         (percent-decode-string fragment
247
                                (if* *strict-parse*
248
                                   then *fragment-bitvector-strict*
249
                                   else *fragment-bitvector-non-strict*))))
250
 
251
     (make-instance ,class
252
       :scheme scheme
253
       :host host
254
       :ipv6 ipv6
255
       :zone-id zone-id
256
       :userinfo userinfo
257
       :port port
258
       :path path
259
       :query query
260
       :fragment fragment
261
       :escaped pct-encoded))))
262
 
263
 (gen-string-to-xri string-to-uri parse-uri-string-rfc3986 'uri)
264
 (gen-string-to-xri string-to-iri parse-iri-string-rfc3987 'iri)
265
 
266
 (defun parse-path (path-string escape)
267
   (do* ((xpath-list (uiop:split-string path-string :separator '(#\/)))
268
         (path-list
269
          (let (#+mswindows temp #+mswindows c)
270
            (cond ((string= "" (car xpath-list))
271
                   (setf (car xpath-list) :absolute))
272
                  (t (push :relative xpath-list)))
273
            xpath-list))
274
         (pl (cdr path-list) (cdr pl))
275
         segments)
276
       ((null pl) path-list)
277
 
278
     (if* (symbolp (car pl))
279
        then ;; Only happens on Windows when we see a path with a drive
280
             ;; letter.  The lack of #+mswindows doesn't matter here.
281
             nil
282
      elseif (cdr (setq segments
283
                    (if* (string= "" (car pl))
284
                       then '("")
285
                       else (uiop:split-string (car pl) :separator '(#\:)))))
286
        then ;; there is a param
287
             (setf (car pl)
288
               (mapcar #'(lambda (s)
289
                           (if* escape
290
                              then (percent-decode-string s nil)
291
                              else s))
292
                       segments))
293
        else ;; no param
294
             (setf (car pl)
295
               (if* escape
296
                  then (percent-decode-string (car segments) nil)
297
                  else (car segments))))))