diff options
| -rwxr-xr-x | env | 8 | ||||
| -rwxr-xr-x | src/tekuti | 297 | ||||
| -rw-r--r-- | tekuti/popen.scm | 215 | ||||
| -rw-r--r-- | tekuti/url.scm | 171 |
4 files changed, 672 insertions, 19 deletions
@@ -0,0 +1,8 @@ +#!/bin/sh + +this_dir=$(cd $(dirname $0) && pwd) +GUILE_LOAD_PATH=$this_dir/$pkg:$GUILE_LOAD_PATH + +export GUILE_LOAD_PATH + +exec "$@" @@ -1,6 +1,6 @@ #! /bin/bash # -*- scheme -*- -exec guile $GUILE_FLAGS -s $0 "$@" +exec guile $GUILE_FLAGS -l $0 -e main "$@" !# ;; Tekuti ;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com> @@ -29,20 +29,80 @@ exec guile $GUILE_FLAGS -s $0 "$@" ;;; Code: -(use-modules (ice-9 rdelim)) +(use-modules (ice-9 rdelim) + (ice-9 popen) + (srfi srfi-1) + (sxml simple) + (tekuti url) + (match-bind) + (sxml transform)) (debug-enable 'backtrace) +(define (expanduser path) + (let ((parts (string-split path #\/))) + (if (eqv? (string-ref (car parts) 0) #\~) + (let ((user (if (= (string-length (car parts)) 1) + (cuserid) + (substring (car parts) 1)))) + (string-join (cons (passwd:dir (getpwnam user)) (cdr parts)) "/")) + path))) + (define *host* "127.0.0.1") (define *port* 8081) (define *backlog* 5) - -(define *socket* (socket PF_INET SOCK_STREAM 0)) -(bind *socket* AF_INET (inet-aton *host*) *port*) -(listen *socket* *backlog*) +(define *git-dir* (expanduser "~/blog.git")) +(define *git* "git") +(define *public-url-base* "/") +(define *private-url-base* "/blog/") +(define *debug* #t) (define (dbg fmt . args) (apply format (current-error-port) fmt args)) +(define-macro (unwind-protect form . cleanups) + `(dynamic-wind (lambda () #t) + (lambda () ,form) + (lambda () ,@cleanups))) + +(define-macro (with-pipe var make-pipe . body) + `(let ((,var ,make-pipe)) + (unwind-protect + (begin ,@body) + (let ((ret (close-pipe ,var))) + (if (not (eq? (status:exit-val ret) 0)) + (throw 'system-error ,var ret)))))) + +(define (git . args) + (with-pipe + pipe (apply open-pipe* OPEN_READ *git* "--bare" args) + (read-delimited "" pipe))) + +;; true badness +(define (git/input input . args) + (let* ((template "/tmp/tekutiXXXXXX") + (tmp (mkstemp! template))) + (display input tmp) + (close tmp) + (unwind-protect + (with-pipe + pipe (open-pipe* OPEN_BOTH "/bin/sh" "-c" + (string-join `(,*git* "--bare" ,@args "<" ,template) " ")) + (read-delimited "" pipe)) + (delete-file template)))) + +(define (is-dir? path) + (catch 'system-error + (lambda () (eq? (stat:type (stat path)) 'directory)) + (lambda args #f))) + +(define (ensure-git-repo) + (if (not (is-dir? *git-dir*)) + (begin + (mkdir *git-dir*) + (chdir *git-dir*) + (git "init")) + (chdir *git-dir*))) + (define (strip-headers socket) (define (read-line*) (let ((line (read-line socket))) @@ -55,33 +115,232 @@ exec guile $GUILE_FLAGS -s $0 "$@" (reverse (map cons keys values)) (lp (cons k keys) (cons (read-line*) values)))))) -(define (output-headers headers) +(define (output-headers headers port) (for-each (lambda (k v) - (format #t "~a\n~a\n" k v)) + (format port "~a\n~a\n" k v)) (map car headers) (map cdr headers)) - (display "end\n")) + (display "end\n" port)) + +(define-macro (let-headers headers bindings . body) + (let ((headers-var (gensym))) + `(let ((,headers-var ,headers)) + (let (,@(map (lambda (binding) + `(,(car binding) + (or (assoc-ref ,headers-var ,(cadr binding)) + (error "Missing header:" ,(cadr binding))))) + bindings)) + ,@body)))) + +(define (page-debug headers) + `(html (head (title "hello")) + (body (p "hello world!") + (table + (tr (th "header") (th "value")) + ,@(map (lambda (pair) + `(tr (td ,(car pair)) (td ,(cdr pair)))) + headers))))) + +(define (visible-error . html-body) + (throw 'visible-error 404 html-body)) + +(define (page-not-found path) + (throw 'html-error 404 path)) + +(define (url-path-split path) + (filter (lambda (x) (not (string-null? x))) + (map url:decode (string-split path #\/)))) + +(define-macro (url-path-case method path . clauses) + (define (optional-argument arg) + (let ((len (string-length arg))) + (and (eqv? (string-ref arg (1- len)) #\?) + (substring arg 0 (1- len))))) + (let ((method-sym (gensym)) (path-parts (gensym))) + (define (process-clauses) + (map (lambda (clause) + (let ((pattern (car clause)) (body (cdr clause))) + (cond + ((eq? pattern 'else) + clause) + (else + (let* ((method-match (car pattern)) + (parts-match (map symbol->string (cdr pattern))) + (nargs (length parts-match)) + (opt (or (find-tail optional-argument parts-match) '())) + (nopt (length opt)) + (nreq (- nargs nopt))) + (cond + ((null? opt) + `((and (eq? ,method-sym ',method-match) + (equal? ,path-parts ',parts-match)) + ,@body)) + (else + `((and (eq? ,method-sym ',method-match) + (equal? (list-head ,path-parts ,nreq) + ',(list-head parts-match nreq)) + (< (length ,path-parts) ,nargs)) + (apply + (lambda ,(map string->symbol (map optional-argument opt)) + ,@body) + (let ((tail (list-tail ,path-parts ,nreq))) + (append tail (make-list (- ,nopt (length tail)) #f)))))))))))) + clauses)) + `(let ((,method-sym (string->symbol ,method)) + (,path-parts (url-path-split ,path))) + (cond ,@(process-clauses))))) + +(define-macro (url-relative-path-case method path . clauses) + (let ((infix (map string->symbol (url-path-split *private-url-base*)))) + (define (munge-clause clause) + (cond + ((eq? (car clause) 'else) clause) + (else + (let ((method (caar clause)) + (parts (cdar clause)) + (body (cdr clause))) + `((,method ,@infix ,@parts) ,@body))))) + `(url-path-case ,method ,path + ,@(map munge-clause clauses)))) + +(define (unimplemented . args) + (apply throw 'unimplemented args)) + +(use-modules (scheme session)) +(use-modules (match-bind)) + +;;(putenv "GIT_DIR=/home/wingo/blog.git") +(define-macro (match-lines string pattern bindings expr) + (let ((line (gensym)) (seed (gensym))) + `(fold + (lambda (,line ,seed) + (match-bind ,pattern ,line ,bindings + (cons ,expr ,seed) + ,seed)) + '() (string-split ,string #\newline)))) + +(define (git-ls-tree treeish path) + (match-lines (git "ls-tree" treeish (or path ".")) + "^(.+) (.+) (.+)\t(.+)$" (_ mode type object name) + (list mode type object name))) + +(define (git-ls-subdirs treeish path) + (match-lines (git "ls-tree" treeish (or path ".")) + "^(.+) tree (.+)\t(.+)$" (_ mode object name) + (cons name object))) + +(define (dsu-sort list key less) + (map cdr + (stable-sort (map (lambda (x) (cons (key x) x)) list) + (lambda (x y) (less (car x) (car y)))))) + +(define (all-published-posts) + (dsu-sort + (filter post-timestamp (map cdr (git-ls-subdirs "master" #f))) + post-timestamp + <)) + +(define (comment-metadata sha1) + (match-lines (git "cat-file" "blob" (string-append sha1 ":" "metadata")) + "^([^: ]+): +(.*)$" (_ k v) + (cons (string->symbol k) v))) + +(define (comment-timestamp sha1) + (and=> (assq-ref (comment-metadata sha1) 'timestamp) + string->number)) + +(define (post-comments sha1) + (dsu-sort + (map cdr (git-ls-subdirs sha1 "comments/")) + comment-timestamp + <)) + +(define (build-comment-skeleton comments) + (fold (lambda (sha1 parent) + (string-trim-both + (if parent + (git/input "comment" "commit-tree" sha1) + (git/input "comment" "commit-tree" "-p" parent sha1)))) + #f + comments)) + +(post-comments "085138c227a15c1462138958868f8ef45741e5c5") +(git/input "comment" "commit-tree" "fae8f17277f74fe1e0710fd3be6ebb7879b65969") +(all-published-posts) +(string-trim-both "aadabe54f0a4d141657f208645955a2c85af4e0b +") + + +(post-metadata "9a83feef2c2304797ad295043d1f33d8e2dae52d") + +(define (reindex-posts) + +(define (reindex) + (reindex-posts) + (reindex-categories)) (define (handle-request headers post-data) - (output-headers '(("Status" . "200 OK") - ("Content-Type" . "text/html"))) - (display "<html><head><title>hello</title><body><p>hello world</p></body>")) + (let-headers + headers ((method "method") (path "url")) + (url-relative-path-case + method path + ((POST admin new-post) + (unimplemented 'new-post)) + ((POST admin modify-post) + (unimplemented 'modify-post)) + ((POST admin new-comment) + (unimplemented 'new-comment)) + ((POST admin delete-comment) + (unimplemented 'delete-comment)) + ((POST admin delete-post) + (unimplemented 'delete-post)) + ((GET) + (unimplemented 'index)) + ((GET archives year? month? day? post?) + (unimplemented 'archives)) + ((GET debug) + (page-debug headers)) + ((POST search) + (unimplemented 'search)) + (else (page-not-found path))))) + +(define xhtml-doctype + (string-append + "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " + "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n")) (define (connection-received socket sockaddr) (let ((headers (strip-headers socket)) (post-data "")) ;; blocks: (read-delimited "" socket))) (dbg "~a" headers) - (with-output-to-port socket - (lambda () - (handle-request headers post-data))) + (catch #t + (lambda () + (let ((sxml (handle-request headers post-data))) + (output-headers '(("Status" . "200 OK") + ("Content-Type" . "text/html")) + socket) + (display xhtml-doctype socket) + (sxml->xml sxml socket))) + (lambda args + (output-headers '(("Status" . "500 Internal Server Error") + ("Content-Type" . "text/plain")) + socket) + (write args socket))) + (close-port socket))) -(define (event-loop) +(define (event-loop socket) (pk 'listening) - (let ((pair (accept *socket*))) + (bind socket AF_INET (inet-aton *host*) *port*) + (listen socket *backlog*) + (let lp ((pair (accept socket))) (pk pair) (connection-received (car pair) (cdr pair)) (pk 'done) - (event-loop))) + (lp (accept socket)))) -(event-loop) +(define (main) + (ensure-git-repo) + (event-loop (socket PF_INET SOCK_STREAM 0))) + +(main) diff --git a/tekuti/popen.scm b/tekuti/popen.scm new file mode 100644 index 0000000..25eec6d --- /dev/null +++ b/tekuti/popen.scm @@ -0,0 +1,215 @@ +;; popen emulation, for non-stdio based ports. + +;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (tekuti popen) + :export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe + open-output-pipe open-input-output-pipe)) + +(define (make-rw-port read-port write-port) + (make-soft-port + (vector + (lambda (c) (write-char c write-port)) + (lambda (s) (display s write-port)) + (lambda () (force-output write-port)) + (lambda () (read-char read-port)) + (lambda () (close-port read-port) (close-port write-port))) + "r+")) + +;; a guardian to ensure the cleanup is done correctly when +;; an open pipe is gc'd or a close-port is used. +(define pipe-guardian (make-guardian)) + +;; a weak hash-table to store the process ids. +(define port/pid-table (make-weak-key-hash-table 31)) + +(define (ensure-fdes port mode) + (or (false-if-exception (fileno port)) + (open-fdes *null-device* mode))) + +;; run a process connected to an input, an output or an +;; input/output port +;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH +;; returns port/pid pair. +(define (open-process mode prog . args) + (let* ((reading (or (equal? mode OPEN_READ) + (equal? mode OPEN_BOTH))) + (writing (or (equal? mode OPEN_WRITE) + (equal? mode OPEN_BOTH))) + (c2p (if reading (pipe) #f)) ; child to parent + (p2c (if writing (pipe) #f))) ; parent to child + + (if c2p (setvbuf (cdr c2p) _IONBF)) + (if p2c (setvbuf (cdr p2c) _IONBF)) + (let ((pid (primitive-fork))) + (cond ((= pid 0) + ;; child + (set-batch-mode?! #t) + + ;; select the three file descriptors to be used as + ;; standard descriptors 0, 1, 2 for the new + ;; process. They are pipes to/from the parent or taken + ;; from the current Scheme input/output/error ports if + ;; possible. + + (let ((input-fdes (if writing + (fileno (car p2c)) + (ensure-fdes (current-input-port) + O_RDONLY))) + (output-fdes (if reading + (fileno (cdr c2p)) + (ensure-fdes (current-output-port) + O_WRONLY))) + (error-fdes (ensure-fdes (current-error-port) + O_WRONLY))) + + ;; close all file descriptors in ports inherited from + ;; the parent except for the three selected above. + ;; this is to avoid causing problems for other pipes in + ;; the parent. + + ;; use low-level system calls, not close-port or the + ;; scsh routines, to avoid side-effects such as + ;; flushing port buffers or evicting ports. + + (port-for-each (lambda (pt-entry) + (false-if-exception + (let ((pt-fileno (fileno pt-entry))) + (if (not (or (= pt-fileno input-fdes) + (= pt-fileno output-fdes) + (= pt-fileno error-fdes))) + (close-fdes pt-fileno)))))) + + ;; Copy the three selected descriptors to the standard + ;; descriptors 0, 1, 2, if not already there + + (cond ((not (= input-fdes 0)) + (if (= output-fdes 0) + (set! output-fdes (dup->fdes 0))) + (if (= error-fdes 0) + (set! error-fdes (dup->fdes 0))) + (dup2 input-fdes 0) + ;; it's possible input-fdes is error-fdes + (if (not (= input-fdes error-fdes)) + (close-fdes input-fdes)))) + + (cond ((not (= output-fdes 1)) + (if (= error-fdes 1) + (set! error-fdes (dup->fdes 1))) + (dup2 output-fdes 1) + ;; it's possible output-fdes is error-fdes + (if (not (= output-fdes error-fdes)) + (close-fdes output-fdes)))) + + (cond ((not (= error-fdes 2)) + (dup2 error-fdes 2) + (close-fdes error-fdes))) + + (apply execlp prog prog args))) + + (else + ;; parent + (if c2p (close-port (cdr c2p))) + (if p2c (close-port (car p2c))) + (cons (cond ((not writing) (car c2p)) + ((not reading) (cdr p2c)) + (else (make-rw-port (car c2p) + (cdr p2c)))) + pid)))))) + +(define (open-pipe* mode command . args) + "Executes the program @var{command} with optional arguments +@var{args} (all strings) in a subprocess. +A port to the process (based on pipes) is created and returned. +@var{modes} specifies whether an input, an output or an input-output +port to the process is created: it should be the value of +@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}." + (let* ((port/pid (apply open-process mode command args)) + (port (car port/pid))) + (pipe-guardian port) + (hashq-set! port/pid-table port (cdr port/pid)) + port)) + +(define (open-pipe command mode) + "Executes the shell command @var{command} (a string) in a subprocess. +A port to the process (based on pipes) is created and returned. +@var{modes} specifies whether an input, an output or an input-output +port to the process is created: it should be the value of +@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}." + (open-pipe* mode "/bin/sh" "-c" command)) + +(define (fetch-pid port) + (let ((pid (hashq-ref port/pid-table port))) + (hashq-remove! port/pid-table port) + pid)) + +(define (close-process port/pid) + (close-port (car port/pid)) + (cdr (waitpid (cdr port/pid)))) + +;; for the background cleanup handler: just clean up without reporting +;; errors. also avoids blocking the process: if the child isn't ready +;; to be collected, puts it back into the guardian's live list so it +;; can be tried again the next time the cleanup runs. +(define (close-process-quietly port/pid) + (catch 'system-error + (lambda () + (close-port (car port/pid))) + (lambda args #f)) + (catch 'system-error + (lambda () + (let ((pid/status (waitpid (cdr port/pid) WNOHANG))) + (cond ((= (car pid/status) 0) + ;; not ready for collection + (pipe-guardian (car port/pid)) + (hashq-set! port/pid-table + (car port/pid) (cdr port/pid)))))) + (lambda args #f))) + +(define (close-pipe p) + "Closes the pipe created by @code{open-pipe}, then waits for the process +to terminate and returns its status value, @xref{Processes, waitpid}, for +information on how to interpret this value." + (let ((pid (fetch-pid p))) + (if (not pid) + (error "close-pipe: pipe not in table")) + (close-process (cons p pid)))) + +(define reap-pipes + (lambda () + (let loop ((p (pipe-guardian))) + (cond (p + ;; maybe removed already by close-pipe. + (let ((pid (fetch-pid p))) + (if pid + (close-process-quietly (cons p pid)))) + (loop (pipe-guardian))))))) + +(add-hook! after-gc-hook reap-pipes) + +(define (open-input-pipe command) + "Equivalent to @code{open-pipe} with mode @code{OPEN_READ}" + (open-pipe command OPEN_READ)) + +(define (open-output-pipe command) + "Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}" + (open-pipe command OPEN_WRITE)) + +(define (open-input-output-pipe command) + "Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}" + (open-pipe command OPEN_BOTH)) diff --git a/tekuti/url.scm b/tekuti/url.scm new file mode 100644 index 0000000..e55fa10 --- /dev/null +++ b/tekuti/url.scm @@ -0,0 +1,171 @@ +;;; www/url.scm --- URL manipulation tools + +;; Copyright (C) 1997,2001,2002 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; + +;;; Commentary: + +;; This module exports the following procedures: +;; (url:scheme url) +;; (url:address url) +;; (url:unknown url) +;; (url:user url) +;; (url:host url) +;; (url:port url) +;; (url:path url) +;; (url:make scheme . args) +;; (url:make-http host port path) +;; (url:make-ftp user host port path) +;; (url:make-mailto address) +;; (url:parse url) +;; (url:unparse url) +;; (url:decode str) +;; (url:encode str reserved-chars) + +;;; Code: + + +;; TODO: +;; * support `user:password@' strings where appropriate in URLs. +;; * make URL parsing smarter. This is good for most TCP/IP-based +;; URL schemes, but parsing is actually specific to each URL scheme. +;; * fill out url:encode, include facilities for URL-scheme-specific +;; encoding methods (e.g. a url-scheme-reserved-char-alist) + +(define-module (tekuti url) + #:use-module (ice-9 regex)) + +;; `url:scheme' is an unfortunate term, but it is the technical +;; name for that portion of the URL according to RFC 1738. Sigh. + +(define-public (url:scheme url) (vector-ref url 0)) +(define-public (url:address url) (vector-ref url 1)) +(define-public (url:unknown url) (vector-ref url 1)) +(define-public (url:user url) (vector-ref url 1)) +(define-public (url:host url) (vector-ref url 2)) +(define-public (url:port url) (vector-ref url 3)) +(define-public (url:path url) (vector-ref url 4)) + +(define-public (url:make scheme . args) + (apply vector scheme args)) +(define-public (url:make-http host port path) + (vector 'http #f host port path)) +(define-public (url:make-ftp user host port path) + (vector 'ftp user host port path)) +(define-public (url:make-mailto address) + (vector 'mailto address)) + +(define http-regexp (make-regexp "^http://([^:/]+)(:([0-9]+))?(/(.*))?$")) +(define ftp-regexp + (make-regexp "^ftp://(([^@:/]+)@)?([^:/]+)(:([0-9]+))?(/(.*))?$")) +(define mailto-regexp (make-regexp "^mailto:(.*)$")) + +(define-public (url:parse url) + (cond + ((regexp-exec http-regexp url) + => (lambda (m) + (url:make-http (match:substring m 1) + (cond ((match:substring m 3) => string->number) + (else #f)) + (match:substring m 5)))) + + ((regexp-exec ftp-regexp url) + => (lambda (m) + (url:make-ftp (match:substring m 2) + (match:substring m 3) + (cond ((match:substring m 5) => string->number) + (else #f)) + (match:substring m 7)))) + + ((regexp-exec mailto-regexp url) + => (lambda (m) + (url:make-mailto (match:substring m 1)))) + + (else + (url:make 'unknown url)))) + + +(define-public (url:unparse url) + (define (pathy scheme username url) ; username not used! + (format #f "~A://~A~A~A" + scheme + (url:host url) + (cond ((url:port url) => (lambda (port) (format #f ":~A" port))) + (else "")) + (cond ((url:path url) => (lambda (path) (format #f "/~A" path))) + (else "")))) + (case (url:scheme url) + ((http) (pathy 'http #f url)) + ((ftp) (pathy 'ftp (url:user url) url)) + ((mailto) (format #f "mailto:~A" (url:address url))) + ((unknown) (url:unknown url)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (url-decode STR) +;; Turn + into space, and hex-encoded %XX strings into their +;; eight-bit characters. Is a regexp faster than character +;; scanning? Does it incur more overhead (which may be more +;; important for code that frequently gets restarted)? + +(define-public (url:decode str) + (regexp-substitute/global + #f "\\+|%([0-9A-Fa-f][0-9A-Fa-f])" str + 'pre + (lambda (m) + (cond ((string=? "+" (match:substring m 0)) " ") + (else (integer->char + (string->number + (match:substring m 1) + 16))))) + 'post)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; (url-encode STR) +;; The inverse of url-decode. Can't be done easily with +;; a regexp: we would have to construct a regular expression +;; like "[\277-\377]", for example, and Guile strings don't +;; let you interpolate character literals. Pity. +;; URL-encode any characters in STR that are not safe: these +;; include any character not in the SAFE-CHARS list and any +;; character that *is* in the RESERVED-CHARS list argument. + +(define-public (url:encode str reserved-chars) + (with-output-to-string + (lambda () + (for-each (lambda (ch) + (if (and (safe-char? ch) + (not (memv ch reserved-chars))) + (display ch) + (begin + (display #\%) + (display (number->string (char->integer ch) 16))))) + (string->list str))))) + +(define safe-chars + '(#\$ #\- #\_ #\. #\+ #\! #\* #\' #\( #\) #\, #\; #\/ #\? #\: #\@ #\& #\=)) + +(define (safe-char? ch) + ;; ``Thus, only alphanumerics, the special characters "$-_.+!*'(),", and + ;; reserved characters used for their reserved purposes may be used + ;; unencoded within a URL.'' RFC 1738, #2.2. + (or (char-alphabetic? ch) + (char-numeric? ch) + (memv ch safe-chars))) + +;;; www/url.scm ends here |