source: project/release/5/henrietta/tags/1.2/henrietta.scm @ 37457

;;;; henrietta.scm - Server program (CGI) for serving eggs from a repository over HTTP
;
; 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
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer. 
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution. 
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission. 
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


; used environment variables:
;
; QUERY_STRING
; REMOTE_ADDR (optional)

; URL arguments:
;
; release=<major-chicken-version>
; name=<name>
; version=<version>
; tests
; list
; listversions


(module main ()

  (import scheme)
  (cond-expand
   (chicken-4
    (import chicken)
    (use regex extras utils ports srfi-1 posix files
         data-structures (only setup-api version>=?)))
   (chicken-5
    (import (chicken base))
    (import (chicken condition))
    (import (chicken file))
    (import (chicken file posix))
    (import (chicken format))
    (import (chicken io))
    (import (chicken irregex))
    (import (chicken pathname))
    (import (chicken pretty-print))
    (import (chicken process-context))
    (import (chicken sort))
    (import (chicken string))
    (import regex)
    (import (srfi 1))

   ;; From setup-api.scm
   (define (version>=? v1 v2)
     (define (version->list v)
       (map (lambda (x) (or (string->number x) x))
            (irregex-split "[-\\._]" (->string v))))
     (let loop ((p1 (version->list v1))
                (p2 (version->list v2)))
       (cond ((null? p1) (null? p2))
             ((null? p2))
             ((number? (car p1))
              (and (number? (car p2))
                   (or (> (car p1) (car p2))
                       (and (= (car p1) (car p2))
                            (loop (cdr p1) (cdr p2))))))
             ((number? (car p2)))
             ((string>? (car p1) (car p2)))
             (else
              (and (string=? (car p1) (car p2))
                   (loop (cdr p1) (cdr p2)))))))))

  (define *default-location* (current-directory))
  (define *tests* #f)
  (define *query-string* #f)
  (define *remote-addr* #f)

  ;; CHICKEN 4 was the first version to have henrietta to serve eggs.
  ;; CHICKEN 5 breaks compatibility with CHICKEN 4, thus it needs eggs
  ;; to be served from a different location.
  ;; *default-chicken-release* is used to determine the subdirectory
  ;; under *default-locations* where eggs can be found.  It is used
  ;; when the `release' variable is not given in the HTTP request.  We
  ;; use 4 because CHICKEN 4's chicken-install does not set `release'
  ;; in requests.
  (define *default-chicken-release* "4")

  
  (define (headers)
    (print "Connection: close\r\nContent-type: text/plain\r\n\r\n"))

  (define (fail msg . args)
    (pp `(error ,msg ,@args))
    (exit 0))

  (define-syntax hairy
    (syntax-rules ()
      ((_ body ...)
       (handle-exceptions ex 
           (fail ((condition-property-accessor 'exn 'message) ex)
                 ((condition-property-accessor 'exn 'arguments) ex))
         body ...))))

  (define test-file?
    (let ((rx (regexp "(\\./)?tests(/.*)?")))
      (lambda (path) (string-match rx path))))

  (define illegal-name?
    (let ((legal-chars
           (string->list
            "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ+-_")))
      (lambda (name)
        (not (every (cut member <> legal-chars)
                    (string->list 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 (locate-egg release name version))))
      (unless dir 
        (fail "no such extension or version" name version))
      (let walk ((dir dir) (prefix "."))
        (let ((files (directory dir)))
          (for-each
           (lambda (f)
             (when (or *tests* (not (test-file? f)))
               (let ((ff (string-append dir "/" f))
                     (pf (string-append prefix "/" f)))
                 (cond ((directory? ff)
                        (print "\n#|-------------------- " ver " |# \"" pf "/\" 0")
                        (walk ff pf))
                       (else
                        (print "\n#|-------------------- " ver " |# \"" pf "\" " 
                               (file-size ff))
                        (display (call-with-input-file ff (cut read-string #f <>))))))))
           files)))))

  (define (egg-listing release)
    (hairy (for-each print (directory (release-base-dir release)))))

  (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 (service)
    (let ((qs (or *query-string* (get-environment-variable "QUERY_STRING")))
          (ra (or *remote-addr* (get-environment-variable "REMOTE_ADDR"))))
      (fprintf (current-error-port) "~%========== serving request from ~a: ~s~%"
               (or ra "<unknown>") qs)
      (unless qs
        (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))
                 (ms (and m (apply substring qs (cadr m))))
                 (rest (and m (substring qs (cadar m)))))
            (cond ((not m)
                   (headers)            ; from here on use `fail'
                   (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))
                  ((string=? ms "tests")
                   (set! *tests* #t)
                   (loop rest))
                  ((string=? ms "list")
                   (headers)
                   (if chicken-release
                       (egg-listing chicken-release)
                       (fail "you must specify CHICKEN release") ) )
                  ((string=? ms "listversions")
                   (headers)
                   (if (and egg chicken-release)
                       (version-listing chicken-release egg)
                       (fail "you must specify extension name and CHICKEN release"))
                   (exit))
                  (else
                   (warning "unrecognized query option" ms)
                   (loop rest))))))))
  
  (define (usage code)
    (print #<#EOF
usage: henrietta [OPTION ...]

  -h   -help                    show this message
       -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)

  QUERYSTRING and REMOTEADDR default to the value of the `QUERY_STRING' 
and `REMOTE_ADDR' environment variables, respectively.

  LOCATION should point to the base directory under which
subdirectories named after the CHICKEN major version can be found.

EOF
);|
    (exit code))

  (define *short-options* '(#\h #\l #\t))

  (define (main args)
    (let loop ((args args))
      (if (null? args)
          (service)
          (let ((arg (car args)))
            (cond ((or (string=? arg "-help") 
                       (string=? arg "-h")
                       (string=? arg "--help"))
                   (usage 0))
                  ((or (string=? arg "-l") (string=? arg "-location"))
                   (unless (pair? (cdr args)) (usage 1))
                   (set! *default-location* (cadr args))
                   (loop (cddr args)))
                  ((string=? "-query" arg)
                   (unless (pair? (cdr args)) (usage 1))
                   (set! *query-string* (cadr args))
                   (loop (cddr args)))
                  ((string=? "-remote" arg)
                   (unless (pair? (cdr args)) (usage 1))
                   (set! *remote-addr* (cadr args))
                   (loop (cddr args)))
                  ((and (positive? (string-length arg))
                        (char=? #\- (string-ref arg 0)))
                   (if (> (string-length arg) 2)
                       (let ((sos (string->list (substring arg 1))))
                         (if (null? (lset-intersection eq? *short-options* sos))
                             (loop (append (map (cut string #\- <>) sos) (cdr args)))
                             (usage 1)))
                       (usage 1)))
                  (else (loop (cdr args))))))))

  (main (command-line-arguments))
  
)