Changeset 31425 in project


Ignore:
Timestamp:
09/14/14 23:59:09 (7 years ago)
Author:
Mario Domenech Goulart
Message:

herietta (trunk): support multiple CHICKEN major versions

This patch is by Peter Bex (see
https://lists.nongnu.org/archive/html/chicken-hackers/2014-09/msg00090.html)

Henrietta now respect the `release' variable in HTTP requests.
It indicates the CHICKEN major version. When not provided,
henrietta assumes "4".

Note that the semantics of -location has changed: its argument
should now point to the base directory under which subdirectories
named after the CHICKEN major version can be found.

The support for transports other than local has been removed (the

-ttransport, -username and -password command line options are

gone).

Version bumped to 1.0

Location:
release/4/henrietta/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/henrietta/trunk/henrietta.scm

    r25926 r31425  
    11;;;; henrietta.scm - Server program (CGI) for serving eggs from a repository over HTTP
    22;
    3 ; Copyright (c) 2008-2010, The CHICKEN Team
     3; Copyright (c) 2008-2014, The CHICKEN Team
    44; All rights reserved.
    55;
     
    3232; URL arguments:
    3333;
     34; release=<major-chicken-version>
     35; name=<name>
    3436; version=<version>
    35 ; name=<name>
    3637; tests
    3738; list
     
    3940
    4041
    41 (require-library setup-download regex extras utils ports srfi-1 posix)
    42 
    43 
    4442(module main ()
    4543
    46   (import scheme chicken regex extras utils ports srfi-1 posix)
    47   (import setup-api setup-download)
    48 
    49   (define *default-transport* 'svn)
     44  (import scheme chicken)
     45  (use regex extras utils ports srfi-1 posix files
     46       data-structures (only setup-api version>=?))
     47
    5048  (define *default-location* (current-directory))
    51   (define *username* #f)
    52   (define *password* #f)
    5349  (define *tests* #f)
    54   (define *mode* 'default)
    5550  (define *query-string* #f)
    5651  (define *remote-addr* #f)
    5752
     53  ;; CHICKEN 4 was the first version to have henrietta to serve eggs.
     54  ;; CHICKEN 5 breaks compatibility with CHICKEN 4, thus it needs eggs
     55  ;; to be served from a different location.
     56  ;; *default-chicken-release* is used to determine the subdirectory
     57  ;; under *default-locations* where eggs can be found.  It is used
     58  ;; when the `release' variable is not given in the HTTP request.  We
     59  ;; use 4 because CHICKEN 4's chicken-install does not set `release'
     60  ;; in requests.
     61  (define *default-chicken-release* "4")
     62
     63 
    5864  (define (headers)
    5965    (print "Connection: close\r\nContent-type: text/plain\r\n\r\n"))
     
    6167  (define (fail msg . args)
    6268    (pp `(error ,msg ,@args))
    63     (cleanup)
    6469    (exit 0))
    6570
     
    7277         body ...))))
    7378
    74   (define (cleanup)
    75     (and-let* ((tmpdir (temporary-directory)))
    76       (fprintf (current-error-port) "removing temporary directory `~a'~%" tmpdir)
    77       (remove-directory tmpdir)))
    78 
    7979  (define test-file?
    8080    (let ((rx (regexp "(\\./)?tests(/.*)?")))
     
    8686             (string->list name))))
    8787
    88   (define (retrieve name version)
    89     (when (illegal-name? name)
    90       (fail "illegal egg name" name))
     88  (define (existing-version egg version vs)
     89    (if version
     90        (if (member version vs)
     91            version
     92            (error "version not found" egg version) )
     93        (let ((vs (sort vs version>=?)))
     94          (and (pair? vs)
     95               (car vs) ) ) ) )
     96
     97  (define (release-base-dir release)
     98    (when (not (equal? release (number->string (string->number release))))
     99      (fail "illegal CHICKEN major release number"))
     100    (make-pathname *default-location* release))
     101
     102  (define (egg-base-dir release egg-name)
     103    (when (illegal-name? egg-name)
     104      (fail "illegal egg name" egg-name))
     105    (make-pathname (release-base-dir release) egg-name))
     106 
     107  (define (locate-egg release egg-name egg-version)
     108    (let* ((egg-dir (egg-base-dir release egg-name))
     109           (version (and (file-exists? egg-dir) (directory? egg-dir)
     110                         (existing-version egg-name egg-version
     111                                           (directory egg-dir)) ) )
     112           (version-dir (and version (make-pathname egg-dir version)) ) )
     113      (cond ((or (not version-dir)
     114                 (not (file-exists? version-dir))
     115                 (not (directory? version-dir)))
     116             (values #f ""))
     117            (else
     118             (values version-dir version)))))
     119
     120  (define (retrieve release name version)
    91121    (let-values (((dir ver)
    92                   (hairy
    93                    (retrieve-extension
    94                     name *default-transport* *default-location*
    95                     version: version
    96                     quiet: #t
    97                     destination: #f
    98                     tests: *tests*
    99                     mode: *mode*
    100                     username: *username*
    101                     password: *password*))))
     122                  (hairy (locate-egg release name version))))
    102123      (unless dir
    103124        (fail "no such extension or version" name version))
     
    118139           files)))))
    119140
    120   (define (listing)
    121     (let ((dir (hairy
    122                  (list-extensions
    123                   *default-transport* *default-location*
    124                   quiet: #t
    125                   username: *username*
    126                   password: *password*))))
    127       (if dir
    128           (display dir)
    129           (fail "unable to retrieve extension-list"))))
    130 
    131   (define (version-listing name)
    132     (let ((dir (hairy
    133                  (list-extension-versions
    134                   name
    135                   *default-transport* *default-location*
    136                   username: *username*
    137                   password: *password*))))
    138       (if dir
    139           (display dir)
    140           (fail "unable to retrieve version-list for extension" name))))
     141  (define (egg-listing release)
     142    (hairy (for-each print (directory (release-base-dir release)))))
     143
     144  (define (version-listing release egg-name)
     145    (hairy (for-each print (directory (egg-base-dir release egg-name)))))
    141146
    142147  (define query-string-rx (regexp "[^?]+\\?(.+)"))
    143   (define query-arg-rx (regexp "^&?(\\w+)=([^&;]+)"))
     148  (define query-arg-rx (regexp "^[&;]?(\\w+)=([^&;]+)"))
    144149
    145150  (define (service)
     
    152157      (let ((m (string-match query-string-rx qs))
    153158            (egg #f)
     159            (chicken-release *default-chicken-release*)
    154160            (version #f))
    155161        (let loop ((qs (if m (cadr m) qs)))
     
    159165            (cond ((not m)
    160166                   (headers)            ; from here on use `fail'
    161                    (cond (egg
    162                           (retrieve egg version)
    163                           (cleanup) )
    164                          (else (fail "no extension name specified") ) ))
     167                   (if (and egg chicken-release)
     168                       (retrieve chicken-release egg version)
     169                       (fail "you must specify extension name and CHICKEN release")  ))
    165170                  ((string=? ms "version")
    166171                   (set! version (apply substring qs (caddr m)))
    167172                   (loop rest))
     173                  ((string=? ms "release")
     174                   (set! chicken-release (apply substring qs (caddr m)))
     175                   (loop rest))
    168176                  ((string=? ms "name")
    169177                   (set! egg (apply substring qs (caddr m)))
     
    174182                  ((string=? ms "list")
    175183                   (headers)
    176                    (listing)
    177                    (exit))
     184                   (if chicken-release
     185                       (egg-listing chicken-release)
     186                       (fail "you must specify CHICKEN release") ) )
    178187                  ((string=? ms "listversions")
    179188                   (headers)
    180                    (if egg
    181                        (version-listing egg)
    182                        (fail "`name' must be given first"))
     189                   (if (and egg chicken-release)
     190                       (version-listing chicken-release egg)
     191                       (fail "you must specify extension name and CHICKEN release"))
    183192                   (exit))
    184                   ((string=? ms "mode")
    185                    (set! *mode* (string->symbol (apply substring qs (caddr m))))
    186                    (loop rest))
    187193                  (else
    188194                   (warning "unrecognized query option" ms)
     
    197203       -remote REMOTEADDR       supply remote address on the command-line
    198204  -l   -location LOCATION       install from given location (default: current directory)
    199   -t   -transport TRANSPORT     use given transport instead of default (#{*default-transport*})
    200        -username USER           set username for transports that require this
    201        -password PASS           set password for transports that require this
    202205
    203206  QUERYSTRING and REMOTEADDR default to the value of the `QUERY_STRING'
    204207and `REMOTE_ADDR' environment variables, respectively.
     208
     209  LOCATION should point to the base directory under which
     210subdirectories named after the CHICKEN major version can be found.
    205211
    206212EOF
     
    222228                   (unless (pair? (cdr args)) (usage 1))
    223229                   (set! *default-location* (cadr args))
    224                    (loop (cddr args)))
    225                   ((or (string=? arg "-t") (string=? arg "-transport"))
    226                    (unless (pair? (cdr args)) (usage 1))
    227                    (set! *default-transport* (string->symbol (cadr args)))
    228                    (loop (cddr args)))
    229                   ((string=? "-username" arg)
    230                    (unless (pair? (cdr args)) (usage 1))
    231                    (set! *username* (cadr args))
    232                    (loop (cddr args)))
    233                   ((string=? "-password" arg)
    234                    (unless (pair? (cdr args)) (usage 1))
    235                    (set! *password* (cadr args))
    236230                   (loop (cddr args)))
    237231                  ((string=? "-query" arg)
  • release/4/henrietta/trunk/henrietta.setup

    r25926 r31425  
    11;;;; henrietta.setup -*- Scheme -*-
    2 
    32
    43(compile -O3 -d0 henrietta.scm)
     
    76 'henrietta
    87 '("henrietta")
    9  '((version 0.6)))
     8 '((version "1.0")))
Note: See TracChangeset for help on using the changeset viewer.