source: project/chicken/trunk/setup-download.scm @ 15660

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

chicken-install tries alternative servers if server responds with error

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