source: project/url/url.scm @ 4084

Last change on this file since 4084 was 4084, checked in by daishi, 14 years ago

uri: removed url-compatible code

File size: 5.1 KB
Line 
1;;;; url.scm
2;;;; url-compatible code for uri.scm [Daishi Kato]
3
4(use uri)
5
6(eval-when (compile)
7  (declare
8    (usual-integrations)
9    (fixnum)
10    (inline)
11    (no-procedure-checks)
12    (export
13      ;; url egg compatibility (deprecated)
14      url? url-scheme url-user url-password url-host url-port url-path
15      url-typecode url->string url url-decode url-encode make-url) ) )
16
17;;;
18;;; URL Compatibility (Deprecated)
19;;;
20
21;Copyright (c) 2003-2005, Felix L. Winkelmann
22;All rights reserved.
23;
24;Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
25;conditions are met:
26;
27;  Redistributions of source code must retain the above copyright notice, this list of conditions and the following
28;    disclaimer.
29;  Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
30;    disclaimer in the documentation and/or other materials provided with the distribution.
31;  Neither the name of the author nor the names of its contributors may be used to endorse or promote
32;    products derived from this software without specific prior written permission.
33;
34;THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
35;OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
36;AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
37;CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
38;CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
39;SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
40;THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
41;OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
42;POSSIBILITY OF SUCH DAMAGE.
43
44(define url? uri?)
45
46(define url->string uri->string)
47
48(define (url-scheme x)
49  (and-let* ([sch (uri-scheme x)])
50    (symbol->string sch) ) )
51
52(define url-user uri-username)
53
54(define url-password uri-password)
55
56(define url-host uri-host)
57
58(define url-port uri-port)
59
60(define url-decode uri-decode-query-item)
61
62(define (url-encode str . special)
63  (if (null? special)
64    (uri-encode str)
65    (uri-encode str (list->string (car special)))) )
66
67(define get-typecode
68  (let ([typecode-regex (regexp ";type=(.+)")])
69    (lambda (x)
70      (and-let* ([lst (string-match typecode-regex (last x))])
71        (string-ref (second lst) 0) ) ) ) )
72
73(define (url-path x)
74  (and-let* ([path (uri-path x)])
75    (if (null? path) ; Should never happen
76      #f
77      (let ([path (if (get-typecode path) (drop-right path 1) path)])
78        (if (null? path) ; Should never happen
79          #f
80          (string-intersperse (cdr path) "/"))) ) ) )
81
82(define (url-typecode x)
83  (and-let* ([cod (get-typecode (uri-path x))])
84    cod ) )
85
86(define (make-url #!key scheme user password host port path typecode)
87  (let ([scheme (string->symbol scheme)]
88        [authority
89          (list
90            (and user (if password (string-append user ":" password) user))
91            host
92            port)]
93        [path-list (and path (split-path path))]
94        [option (and typecode (string-append ";type=" (string typecode)))])
95    (when option
96      (set! path-list (append! (or path-list '()) (list option))) )
97    (*make-uri scheme authority path-list #f #f)) )
98
99;;Note - preserves original "+" <-> " " mapping behavior
100;;& typecode
101(define url
102  (let* (
103      [name-chars "[A-Za-z0-9.+%-]+"]
104      [path-chars "[A-Za-z0-9.~/+%-]+"]
105      [url-regex
106        (regexp
107          (string-append
108            "((" name-chars "\\:)?(//))?("      ; scheme
109            name-chars "(\\:"               ; user
110            name-chars ")?@)?("                         ; password
111            name-chars ")?(\\:[0-9]+)?(/"       ; host
112            path-chars ")?"                                 ; path
113            "(;type=[aid])?")) ] )          ; typecode
114    (lambda (str . default)
115      (match (string-match url-regex str)
116        [(_ _ scheme _ user password host port path typecode)
117          (make-url
118            #:scheme
119              (and scheme (substring scheme 0 (sub1 (string-length scheme))))
120            #:user
121              (and user
122                   (url-decode
123                     (if password
124                       (substring user 0 (- (string-length user) (string-length password) 1))
125                       (substring user 0 (- (string-length user) 1)) ) ) )
126            #:password
127              (and password (url-decode (substring password 1 (string-length password))))
128            #:host
129              (and host (url-decode host))
130            #:port
131              (and port (string->number (url-decode (substring port 1 (string-length port)))))
132            #:path
133              (and path (url-decode (substring path 1 (string-length path))))
134            #:typecode
135              (and typecode (string-ref (url-decode typecode) (sub1 (string-length typecode)))) ) ]
136        [_
137          (if (pair? default)
138            (car default)
139            (error 'url "invalid URL" str) ) ] ) ) ) )
140
141
Note: See TracBrowser for help on using the repository browser.