1 |
;;;; www/url.scm: URL manipulation tools. |
;;; www/url.scm --- URL manipulation tools |
2 |
|
|
3 |
;;;; Copyright (C) 1997,2001 Free Software Foundation, Inc. |
;; Copyright (C) 1997,2001,2002 Free Software Foundation, Inc. |
4 |
;;;; |
;; |
5 |
;;;; This program is free software; you can redistribute it and/or modify |
;; This program is free software; you can redistribute it and/or modify |
6 |
;;;; it under the terms of the GNU General Public License as published by |
;; it under the terms of the GNU General Public License as published by |
7 |
;;;; the Free Software Foundation; either version 2, or (at your option) |
;; the Free Software Foundation; either version 2, or (at your option) |
8 |
;;;; any later version. |
;; any later version. |
9 |
;;;; |
;; |
10 |
;;;; This program is distributed in the hope that it will be useful, |
;; This program is distributed in the hope that it will be useful, |
11 |
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
12 |
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
13 |
;;;; GNU General Public License for more details. |
;; GNU General Public License for more details. |
14 |
;;;; |
;; |
15 |
;;;; You should have received a copy of the GNU General Public License |
;; You should have received a copy of the GNU General Public License |
16 |
;;;; along with this software; see the file COPYING. If not, write to |
;; along with this software; see the file COPYING. If not, write to |
17 |
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
18 |
;;;; Boston, MA 02111-1307 USA |
;; Boston, MA 02111-1307 USA |
19 |
;;;; |
;; |
20 |
|
|
21 |
;;; Commentary: |
;;; Commentary: |
22 |
|
|
40 |
;;; Code: |
;;; Code: |
41 |
|
|
42 |
|
|
43 |
;;;; TODO: |
;; TODO: |
44 |
;;;; * support `user:password@' strings where appropriate in URLs. |
;; * support `user:password@' strings where appropriate in URLs. |
45 |
;;;; * make URL parsing smarter. This is good for most TCP/IP-based |
;; * make URL parsing smarter. This is good for most TCP/IP-based |
46 |
;;;; URL schemes, but parsing is actually specific to each URL scheme. |
;; URL schemes, but parsing is actually specific to each URL scheme. |
47 |
;;;; * fill out url:encode, include facilities for URL-scheme-specific |
;; * fill out url:encode, include facilities for URL-scheme-specific |
48 |
;;;; encoding methods (e.g. a url-scheme-reserved-char-alist) |
;; encoding methods (e.g. a url-scheme-reserved-char-alist) |
49 |
|
|
50 |
(define-module (www url) |
(define-module (www url) |
51 |
:use-module (ice-9 regex)) |
:use-module (ice-9 regex)) |
101 |
|
|
102 |
|
|
103 |
(define-public (url:unparse url) |
(define-public (url:unparse url) |
104 |
(define (pathy scheme username host port path) |
(define (pathy scheme username url) ; username not used! |
105 |
(string-append (symbol->string scheme) |
(format #f "~A://~A~A~A" |
106 |
"://" host |
scheme |
107 |
(if port (string-append ":" (number->string port)) |
(url:host url) |
108 |
"") |
(cond ((url:port url) => (lambda (port) (format #f ":~A" port))) |
109 |
(if path (string-append "/" path) |
(else "")) |
110 |
""))) |
(cond ((url:path url) => (lambda (path) (format #f "/~A" path))) |
111 |
|
(else "")))) |
112 |
(case (url:scheme url) |
(case (url:scheme url) |
113 |
((http) (pathy 'http #f |
((http) (pathy 'http #f url)) |
114 |
(url:host url) |
((ftp) (pathy 'ftp (url:user url) url)) |
115 |
(url:port url) |
((mailto) (format #f "mailto:~A" (url:address url))) |
|
(url:path url))) |
|
|
((ftp) (pathy 'ftp |
|
|
(url:user url) |
|
|
(url:host url) |
|
|
(url:port url) |
|
|
(url:path url))) |
|
|
((mailto) (string-append "mailto:" (url:address url))) |
|
116 |
((unknown) (url:unknown url)))) |
((unknown) (url:unknown url)))) |
117 |
|
|
118 |
|
|
124 |
;; important for code that frequently gets restarted)? |
;; important for code that frequently gets restarted)? |
125 |
|
|
126 |
(define-public (url:decode str) |
(define-public (url:decode str) |
127 |
(regexp-substitute/global #f "\\+|%([0-9A-Fa-f][0-9A-Fa-f])" str |
(regexp-substitute/global |
128 |
'pre |
#f "\\+|%([0-9A-Fa-f][0-9A-Fa-f])" str |
129 |
(lambda (m) |
'pre |
130 |
(cond ((string=? "+" (match:substring m 0)) " ") |
(lambda (m) |
131 |
(else (integer->char |
(cond ((string=? "+" (match:substring m 0)) " ") |
132 |
(string->number |
(else (integer->char |
133 |
(match:substring m 1) |
(string->number |
134 |
16))))) |
(match:substring m 1) |
135 |
'post)) |
16))))) |
136 |
|
'post)) |
137 |
|
|
138 |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
139 |
;; (url-encode STR) |
;; (url-encode STR) |