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

Last change on this file since 25926 was 25926, checked in by felix winkelmann, 10 years ago

henrietta 0.6: better egg name checking

File size: 8.2 KB
Line 
1;;;; henrietta.scm - Server program (CGI) for serving eggs from a repository over HTTP
2;
3; Copyright (c) 2008-2010, 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; version=<version>
35; name=<name>
36; tests
37; list
38; listversions
39
40
41(require-library setup-download regex extras utils ports srfi-1 posix)
42
43
44(module main ()
45
46  (import scheme chicken regex extras utils ports srfi-1 posix)
47  (import setup-api setup-download)
48
49  (define *default-transport* 'svn)
50  (define *default-location* (current-directory))
51  (define *username* #f)
52  (define *password* #f)
53  (define *tests* #f)
54  (define *mode* 'default)
55  (define *query-string* #f)
56  (define *remote-addr* #f)
57
58  (define (headers)
59    (print "Connection: close\r\nContent-type: text/plain\r\n\r\n"))
60
61  (define (fail msg . args)
62    (pp `(error ,msg ,@args))
63    (cleanup)
64    (exit 0))
65
66  (define-syntax hairy
67    (syntax-rules ()
68      ((_ body ...)
69       (handle-exceptions ex 
70           (fail ((condition-property-accessor 'exn 'message) ex)
71                 ((condition-property-accessor 'exn 'arguments) ex))
72         body ...))))
73
74  (define (cleanup)
75    (and-let* ((tmpdir (temporary-directory)))
76      (fprintf (current-error-port) "removing temporary directory `~a'~%" tmpdir)
77      (remove-directory tmpdir)))
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 (retrieve name version)
89    (when (illegal-name? name)
90      (fail "illegal egg name" name))
91    (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*))))
102      (unless dir 
103        (fail "no such extension or version" name version))
104      (let walk ((dir dir) (prefix "."))
105        (let ((files (directory dir)))
106          (for-each
107           (lambda (f)
108             (when (or *tests* (not (test-file? f)))
109               (let ((ff (string-append dir "/" f))
110                     (pf (string-append prefix "/" f)))
111                 (cond ((directory? ff)
112                        (print "\n#|-------------------- " ver " |# \"" pf "/\" 0")
113                        (walk ff pf))
114                       (else
115                        (print "\n#|-------------------- " ver " |# \"" pf "\" " 
116                               (file-size ff))
117                        (display (read-all ff)))))))
118           files)))))
119
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
142  (define query-string-rx (regexp "[^?]+\\?(.+)"))
143  (define query-arg-rx (regexp "^&?(\\w+)=([^&;]+)"))
144
145  (define (service)
146    (let ((qs (or *query-string* (get-environment-variable "QUERY_STRING")))
147          (ra (or *remote-addr* (get-environment-variable "REMOTE_ADDR"))))
148      (fprintf (current-error-port) "~%========== serving request from ~a: ~s~%"
149               (or ra "<unknown>") qs)
150      (unless qs
151        (error "no QUERY_STRING set"))
152      (let ((m (string-match query-string-rx qs))
153            (egg #f)
154            (version #f))
155        (let loop ((qs (if m (cadr m) qs)))
156          (let* ((m (string-search-positions query-arg-rx qs))
157                 (ms (and m (apply substring qs (cadr m))))
158                 (rest (and m (substring qs (cadar m)))))
159            (cond ((not m)
160                   (headers)            ; from here on use `fail'
161                   (cond (egg
162                          (retrieve egg version)
163                          (cleanup) )
164                         (else (fail "no extension name specified") ) ))
165                  ((string=? ms "version")
166                   (set! version (apply substring qs (caddr m)))
167                   (loop rest))
168                  ((string=? ms "name")
169                   (set! egg (apply substring qs (caddr m)))
170                   (loop rest))
171                  ((string=? ms "tests")
172                   (set! *tests* #t)
173                   (loop rest))
174                  ((string=? ms "list")
175                   (headers)
176                   (listing)
177                   (exit))
178                  ((string=? ms "listversions")
179                   (headers)
180                   (if egg
181                       (version-listing egg)
182                       (fail "`name' must be given first"))
183                   (exit))
184                  ((string=? ms "mode")
185                   (set! *mode* (string->symbol (apply substring qs (caddr m))))
186                   (loop rest))
187                  (else
188                   (warning "unrecognized query option" ms)
189                   (loop rest))))))))
190 
191  (define (usage code)
192    (print #<#EOF
193usage: henrietta [OPTION ...]
194
195  -h   -help                    show this message
196       -query QUERYSTRING       supply query-string on the command-line
197       -remote REMOTEADDR       supply remote address on the command-line
198  -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
202
203  QUERYSTRING and REMOTEADDR default to the value of the `QUERY_STRING' 
204and `REMOTE_ADDR' environment variables, respectively.
205
206EOF
207);|
208    (exit code))
209
210  (define *short-options* '(#\h #\l #\t))
211
212  (define (main args)
213    (let loop ((args args))
214      (if (null? args)
215          (service)
216          (let ((arg (car args)))
217            (cond ((or (string=? arg "-help") 
218                       (string=? arg "-h")
219                       (string=? arg "--help"))
220                   (usage 0))
221                  ((or (string=? arg "-l") (string=? arg "-location"))
222                   (unless (pair? (cdr args)) (usage 1))
223                   (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))
236                   (loop (cddr args)))
237                  ((string=? "-query" arg)
238                   (unless (pair? (cdr args)) (usage 1))
239                   (set! *query-string* (cadr args))
240                   (loop (cddr args)))
241                  ((string=? "-remote" arg)
242                   (unless (pair? (cdr args)) (usage 1))
243                   (set! *remote-addr* (cadr args))
244                   (loop (cddr args)))
245                  ((and (positive? (string-length arg))
246                        (char=? #\- (string-ref arg 0)))
247                   (if (> (string-length arg) 2)
248                       (let ((sos (string->list (substring arg 1))))
249                         (if (null? (lset-intersection eq? *short-options* sos))
250                             (loop (append (map (cut string #\- <>) sos) (cdr args)))
251                             (usage 1)))
252                       (usage 1)))
253                  (else (loop (cdr args))))))))
254
255  (main (command-line-arguments))
256 
257)
Note: See TracBrowser for help on using the repository browser.