From 04ee329b4b0e06ad2a58803cfaadd234cd7b1244 Mon Sep 17 00:00:00 2001
From: Andy Wingo
Date: Sat, 9 Feb 2008 21:37:57 +0100
Subject: further hacking

---
 env              |   8 ++
 src/tekuti       | 297 +++++++++++++++++++++++++++++++++++++++++++++++++++----
 tekuti/popen.scm | 215 ++++++++++++++++++++++++++++++++++++++++
 tekuti/url.scm   | 171 ++++++++++++++++++++++++++++++++
 4 files changed, 672 insertions(+), 19 deletions(-)
 create mode 100755 env
 create mode 100644 tekuti/popen.scm
 create mode 100644 tekuti/url.scm

diff --git a/env b/env
new file mode 100755
index 0000000..b7edc9a
--- /dev/null
+++ b/env
@@ -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 "$@"
diff --git a/src/tekuti b/src/tekuti
index 4b7409a..eb216bb 100755
--- a/src/tekuti
+++ b/src/tekuti
@@ -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
-- 
cgit v1.2.3-54-g00ecf