1; uri.ss
2;
3;   Copyright (c) 2010  Higepon(Taro Minowa)  <higepon@users.sourceforge.jp>
4;
5;
6;   Redistribution and use in source and binary forms, with or without
7;   modification, are permitted provided that the following conditions
8;   are met:
9;
10;   1. Redistributions of source code must retain the above copyright
11;      notice, this list of conditions and the following disclaimer.
12;
13;   2. Redistributions in binary form must reproduce the above copyright
14;      notice, this list of conditions and the following disclaimer in the
15;      documentation and/or other materials provided with the distribution.
16;
17;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
18;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
19;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
20;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
21;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
22;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
23;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
24;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
25;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
26;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
27;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28;
29(library (uri)
30  (export uri-encode uri-decode)
31  (import (rnrs))
32
33;; This library is undocumented. APIs is subject to change without notice.
34
35;; http://tips.lisp-users.org/scheme/
36(define uri-unreserved-char-sv?
37  (let ((unreserved-char-svs (map char->integer
38                                  (string->list
39                                   "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-._‾"))))
40    (lambda (sv)
41      (and (memv sv unreserved-char-svs) #t))))
42
43(define (uri-encode str)
44  (let ((svs (bytevector->u8-list (string->utf8 str))))
45    (call-with-string-output-port
46     (lambda (p)
47       (for-each
48        (lambda (sv)
49          (cond ((uri-unreserved-char-sv? sv)
50                 (display (integer->char sv) (current-error-port))
51                 (newline (current-error-port))
52                 (display (integer->char sv) p))
53                (else
54                 (display "%" p)
55                 (when (< sv 16)
56                   (display "0" p))
57                 (display (number->string sv 16) p))))
58        svs)))))
59
60(define (uri-decode str)
61  (define digit->integer
62    (lambda (c)
63      (cond
64        ((char<=? #\0 c #\9) (- (char->integer c) (char->integer #\0)))
65        ((char<=? #\a c #\f) (+ 10 (- (char->integer c) (char->integer #\a))))
66        ((char<=? #\A c #\F) (+ 10 (- (char->integer c) (char->integer #\A))))
67        (else #f))))
68  (define percent-filter
69    (lambda (in out err)
70      (let loop ((c (peek-char in)))
71        (and (not (eof-object? c)) (char=? c #\%)
72          (let* ((cp (get-char in)) (c1 (get-char in)) (c2 (get-char in)))
73            (cond
74              ((eof-object? c1) (put-char err cp))
75              ((eof-object? c2) (put-char err cp) (put-char err c1))
76              (else
77                (let ((i1 (digit->integer c1)) (i2 (digit->integer c2)))
78                  (cond
79                    ((and i1 i2)
80                      (put-u8 out (+ (* 16 (digit->integer c1)) (digit->integer c2)))
81                      (loop (peek-char in)))
82                    (else
83                      (put-char err cp)
84                      (put-char err c1)
85                      (put-char err c2)))))))))))
86  (define filter
87    (lambda (in out)
88      (let loop ((c (peek-char in)))
89        (when (not (eof-object? c))
90          (if (char=? c #\%)
91            (put-string out
92              (bytevector->string
93                (call-with-bytevector-output-port
94                  (lambda (op) (percent-filter in op out)))
95                (make-transcoder (utf-8-codec))))
96            (let ((c (get-char in)))
97              (cond
98                ((char=? c #\+) (put-char out #\space))
99                (else (put-char out c)))))
100          (loop (peek-char in))))))
101  (call-with-port (open-string-input-port str)
102    (lambda (in)
103      (call-with-string-output-port
104        (lambda (out) (filter in out))))))
105)
106