source: project/chicken/branches/scrutiny/setup-download.scm @ 13965

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

merged trunk rev. 13953

File size: 11.1 KB
Line 
1;;;; setup-download.scm
2;
3; Copyright (c) 2008-2009, 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 extras regex posix utils setup-api srfi-1 data-structures tcp srfi-13
28                 files)
29
30
31(module setup-download (retrieve-extension
32                        locate-egg/local
33                        locate-egg/svn
34                        locate-egg/http
35                        gather-egg-information
36                        list-extensions
37                        temporary-directory)
38
39  (import scheme chicken)
40  (import extras regex posix utils srfi-1 data-structures tcp srfi-13 files setup-api)
41
42  (tcp-connect-timeout 10000)           ; 10 seconds
43  (tcp-read-timeout 10000)
44  (tcp-write-timeout 10000)
45
46  (define *quiet* #f)
47
48  (define *chicken-install-user-agent* (conc "chicken-install " (chicken-version)))
49
50  (define (d fstr . args)
51    (let ([port (if *quiet* (current-error-port) (current-output-port))])
52      (apply fprintf port fstr args)
53      (flush-output port) ) )
54
55  (define temporary-directory (make-parameter #f))
56
57  (define (get-temporary-directory)
58    (or (temporary-directory)
59        (let ([dir (create-temporary-directory)])
60          (temporary-directory dir)
61          dir ) ) )
62
63  (define (existing-version egg version vs)
64    (if version
65        (if (member version vs)
66            version
67            (error "version not found" egg version) )
68        (let ([vs (sort vs version>=?)])
69          (and (pair? vs)
70               (car vs) ) ) ) )
71
72  (define (when-no-such-version-warning egg version)
73    (when version (warning "extension has no such version - using default" egg version)) )
74
75  (define (list-eggs/local dir)
76    (string-concatenate (map (cut string-append <> "\n") (directory dir))) )
77
78  (define (locate-egg/local egg dir #!optional version destination)
79    (let* ([eggdir (make-pathname dir egg)]
80           [tagdir (make-pathname eggdir "tags")]
81           [tagver (and (file-exists? tagdir) (directory? tagdir)
82                        (existing-version egg version (directory tagdir)) ) ] )
83      (if tagver
84          (values (make-pathname tagdir tagver) tagver)
85          (let ([trunkdir (make-pathname eggdir "trunk")])
86            (when-no-such-version-warning egg version)
87            (if (and (file-exists? trunkdir) (directory? trunkdir))
88                (values trunkdir "trunk")
89                (values eggdir "") ) ) ) ) )
90
91  (define (gather-egg-information dir)
92    (let ((ls (directory dir)))
93      (filter-map
94       (lambda (egg)
95         (let-values (((loc version) (locate-egg/local egg dir)))
96           (let ((meta (make-pathname loc egg "meta")))
97             (and (file-exists? meta)
98                  (call/cc
99                   (lambda (return)
100                     (cons (string->symbol egg) 
101                           (cons (list 'version version)
102                                 (handle-exceptions ex
103                                     (begin
104                                       (warning "extension has syntactically invalid .meta file" egg)
105                                       (return #f))
106                                   (with-input-from-file meta read))))))))))
107       ls)))
108
109  (define (make-svn-ls-cmd uarg parg pnam #!key recursive?)
110    (conc "svn ls " uarg #\space parg (if recursive? " -R " "") (qs pnam)) )
111
112  (define (make-svn-export-cmd uarg parg dir tmpdir)
113    (conc "svn export " uarg #\space parg #\space #\" dir #\" #\space #\" tmpdir #\"
114          (if *quiet* " 1>&2" "")) )
115
116  (define (list-eggs/svn repo #!optional username password)
117    (let ([uarg (if username (string-append "--username='" username "'") "")]
118          [parg (if password (string-append "--password='" password "'") "")])
119      (let ([cmd (make-svn-ls-cmd uarg parg repo)])
120        (d "listing extension directory ...~%  ~a~%" cmd)
121        (string-concatenate
122         (map (lambda (s) (string-append (string-chomp s "/") "\n"))
123              (with-input-from-pipe cmd read-lines))) ) ) )
124
125  (define (locate-egg/svn egg repo #!optional version destination username  password)
126    (let* ([uarg (if username (string-append "--username='" username "'") "")]
127           [parg (if password (string-append "--password='" password "'") "")]
128           [cmd (make-svn-ls-cmd uarg parg (make-pathname repo egg) recursive?: #t)])
129      (d "checking available versions ...~%  ~a~%" cmd)
130      (let* ([files (with-input-from-pipe cmd read-lines)]
131             [tagver (existing-version
132                      egg version
133                      (filter-map
134                       (lambda (f) (and-let* ((m (string-search "^tags/([^/]+)/" f))) (cadr m)))
135                       files))])
136        (let-values ([(filedir ver)
137                      (if tagver
138                          (values (string-append "tags/" tagver) tagver)
139                          (begin
140                            (when-no-such-version-warning egg version)
141                            (if (member "trunk/" files)
142                                (values "trunk" "trunk")
143                                (values "" "") ) ) ) ] )
144          (let* ([tmpdir (make-pathname (or destination (get-temporary-directory)) egg)]
145                 [cmd (make-svn-export-cmd uarg parg (conc repo #\/ egg #\/ filedir) tmpdir)])
146            (d "  ~a~%" cmd)
147            (if (zero? (system cmd))
148                (values tmpdir ver)
149                (values #f "") ) ) ) ) ) )
150
151  (define (deconstruct-url url)
152    (let ([m (string-match "(http://)?([^/:]+)(:([^:/]+))?(/.+)" url)])
153      (values
154       (if m (caddr m) url)
155       (if (and m (cadddr m))
156           (or (string->number (list-ref m 4))
157               (error "not a valid port" (list-ref m 4)))
158           80)
159       (if m (list-ref m 5) "/")) ) )
160
161  (define (locate-egg/http egg url #!optional version destination tests)
162    (let ([tmpdir (or destination (get-temporary-directory))])
163      (let-values ([(host port locn) (deconstruct-url url)])
164        (let ([locn (string-append
165                     locn
166                     "?name=" egg
167                     (if version (string-append "&version=" version) "")
168                     (if tests "&tests=yes" ""))]
169              [eggdir (make-pathname tmpdir egg) ] )
170          (unless (file-exists? eggdir) (create-directory eggdir))
171          (http-fetch host port locn eggdir)
172          ; If we get here then version of egg exists
173          (values eggdir (or version "")) ) ) ) )
174
175  (define (network-failure msg . args)
176    (signal
177     (make-composite-condition
178      (make-property-condition
179       'exn
180       'message "invalid response from server"
181       'arguments args)
182      (make-property-condition 'http-fetch))) )
183
184  (define (make-HTTP-GET/1.1 location user-agent host
185                             #!key
186                             (port 80)
187                             (connection "close")
188                             (accept "*")
189                             (content-length 0))
190    (conc
191     "GET " location " HTTP/1.1" "\r\n"
192     "Connection: " connection "\r\n"
193     "User-Agent: " user-agent "\r\n"
194     "Accept: " accept "\r\n"
195     "Host: " host #\: port "\r\n"
196     "Content-length: " content-length "\r\n"
197     "\r\n") )
198
199  (define (match-http-response rsp)
200    (and (string? rsp)
201         (string-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )
202
203  (define (response-match-code? mrsp code)
204    (and mrsp (string=? (number->string code) (cadr mrsp))) )
205
206  (define (match-chunked-transfer-encoding ln)
207    (string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
208
209  (define (http-fetch host port locn dest)
210    (d "connecting to host ~s, port ~a ...~%" host port)
211    (let-values ([(in out) (tcp-connect host port)])
212      (d "requesting ~s ...~%" locn)
213      (display
214       (make-HTTP-GET/1.1 locn *chicken-install-user-agent* host port: port accept: "*/*")
215       out)
216      (close-output-port out)
217      (d "reading response ...~%")
218      (let ([chunked #f])
219        (let* ([h1 (read-line in)]
220               [response-match (match-http-response h1)])
221          (d "~a~%" h1)
222          ;;*** handle redirects here
223          (unless (response-match-code? response-match 200)
224            (network-failure "invalid response from server" h1) )
225          (let loop ()
226            (let ([ln (read-line in)])
227              (unless (string-null? ln)
228                (when (match-chunked-transfer-encoding ln) (set! chunked #t))
229                (d "~a~%" ln)
230                (loop) ) ) ) )
231        (when chunked
232          (d "reading chunks ...~%")
233          (let ([data (read-chunks in)])
234            (close-input-port in)
235            (set! in (open-input-string data))) ) )
236      (d "reading files ...~%")
237      (let get-files ([files '()])
238        (let ([name (read in)])
239          (cond [(and (pair? name) (eq? 'error (car name)))
240                 (apply error (string-append "[Server] " (cadr name)) (cddr name)) ]
241                [(or (eof-object? name) (not name))
242                 (close-input-port in)
243                 (reverse files) ]
244                [(not (string? name))
245                 (error "invalid file name - possibly corrupt transmission" name) ]
246                [(string-suffix? "/" name)
247                 (read in)              ; skip size
248                 (d "  ~a~%" name)
249                 (create-directory (make-pathname dest name))
250                 (get-files files) ]
251                [else
252                 (d "  ~a~%" name)
253                 (let* ([size (read in)]
254                        [_ (read-line in)]
255                        [data (read-string size in)] )
256                   (with-output-to-file (make-pathname dest name) (cut display data) ) )
257                 (get-files (cons name files)) ] ) ) ) ) )
258
259  (define (read-chunks in)
260    (let get-chunks ([data '()])
261      (let ([size (string->number (read-line in) 16)])
262        (if (zero? size)
263            (string-concatenate-reverse data)
264            (let ([chunk (read-string size in)])
265              (read-line in)
266              (get-chunks (cons chunk data)) ) ) ) ) )
267
268  (define (retrieve-extension name transport location
269                              #!key version quiet destination username password tests)
270    (fluid-let ([*quiet* quiet])
271      (case transport
272        [(local)
273         (when destination (warning "destination for transport `local' ignored"))
274         (locate-egg/local name location version destination) ]
275        [(svn)
276         (locate-egg/svn name location version destination username password) ]
277        [(http)
278         (locate-egg/http name location version destination tests) ]
279        [else
280         (error "cannot retrieve extension unsupported transport" transport) ] ) ) )
281
282  (define (list-extensions transport location #!key quiet username password)
283    (fluid-let ([*quiet* quiet])
284      (case transport
285        [(local)
286         (list-eggs/local location) ]
287        [(svn)
288         (list-eggs/svn location username password) ]
289        [else
290         (error "cannot list extensions - unsupported transport" transport) ] ) ) )
291
292) ;module setup-download
Note: See TracBrowser for help on using the repository browser.