Index: henrietta.scm
===================================================================
--- henrietta.scm	(revision 31417)
+++ henrietta.scm	(working copy)
@@ -1,6 +1,6 @@
 ;;;; henrietta.scm - Server program (CGI) for serving eggs from a repository over HTTP
 ;
-; Copyright (c) 2008-2010, The CHICKEN Team
+; Copyright (c) 2008-2014, The CHICKEN Team
 ; All rights reserved.
 ;
 ; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
@@ -31,27 +31,23 @@
 
 ; URL arguments:
 ;
-; version=<version>
+; release=<major-chicken-version>
 ; name=<name>
+; version=<version>
 ; tests
 ; list
 ; listversions
 
 
-(require-library setup-download regex extras utils ports srfi-1 posix)
-
-
 (module main ()
 
-  (import scheme chicken regex extras utils ports srfi-1 posix)
-  (import setup-api setup-download)
+  (import scheme chicken)
+  (use regex extras utils ports srfi-1 posix files
+       data-structures (only setup-api version>=?))
 
-  (define *default-transport* 'svn)
   (define *default-location* (current-directory))
-  (define *username* #f)
-  (define *password* #f)
+  (define *default-chicken-release* "4")
   (define *tests* #f)
-  (define *mode* 'default)
   (define *query-string* #f)
   (define *remote-addr* #f)
 
@@ -60,7 +56,6 @@
 
   (define (fail msg . args)
     (pp `(error ,msg ,@args))
-    (cleanup)
     (exit 0))
 
   (define-syntax hairy
@@ -71,11 +66,6 @@
 		 ((condition-property-accessor 'exn 'arguments) ex))
 	 body ...))))
 
-  (define (cleanup)
-    (and-let* ((tmpdir (temporary-directory)))
-      (fprintf (current-error-port) "removing temporary directory `~a'~%" tmpdir)
-      (remove-directory tmpdir)))
-
   (define test-file?
     (let ((rx (regexp "(\\./)?tests(/.*)?")))
       (lambda (path) (string-match rx path))))
@@ -85,20 +75,41 @@
         (any (cut equal? #\/ <>)
              (string->list name))))
 
-  (define (retrieve name version)
-    (when (illegal-name? name)
-      (fail "illegal egg name" name))
+  (define (existing-version egg version vs)
+    (if version
+        (if (member version vs)
+            version
+            (error "version not found" egg version) )
+        (let ((vs (sort vs version>=?)))
+          (and (pair? vs)
+               (car vs) ) ) ) )
+
+  (define (release-base-dir release)
+    (when (not (equal? release (number->string (string->number release))))
+      (fail "illegal CHICKEN major release number"))
+    (make-pathname *default-location* release))
+
+  (define (egg-base-dir release egg-name)
+    (when (illegal-name? egg-name)
+      (fail "illegal egg name" egg-name))
+    (make-pathname (release-base-dir release) egg-name))
+  
+  (define (locate-egg release egg-name egg-version)
+    (let* ((egg-dir (egg-base-dir release egg-name))
+           (version (and (file-exists? egg-dir) (directory? egg-dir)
+                         (existing-version egg-name egg-version
+                                           (directory egg-dir)) ) )
+           (version-dir (and version (make-pathname egg-dir version)) ) )
+      (cond ((or (not version-dir)
+                 (not (file-exists? version-dir))
+                 (not (directory? version-dir)))
+             (values #f ""))
+            (else
+             (values version-dir version)))))
+
+  (define (retrieve release name version)
     (let-values (((dir ver)
-		  (hairy
-		   (retrieve-extension 
-		    name *default-transport* *default-location*
-		    version: version 
-		    quiet: #t 
-		    destination: #f
-		    tests: *tests*
-		    mode: *mode*
-		    username: *username* 
-		    password: *password*))))
+		  (hairy (locate-egg release name version))))
       (unless dir 
 	(fail "no such extension or version" name version))
       (let walk ((dir dir) (prefix "."))
@@ -117,30 +128,14 @@
 			(display (read-all ff)))))))
 	   files)))))
 
-  (define (listing)
-    (let ((dir (hairy
-		 (list-extensions
-		  *default-transport* *default-location*
-		  quiet: #t 
-		  username: *username* 
-		  password: *password*))))
-      (if dir 
-	  (display dir)
-	  (fail "unable to retrieve extension-list"))))
+  (define (egg-listing release)
+    (hairy (for-each print (directory (release-base-dir release)))))
 
-  (define (version-listing name)
-    (let ((dir (hairy
-		 (list-extension-versions
-		  name
-		  *default-transport* *default-location*
-		  username: *username* 
-		  password: *password*))))
-      (if dir 
-	  (display dir)
-	  (fail "unable to retrieve version-list for extension" name))))
+  (define (version-listing release egg-name)
+    (hairy (for-each print (directory (egg-base-dir release egg-name)))))
 
   (define query-string-rx (regexp "[^?]+\\?(.+)"))
-  (define query-arg-rx (regexp "^&?(\\w+)=([^&;]+)"))
+  (define query-arg-rx (regexp "^[&;]?(\\w+)=([^&;]+)"))
 
   (define (service)
     (let ((qs (or *query-string* (get-environment-variable "QUERY_STRING")))
@@ -151,6 +146,7 @@
 	(error "no QUERY_STRING set"))
       (let ((m (string-match query-string-rx qs))
 	    (egg #f)
+            (chicken-release *default-chicken-release*)
 	    (version #f))
 	(let loop ((qs (if m (cadr m) qs)))
 	  (let* ((m (string-search-positions query-arg-rx qs))
@@ -158,13 +154,15 @@
 		 (rest (and m (substring qs (cadar m)))))
 	    (cond ((not m)
 		   (headers)		; from here on use `fail'
-		   (cond (egg
-			  (retrieve egg version)
-			  (cleanup) )
-			 (else (fail "no extension name specified") ) ))
+		   (if (and egg chicken-release)
+                       (retrieve chicken-release egg version)
+                       (fail "you must specify extension name and CHICKEN release")  ))
 		  ((string=? ms "version")
 		   (set! version (apply substring qs (caddr m)))
 		   (loop rest))
+		  ((string=? ms "release")
+		   (set! chicken-release (apply substring qs (caddr m)))
+		   (loop rest))
 		  ((string=? ms "name")
 		   (set! egg (apply substring qs (caddr m)))
 		   (loop rest))
@@ -173,17 +171,15 @@
 		   (loop rest))
 		  ((string=? ms "list")
 		   (headers)
-		   (listing)
-		   (exit))
+                   (if chicken-release
+                       (egg-listing chicken-release)
+                       (fail "you must specify CHICKEN release") ) )
 		  ((string=? ms "listversions")
 		   (headers)
-		   (if egg
-		       (version-listing egg)
-		       (fail "`name' must be given first"))
+		   (if (and egg chicken-release)
+		       (version-listing chicken-release egg)
+		       (fail "you must specify extension name and CHICKEN release"))
 		   (exit))
-		  ((string=? ms "mode")
-		   (set! *mode* (string->symbol (apply substring qs (caddr m))))
-		   (loop rest))
 		  (else
 		   (warning "unrecognized query option" ms)
 		   (loop rest))))))))
@@ -196,9 +192,6 @@
        -query QUERYSTRING       supply query-string on the command-line
        -remote REMOTEADDR       supply remote address on the command-line
   -l   -location LOCATION       install from given location (default: current directory)
-  -t   -transport TRANSPORT     use given transport instead of default (#{*default-transport*})
-       -username USER           set username for transports that require this
-       -password PASS           set password for transports that require this
 
   QUERYSTRING and REMOTEADDR default to the value of the `QUERY_STRING' 
 and `REMOTE_ADDR' environment variables, respectively.
@@ -222,18 +215,6 @@
 		   (unless (pair? (cdr args)) (usage 1))
 		   (set! *default-location* (cadr args))
 		   (loop (cddr args)))
-		  ((or (string=? arg "-t") (string=? arg "-transport"))
-		   (unless (pair? (cdr args)) (usage 1))
-		   (set! *default-transport* (string->symbol (cadr args)))
-		   (loop (cddr args)))
-		  ((string=? "-username" arg)
-		   (unless (pair? (cdr args)) (usage 1))
-		   (set! *username* (cadr args))
-		   (loop (cddr args)))
-		  ((string=? "-password" arg)
-		   (unless (pair? (cdr args)) (usage 1))
-		   (set! *password* (cadr args))
-		   (loop (cddr args)))
 		  ((string=? "-query" arg)
 		   (unless (pair? (cdr args)) (usage 1))
 		   (set! *query-string* (cadr args))