source: project/url/url.scm.v1.7 @ 3123

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

moved v1.7 just in case

File size: 5.2 KB
Line 
1;;;; url.scm
2;
3; Copyright (c) 2003-2005, Felix L. Winkelmann
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25;
26; Send bugs, suggestions and ideas to:
27;
28; felix@call-with-current-continuation.org
29;
30; Felix L. Winkelmann
31; Steinweg 1A
32; 37130 Gleichen, OT Weissenborn
33; Germany
34
35
36(declare
37  (uses regex extras)
38  (export url? url-scheme url-user url-password url-host url-host url-port url-path url-typecode
39          url->string url url-decode url-encode make-url) )
40
41(define name-chars (if (test-feature? 'pregexp) "[A-Za-z0-9---.+%]+" "[-A-Za-z0-9.+%]+"))
42(define path-chars (if (test-feature? 'pregexp) "[A-Za-z0-9---.~/+%]+" "[-A-Za-z0-9.~/+%]+"))
43
44;(when (memq #:pregexp ##sys#features)
45;  (error "sorry - URL parsing is currently not available with pregexp") )
46
47(define url-regex
48  (regexp
49   (string-append
50    "((" name-chars "\\:)?(//))?("      ; scheme
51    name-chars "(\\:"                   ; user
52    name-chars ")?@)?("                 ; password
53    name-chars ")?(\\:[0-9]+)?(/"       ; host
54    path-chars ")?"                     ; path
55    "(;type=[aid])?") ) )               ; typecode
56
57(define-record url scheme user password host port path typecode)
58
59(define %make-url make-url)
60
61(define (make-url #!key scheme user password host port path typecode)
62  (%make-url scheme user password host port path typecode) )
63
64(define (spaces str)
65  (string-translate str #\+ #\space) )
66
67(define (url str . default)
68  (match (string-match url-regex str)
69    [(_ _ scheme _ user password host port path typecode)
70     (%make-url
71      (and scheme (substring scheme 0 (sub1 (string-length scheme))))
72      (and user
73           (url-decode
74            (if password
75                (substring user 0 (- (string-length user) (string-length password) 1))
76                (substring user 0 (- (string-length user) 1)) ) ) )
77      (and password (url-decode (substring password 1 (string-length password))))
78      (and host (url-decode host))
79      (and port (string->number (url-decode (substring port 1 (string-length port)))))
80      (and path (url-decode (substring path 1 (string-length path))))
81      (and typecode (string-ref (url-decode typecode) (sub1 (string-length typecode)))) ) ]
82    [_ (if (pair? default)
83           (car default)
84           (error "not a valid URL" str) ) ] ) )
85
86(define (url->string url)
87  (string-append
88   (or (and-let* ([scheme (url-scheme url)])
89         (string-append scheme "://") )
90       "")
91   (or (and-let* ([user (url-user url)])
92         (string-append
93          (url-encode user)
94          (or (and-let* ([pass (url-password url)])
95                (string-append ":" (url-encode pass) ) )
96              "")
97          "@") )
98       "")
99   (or (and-let* ([host (url-host url)])
100         (url-encode host) )
101       "")
102   (or (and-let* ([port (url-port url)])
103         (string-append ":" (url-encode (number->string port)) ) )
104       "")
105   (or (and-let* ([path (url-path url)])
106         (string-append "/" (url-encode path '(#\/))) )
107       "")
108   (or (and-let* ([type (url-typecode url)])
109         (string-append ";type=" (url-encode (string type)) ) )
110       "") ) )
111
112(define (url-encode str #!optional special)
113  (let ([special (cons #\. (cons #\- special))])
114    (list->string
115     (let loop ([lst (string->list str)])
116       (if (null? lst)
117           '()
118           (let ([c (car lst)])
119             (if (or (char-alphabetic? c)
120                     (char-numeric? c)
121                     (memq c special) )
122                 (cons c (loop (cdr lst)))
123                 (let ([s (number->string (char->integer c) 16)])
124                   (cons #\%
125                         (if (= 1 (string-length s))
126                             (cons #\0 (cons (string-ref s 0) (loop (cdr lst))))
127                             (cons (string-ref s 0) (cons (string-ref s 1) (loop (cdr lst)))) ) ) ) ) ) ) ) ) ) )
128
129(define (url-decode str)
130  (let ((str (spaces str)))
131    (let loop ([i 0])
132      (match (string-search-positions "%[0-9a-fA-F][0-9a-fA-F]" str i)
133        [((start end))
134         (string-append
135          (substring str i start)
136          (string (integer->char (string->number (substring str (add1 start) end) 16)))
137          (loop end) ) ]
138        [_ (substring str i (string-length str))] ) ) ) )
139
140(define-record-printer (url u p)
141  (fprintf p "#<url: ~A>" (url->string u)) )
Note: See TracBrowser for help on using the repository browser.