source: project/release/5/henrietta/trunk/henrietta.scm @ 37457

Last change on this file since 37457 was 37457, checked in by felix winkelmann, 22 months ago

added henrietta 1.2, thanks to wasamasa for patches

File size: 10.2 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)
45  (cond-expand
46   (chicken-4
47    (import chicken)
48    (use regex extras utils ports srfi-1 posix files
49         data-structures (only setup-api version>=?)))
50   (chicken-5
51    (import (chicken base))
52    (import (chicken condition))
53    (import (chicken file))
54    (import (chicken file posix))
55    (import (chicken format))
56    (import (chicken io))
57    (import (chicken irregex))
58    (import (chicken pathname))
59    (import (chicken pretty-print))
60    (import (chicken process-context))
61    (import (chicken sort))
62    (import (chicken string))
63    (import regex)
64    (import (srfi 1))
65
66   ;; From setup-api.scm
67   (define (version>=? v1 v2)
68     (define (version->list v)
69       (map (lambda (x) (or (string->number x) x))
70            (irregex-split "[-\\._]" (->string v))))
71     (let loop ((p1 (version->list v1))
72                (p2 (version->list v2)))
73       (cond ((null? p1) (null? p2))
74             ((null? p2))
75             ((number? (car p1))
76              (and (number? (car p2))
77                   (or (> (car p1) (car p2))
78                       (and (= (car p1) (car p2))
79                            (loop (cdr p1) (cdr p2))))))
80             ((number? (car p2)))
81             ((string>? (car p1) (car p2)))
82             (else
83              (and (string=? (car p1) (car p2))
84                   (loop (cdr p1) (cdr p2)))))))))
85
86  (define *default-location* (current-directory))
87  (define *tests* #f)
88  (define *query-string* #f)
89  (define *remote-addr* #f)
90
91  ;; CHICKEN 4 was the first version to have henrietta to serve eggs.
92  ;; CHICKEN 5 breaks compatibility with CHICKEN 4, thus it needs eggs
93  ;; to be served from a different location.
94  ;; *default-chicken-release* is used to determine the subdirectory
95  ;; under *default-locations* where eggs can be found.  It is used
96  ;; when the `release' variable is not given in the HTTP request.  We
97  ;; use 4 because CHICKEN 4's chicken-install does not set `release'
98  ;; in requests.
99  (define *default-chicken-release* "4")
100
101 
102  (define (headers)
103    (print "Connection: close\r\nContent-type: text/plain\r\n\r\n"))
104
105  (define (fail msg . args)
106    (pp `(error ,msg ,@args))
107    (exit 0))
108
109  (define-syntax hairy
110    (syntax-rules ()
111      ((_ body ...)
112       (handle-exceptions ex 
113           (fail ((condition-property-accessor 'exn 'message) ex)
114                 ((condition-property-accessor 'exn 'arguments) ex))
115         body ...))))
116
117  (define test-file?
118    (let ((rx (regexp "(\\./)?tests(/.*)?")))
119      (lambda (path) (string-match rx path))))
120
121  (define illegal-name?
122    (let ((legal-chars
123           (string->list
124            "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ+-_")))
125      (lambda (name)
126        (not (every (cut member <> legal-chars)
127                    (string->list name))))))
128
129  (define (existing-version egg version vs)
130    (if version
131        (if (member version vs)
132            version
133            (error "version not found" egg version) )
134        (let ((vs (sort vs version>=?)))
135          (and (pair? vs)
136               (car vs) ) ) ) )
137
138  (define (release-base-dir release)
139    (when (not (equal? release (number->string (string->number release))))
140      (fail "illegal CHICKEN major release number"))
141    (make-pathname *default-location* release))
142
143  (define (egg-base-dir release egg-name)
144    (when (illegal-name? egg-name)
145      (fail "illegal egg name" egg-name))
146    (make-pathname (release-base-dir release) egg-name))
147 
148  (define (locate-egg release egg-name egg-version)
149    (let* ((egg-dir (egg-base-dir release egg-name))
150           (version (and (file-exists? egg-dir) (directory? egg-dir)
151                         (existing-version egg-name egg-version
152                                           (directory egg-dir)) ) )
153           (version-dir (and version (make-pathname egg-dir version)) ) )
154      (cond ((or (not version-dir)
155                 (not (file-exists? version-dir))
156                 (not (directory? version-dir)))
157             (values #f ""))
158            (else
159             (values version-dir version)))))
160
161  (define (retrieve release name version)
162    (let-values (((dir ver)
163                  (hairy (locate-egg release name version))))
164      (unless dir 
165        (fail "no such extension or version" name version))
166      (let walk ((dir dir) (prefix "."))
167        (let ((files (directory dir)))
168          (for-each
169           (lambda (f)
170             (when (or *tests* (not (test-file? f)))
171               (let ((ff (string-append dir "/" f))
172                     (pf (string-append prefix "/" f)))
173                 (cond ((directory? ff)
174                        (print "\n#|-------------------- " ver " |# \"" pf "/\" 0")
175                        (walk ff pf))
176                       (else
177                        (print "\n#|-------------------- " ver " |# \"" pf "\" " 
178                               (file-size ff))
179                        (display (call-with-input-file ff (cut read-string #f <>))))))))
180           files)))))
181
182  (define (egg-listing release)
183    (hairy (for-each print (directory (release-base-dir release)))))
184
185  (define (version-listing release egg-name)
186    (hairy (for-each print (directory (egg-base-dir release egg-name)))))
187
188  (define query-string-rx (regexp "[^?]+\\?(.+)"))
189  (define query-arg-rx (regexp "^[&;]?(\\w+)=([^&;]+)"))
190
191  (define (service)
192    (let ((qs (or *query-string* (get-environment-variable "QUERY_STRING")))
193          (ra (or *remote-addr* (get-environment-variable "REMOTE_ADDR"))))
194      (fprintf (current-error-port) "~%========== serving request from ~a: ~s~%"
195               (or ra "<unknown>") qs)
196      (unless qs
197        (error "no QUERY_STRING set"))
198      (let ((m (string-match query-string-rx qs))
199            (egg #f)
200            (chicken-release *default-chicken-release*)
201            (version #f))
202        (let loop ((qs (if m (cadr m) qs)))
203          (let* ((m (string-search-positions query-arg-rx qs))
204                 (ms (and m (apply substring qs (cadr m))))
205                 (rest (and m (substring qs (cadar m)))))
206            (cond ((not m)
207                   (headers)            ; from here on use `fail'
208                   (if (and egg chicken-release)
209                       (retrieve chicken-release egg version)
210                       (fail "you must specify extension name and CHICKEN release")  ))
211                  ((string=? ms "version")
212                   (set! version (apply substring qs (caddr m)))
213                   (loop rest))
214                  ((string=? ms "release")
215                   (set! chicken-release (apply substring qs (caddr m)))
216                   (loop rest))
217                  ((string=? ms "name")
218                   (set! egg (apply substring qs (caddr m)))
219                   (loop rest))
220                  ((string=? ms "tests")
221                   (set! *tests* #t)
222                   (loop rest))
223                  ((string=? ms "list")
224                   (headers)
225                   (if chicken-release
226                       (egg-listing chicken-release)
227                       (fail "you must specify CHICKEN release") ) )
228                  ((string=? ms "listversions")
229                   (headers)
230                   (if (and egg chicken-release)
231                       (version-listing chicken-release egg)
232                       (fail "you must specify extension name and CHICKEN release"))
233                   (exit))
234                  (else
235                   (warning "unrecognized query option" ms)
236                   (loop rest))))))))
237 
238  (define (usage code)
239    (print #<#EOF
240usage: henrietta [OPTION ...]
241
242  -h   -help                    show this message
243       -query QUERYSTRING       supply query-string on the command-line
244       -remote REMOTEADDR       supply remote address on the command-line
245  -l   -location LOCATION       install from given location (default: current directory)
246
247  QUERYSTRING and REMOTEADDR default to the value of the `QUERY_STRING' 
248and `REMOTE_ADDR' environment variables, respectively.
249
250  LOCATION should point to the base directory under which
251subdirectories named after the CHICKEN major version can be found.
252
253EOF
254);|
255    (exit code))
256
257  (define *short-options* '(#\h #\l #\t))
258
259  (define (main args)
260    (let loop ((args args))
261      (if (null? args)
262          (service)
263          (let ((arg (car args)))
264            (cond ((or (string=? arg "-help") 
265                       (string=? arg "-h")
266                       (string=? arg "--help"))
267                   (usage 0))
268                  ((or (string=? arg "-l") (string=? arg "-location"))
269                   (unless (pair? (cdr args)) (usage 1))
270                   (set! *default-location* (cadr args))
271                   (loop (cddr args)))
272                  ((string=? "-query" arg)
273                   (unless (pair? (cdr args)) (usage 1))
274                   (set! *query-string* (cadr args))
275                   (loop (cddr args)))
276                  ((string=? "-remote" arg)
277                   (unless (pair? (cdr args)) (usage 1))
278                   (set! *remote-addr* (cadr args))
279                   (loop (cddr args)))
280                  ((and (positive? (string-length arg))
281                        (char=? #\- (string-ref arg 0)))
282                   (if (> (string-length arg) 2)
283                       (let ((sos (string->list (substring arg 1))))
284                         (if (null? (lset-intersection eq? *short-options* sos))
285                             (loop (append (map (cut string #\- <>) sos) (cdr args)))
286                             (usage 1)))
287                       (usage 1)))
288                  (else (loop (cdr args))))))))
289
290  (main (command-line-arguments))
291 
292)
Note: See TracBrowser for help on using the repository browser.