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

Last change on this file since 12227 was 12227, checked in by felix winkelmann, 12 years ago
  • added helpful script for testing in build dir
  • chicken-install checks for TCP timeouts and handles multiple default sources to download from
  • alias-global-hook is saved and restored when loading compiler extensions
  • making bootstrap automaticaly makes confclean
File size: 7.7 KB
Line 
1;;;; setup-download.scm
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 extras regex posix utils setup-utils 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                        temporary-directory)
36
37  (import scheme chicken)
38  (import extras regex posix utils setup-utils srfi-1 data-structures tcp 
39          srfi-13 files)
40
41  (tcp-connect-timeout 10000)           ; 10 seconds
42  (tcp-read-timeout 10000)
43  (tcp-write-timeout 10000)
44
45  (define *quiet* #f)
46
47  (define (d fstr . args)
48    (apply      
49     fprintf (if *quiet* (current-error-port) (current-output-port))
50     fstr args))
51     
52  (define temporary-directory (make-parameter #f))
53
54  (define (get-temporary-directory)
55    (or (temporary-directory)
56        (let ((dir (create-temporary-directory)))
57          (temporary-directory dir)
58          dir)))
59
60  (define (locate-egg/local egg dir #!optional version destination)
61    (let* ((eggdir (make-pathname dir egg))
62           (files (directory eggdir))
63           (trunkdir (make-pathname eggdir "trunk"))
64           (tagdir (make-pathname eggdir "tags"))
65           (hastrunk (and (file-exists? trunkdir) (directory? trunkdir))))
66      (or (and (file-exists? tagdir) (directory? tagdir)
67               (let ((vs (directory tagdir)))
68                 (if version
69                     (if (member version vs)
70                         (make-pathname tagdir version)
71                         (error "version not found" egg version))
72                     (let ((vs (sort vs version>=?)))
73                       (and (pair? vs)
74                            (make-pathname tagdir (car vs)))))))
75          (begin
76            (when version
77              (warning "extension has no such version - using trunk" egg version))
78            (or (and hastrunk trunkdir)
79                eggdir)))))
80 
81  (define (locate-egg/svn egg repo #!optional version destination username 
82                          password)
83    (call/cc
84     (lambda (k)
85       (define (runcmd cmd)
86         (unless (zero? (system cmd))
87           (k #f)))
88       (let* ((uarg (if username (string-append "--username='" username "'") ""))
89              (parg (if password (string-append "--password='" password "'") ""))
90              (cmd (sprintf "svn ls ~a ~a -R \"~a/~a\"" uarg parg repo egg)))
91         (d "checking available versions ...~%  ~a~%" cmd)
92         (let* ((files (with-input-from-pipe cmd read-lines))
93                (hastrunk (member "trunk/" files)) 
94                (filedir
95                 (or (let ((vs (filter-map
96                                (lambda (f)
97                                  (and-let* ((m (string-search "^tags/([^/]+)/" f)))
98                                    (cadr m)))
99                                files)))
100                       (if version
101                           (if (member version vs)
102                               (string-append "tags/" version)
103                               (error "version not found" egg version))
104                           (let ((vs (sort vs version>=?)))
105                             (and (pair? vs)
106                                  (string-append "tags/" (car vs))))))
107                     (begin
108                       (when version
109                         (warning "extension has no such version - using trunk" egg version))
110                       (and hastrunk "trunk") )
111                     ""))
112                (tmpdir (make-pathname (or destination (get-temporary-directory)) egg))
113                (cmd (sprintf "svn export ~a ~a \"~a/~a/~a\" \"~a\" ~a"
114                              uarg parg repo egg filedir 
115                              tmpdir
116                              (if *quiet* "1>&2" ""))))
117           (d "  ~a~%" cmd)
118           (runcmd cmd)
119           tmpdir)) )))
120
121  (define (locate-egg/http egg url #!optional version destination tests)
122    (let* ((tmpdir (or destination (get-temporary-directory)))
123           (m (string-match "(http://)?([^/:]+)(:([^:/]+))?(/.+)" url))
124           (host (if m (caddr m) url))
125           (port (if (and m (cadddr m)) 
126                     (or (string->number (list-ref m 4)) 
127                         (error "not a valid port" (list-ref m 4)))
128                     80))
129           (loc (string-append
130                 (if m (list-ref m 5) "/")
131                 "?name=" egg
132                 (if version
133                     (string-append "&version=" version)
134                     "")
135                 (if tests
136                     "&tests=yes"
137                     "")))
138           (eggdir (make-pathname tmpdir egg)))
139      (unless (file-exists? eggdir)
140        (create-directory eggdir))
141      (http-fetch host port loc eggdir)
142      eggdir))
143
144  (define (http-fetch host port loc dest)
145    (d "connecting to host ~s, port ~a ...~%" host port)
146    (let-values (((in out) (tcp-connect host port)))
147      (d "requesting ~s ...~%" loc)
148      (fprintf out "GET ~a HTTP/1.1\r\nConnection: close\r\nUser-Agent: chicken-install ~a\r\nAccept: */*\r\nHost: ~a:~a\r\nContent-length: 0\r\n\r\n"
149               loc (chicken-version) host port)
150      (close-output-port out)
151      (let ((chunked #f))
152        (let* ((h1 (read-line in))
153               (m (and (string? h1)
154                       (string-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" h1))))
155          (print h1)
156          ;;*** handle redirects here
157          (unless (and m (string=? "200" (cadr m)))
158            (error "invalid response from server" h1))
159          (let loop ()
160            (let ((ln (read-line in)))
161              (unless (equal? "" ln)
162                (when (string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln)
163                  (set! chunked #t))
164                (print ln)
165                (loop)))))
166        (when chunked
167          (d "reading chunks ...~%")
168          (let ((data (read-chunks in)))
169            (close-input-port in)
170            (set! in (open-input-string data))))
171        (d "reading files ...~%")
172        (let loop ((files '()))
173          (let ((name (read in)))
174            (cond ((and (pair? name) (eq? 'error (car name)))
175                   (apply
176                    error 
177                    (string-append "[Server] " (cadr name))
178                    (cddr name)))
179                  ((or (eof-object? name) (not name))
180                   (close-input-port in)
181                   (reverse files) )
182                  ((not (string? name))
183                   (error "invalid file name - possibly corrupt transmission" name))
184                  ((string-suffix? "/" name)
185                   (read in)            ; skip size
186                   (d "  ~a~%" name)
187                   (create-directory (make-pathname dest name))
188                   (loop files))
189                  (else
190                   (d "  ~a~%" name)
191                   (let* ((size (read in))
192                          (_ (read-line in))
193                          (data (read-string size in)) )
194                     (with-output-to-file (make-pathname dest name)
195                       (cut display data) ) )
196                   (loop (cons name files)))))))) )
197
198  (define (read-chunks in)
199    (let loop ((data '()))
200      (let ((size (string->number (read-line in) 16)))
201        (if (zero? size)
202            (string-concatenate-reverse data) 
203            (let ((chunk (read-string size in)))
204              (read-line in)
205              (loop (cons chunk data)))))))
206
207  (define (retrieve-extension name transport location #!key version quiet 
208                              destination username password tests)
209    (fluid-let ((*quiet* quiet))
210      (case transport
211        ((local)
212         (when destination
213           (warning "destination for transport `local' ignored"))
214         (locate-egg/local name location version destination)) 
215        ((svn)
216         (locate-egg/svn name location version destination username password))
217        ((http)
218         (locate-egg/http name location version destination tests))
219        (else (error "unsupported transport" transport)))) )
220
221)
Note: See TracBrowser for help on using the repository browser.