source: project/release/4/henrietta/trunk/henrietta.scm @ 31425

Last change on this file since 31425 was 31425, checked in by Mario Domenech Goulart, 7 years ago

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

File size: 8.9 KB
Line 
1;;;; henrietta.scm - Server program (CGI) for serving eggs from a repository over HTTP
2;
3; Copyright (c) 2008-2014, The CHICKEN Team
4; All rights reserved.
5;
6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
7; conditions are met:
8;
9;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
10;     disclaimer.
11;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
12;     disclaimer in the documentation and/or other materials provided with the distribution.
13;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
14;     products derived from this software without specific prior written permission.
15;
16; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
24; POSSIBILITY OF SUCH DAMAGE.
25
26
27; used environment variables:
28;
29; QUERY_STRING
30; REMOTE_ADDR (optional)
31
32; URL arguments:
33;
34; release=<major-chicken-version>
35; name=<name>
36; version=<version>
37; tests
38; list
39; listversions
40
41
42(module main ()
43
44  (import scheme chicken)
45  (use regex extras utils ports srfi-1 posix files
46       data-structures (only setup-api version>=?))
47
48  (define *default-location* (current-directory))
49  (define *tests* #f)
50  (define *query-string* #f)
51  (define *remote-addr* #f)
52
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 
64  (define (headers)
65    (print "Connection: close\r\nContent-type: text/plain\r\n\r\n"))
66
67  (define (fail msg . args)
68    (pp `(error ,msg ,@args))
69    (exit 0))
70
71  (define-syntax hairy
72    (syntax-rules ()
73      ((_ body ...)
74       (handle-exceptions ex 
75           (fail ((condition-property-accessor 'exn 'message) ex)
76                 ((condition-property-accessor 'exn 'arguments) ex))
77         body ...))))
78
79  (define test-file?
80    (let ((rx (regexp "(\\./)?tests(/.*)?")))
81      (lambda (path) (string-match rx path))))
82
83  (define (illegal-name? name)
84    (or (equal? #\. (string-ref name 0))
85        (any (cut equal? #\/ <>)
86             (string->list name))))
87
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)
121    (let-values (((dir ver)
122                  (hairy (locate-egg release name version))))
123      (unless dir 
124        (fail "no such extension or version" name version))
125      (let walk ((dir dir) (prefix "."))
126        (let ((files (directory dir)))
127          (for-each
128           (lambda (f)
129             (when (or *tests* (not (test-file? f)))
130               (let ((ff (string-append dir "/" f))
131                     (pf (string-append prefix "/" f)))
132                 (cond ((directory? ff)
133                        (print "\n#|-------------------- " ver " |# \"" pf "/\" 0")
134                        (walk ff pf))
135                       (else
136                        (print "\n#|-------------------- " ver " |# \"" pf "\" " 
137                               (file-size ff))
138                        (display (read-all ff)))))))
139           files)))))
140
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)))))
146
147  (define query-string-rx (regexp "[^?]+\\?(.+)"))
148  (define query-arg-rx (regexp "^[&;]?(\\w+)=([^&;]+)"))
149
150  (define (service)
151    (let ((qs (or *query-string* (get-environment-variable "QUERY_STRING")))
152          (ra (or *remote-addr* (get-environment-variable "REMOTE_ADDR"))))
153      (fprintf (current-error-port) "~%========== serving request from ~a: ~s~%"
154               (or ra "<unknown>") qs)
155      (unless qs
156        (error "no QUERY_STRING set"))
157      (let ((m (string-match query-string-rx qs))
158            (egg #f)
159            (chicken-release *default-chicken-release*)
160            (version #f))
161        (let loop ((qs (if m (cadr m) qs)))
162          (let* ((m (string-search-positions query-arg-rx qs))
163                 (ms (and m (apply substring qs (cadr m))))
164                 (rest (and m (substring qs (cadar m)))))
165            (cond ((not m)
166                   (headers)            ; from here on use `fail'
167                   (if (and egg chicken-release)
168                       (retrieve chicken-release egg version)
169                       (fail "you must specify extension name and CHICKEN release")  ))
170                  ((string=? ms "version")
171                   (set! version (apply substring qs (caddr m)))
172                   (loop rest))
173                  ((string=? ms "release")
174                   (set! chicken-release (apply substring qs (caddr m)))
175                   (loop rest))
176                  ((string=? ms "name")
177                   (set! egg (apply substring qs (caddr m)))
178                   (loop rest))
179                  ((string=? ms "tests")
180                   (set! *tests* #t)
181                   (loop rest))
182                  ((string=? ms "list")
183                   (headers)
184                   (if chicken-release
185                       (egg-listing chicken-release)
186                       (fail "you must specify CHICKEN release") ) )
187                  ((string=? ms "listversions")
188                   (headers)
189                   (if (and egg chicken-release)
190                       (version-listing chicken-release egg)
191                       (fail "you must specify extension name and CHICKEN release"))
192                   (exit))
193                  (else
194                   (warning "unrecognized query option" ms)
195                   (loop rest))))))))
196 
197  (define (usage code)
198    (print #<#EOF
199usage: henrietta [OPTION ...]
200
201  -h   -help                    show this message
202       -query QUERYSTRING       supply query-string on the command-line
203       -remote REMOTEADDR       supply remote address on the command-line
204  -l   -location LOCATION       install from given location (default: current directory)
205
206  QUERYSTRING and REMOTEADDR default to the value of the `QUERY_STRING' 
207and `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.
211
212EOF
213);|
214    (exit code))
215
216  (define *short-options* '(#\h #\l #\t))
217
218  (define (main args)
219    (let loop ((args args))
220      (if (null? args)
221          (service)
222          (let ((arg (car args)))
223            (cond ((or (string=? arg "-help") 
224                       (string=? arg "-h")
225                       (string=? arg "--help"))
226                   (usage 0))
227                  ((or (string=? arg "-l") (string=? arg "-location"))
228                   (unless (pair? (cdr args)) (usage 1))
229                   (set! *default-location* (cadr args))
230                   (loop (cddr args)))
231                  ((string=? "-query" arg)
232                   (unless (pair? (cdr args)) (usage 1))
233                   (set! *query-string* (cadr args))
234                   (loop (cddr args)))
235                  ((string=? "-remote" arg)
236                   (unless (pair? (cdr args)) (usage 1))
237                   (set! *remote-addr* (cadr args))
238                   (loop (cddr args)))
239                  ((and (positive? (string-length arg))
240                        (char=? #\- (string-ref arg 0)))
241                   (if (> (string-length arg) 2)
242                       (let ((sos (string->list (substring arg 1))))
243                         (if (null? (lset-intersection eq? *short-options* sos))
244                             (loop (append (map (cut string #\- <>) sos) (cdr args)))
245                             (usage 1)))
246                       (usage 1)))
247                  (else (loop (cdr args))))))))
248
249  (main (command-line-arguments))
250 
251)
Note: See TracBrowser for help on using the repository browser.