source: project/chicken/branches/hygienic/henrietta.scm @ 11776

Last change on this file since 11776 was 11776, checked in by felix winkelmann, 13 years ago

-version option for new setup tools; options for credentials

File size: 5.9 KB
Line 
1;;;; henrietta.scm - Server program (CGI) for serving eggs from a repository over HTTP
2;
3; Copyright (c) 2008, 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(require-library setup-download regex extras utils ports srfi-1 posix)
28
29
30(module main ()
31
32  (import scheme chicken regex extras utils ports srfi-1 posix)
33  (import setup-utils setup-download)
34
35  (define *default-transport* 'svn)
36  (define *default-location* (current-directory))
37  (define *test* #f)
38  (define *username* #f)
39  (define *password* #f)
40
41  (define (headers)
42    (print "Connection: close\r\nContent-type: text/plain\r\n\r\n"))
43
44  (define (fail msg . args)
45    (pp `(error ,msg ,@args))
46    (cleanup)
47    (exit 0))
48
49  (define (cleanup)
50    (and-let* ((tmpdir (temporary-directory)))
51      (fprintf (current-error-port) "removing temporary directory `~a'~%" tmpdir)
52      (remove-directory tmpdir)))
53
54  (define (retrieve name version)
55    (let ((dir (handle-exceptions ex 
56                   (fail ((condition-property-accessor 'exn 'message) ex)
57                         ((condition-property-accessor 'exn 'arguments) ex))
58                 (retrieve-extension 
59                  name *default-transport* *default-location*
60                  version #t #f
61                  *username* *password*))))
62      (unless dir 
63        (fail "no such extension or version" name version))
64      (let walk ((dir dir) (prefix "."))
65        (let ((files (directory dir)))
66          (for-each
67           (lambda (f)
68             (let ((ff (string-append dir "/" f))
69                   (pf (string-append prefix "/" f)))
70               (cond ((directory? ff)
71                      (print "\n#|--------------------|# \"" pf "/\" 0")
72                      (walk ff pf))
73                     (else
74                      (print "\n#|--------------------|# \"" pf "\" " (file-size ff))
75                      (display (read-all ff))))))
76           files)))
77      (print "\n#!eof") ) )
78
79  (define (service)
80    (let ((qs (getenv "QUERY_STRING"))
81          (ra (getenv "REMOTE_ADDR")))
82      (fprintf (current-error-port) "~%========== serving request from ~a: ~s~%"
83               (or ra "<unknown>") qs)
84      (unless qs
85        (error "no QUERY_STRING set"))
86      (let ((m (string-match "[^?]+\\?(.+)" qs))
87            (egg #f)
88            (version #f))
89        (let loop ((qs (if m (cadr m) qs)))
90          (let* ((m (string-search-positions "^(\\w+)=([^&]+)" qs))
91                 (ms (and m (apply substring qs (cadr m))))
92                 (rest (and m (substring qs (cadar m)))))
93            (cond ((not m)
94                   (headers)            ; from here on use `fail'
95                   (cond (*test* 
96                          (fail "test"))
97                         (egg
98                          (retrieve egg version)
99                          (cleanup) )
100                         (else (fail "no extension name specified") ) ))
101                  ((string=? ms "version")
102                   (set! version (apply substring qs (caddr m)))
103                   (loop rest))
104                  ((string=? ms "name")
105                   (set! egg (apply substring qs (caddr m)))
106                   (loop rest))
107                  ((string=? ms "test")
108                   (set! *test* #t)
109                   (loop rest))
110                  (else
111                   (warning "unrecognized query option" ms)
112                   (loop rest))))))))
113 
114
115  (define (usage code)
116    (print #<#EOF
117usage: henrietta [OPTION ...]
118
119  -h   -help                    show this message
120  -l   -location LOCATION       install from given location (default: current directory)
121  -t   -transport TRANSPORT     use given transport instead of default (#{*default-transport*})
122       -username USER           set username for transports that require this
123       -password PASS           set password for transports that require this
124EOF
125);|
126    (exit code))
127
128  (define *short-options* '(#\h #\l #\t))
129
130  (define (main args)
131    (let loop ((args args))
132      (if (null? args)
133          (service)
134          (let ((arg (car args)))
135            (cond ((or (string=? arg "-help") 
136                       (string=? arg "-h")
137                       (string=? arg "--help"))
138                   (usage 0))
139                  ((or (string=? arg "-l") (string=? arg "-location"))
140                   (unless (pair? (cdr args)) (usage 1))
141                   (set! *default-location* (cadr args))
142                   (loop (cddr args)))
143                  ((or (string=? arg "-t") (string=? arg "-transport"))
144                   (unless (pair? (cdr args)) (usage 1))
145                   (set! *default-transport* (string->symbol (cadr args)))
146                   (loop (cddr args)))
147                  ((string=? "-username" arg)
148                   (unless (pair? (cdr args)) (usage 1))
149                   (set! *username* (cadr args))
150                   (loop (cddr args)))
151                  ((string=? "-password" arg)
152                   (unless (pair? (cdr args)) (usage 1))
153                   (set! *password* (cadr args))
154                   (loop (cddr args)))
155                  ((and (positive? (string-length arg))
156                        (char=? #\- (string-ref arg 0)))
157                   (if (> (string-length arg) 2)
158                       (let ((sos (string->list (substring arg 1))))
159                         (if (null? (lset-intersection eq? *short-options* sos))
160                             (loop (append (map (cut string #\- <>) sos) (cdr args)))
161                             (usage 1)))
162                       (usage 1)))
163                  (else (loop (cdr args))))))))
164
165  (main (command-line-arguments))
166 
167)
Note: See TracBrowser for help on using the repository browser.