source: project/url/url.scm @ 4086

Last change on this file since 4086 was 4086, checked in by Kon Lovett, 14 years ago

Fixes for split up uri/url egg. Rmvd older versions.

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