source: project/chicken/branches/prerelease/setup-download.scm @ 13240

Last change on this file since 13240 was 13240, checked in by felix winkelmann, 11 years ago

merged trunk svn rev. 13239 into prerelease

File size: 9.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                        list-extensions
36                        temporary-directory)
37
38  (import scheme chicken)
39  (import extras regex posix utils srfi-1 data-structures tcp 
40          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 (d fstr . args)
49    (apply      
50     fprintf (if *quiet* (current-error-port) (current-output-port))
51     fstr args))
52     
53  (define temporary-directory (make-parameter #f))
54
55  (define (get-temporary-directory)
56    (or (temporary-directory)
57        (let ((dir (create-temporary-directory)))
58          (temporary-directory dir)
59          dir)))
60
61  (define (list-eggs/local dir)
62    (string-concatenate
63     (map (cut string-append <> "\n")
64          (directory dir))))
65
66  (define (locate-egg/local egg dir #!optional version destination)
67    (let* ((eggdir (make-pathname dir egg))
68           (files (directory eggdir))
69           (trunkdir (make-pathname eggdir "trunk"))
70           (tagdir (make-pathname eggdir "tags"))
71           (hastrunk (and (file-exists? trunkdir) (directory? trunkdir))))
72      (or (and (file-exists? tagdir) (directory? tagdir)
73               (let ((vs (directory tagdir)))
74                 (if version
75                     (if (member version vs)
76                         (make-pathname tagdir version)
77                         (error "version not found" egg version))
78                     (let ((vs (sort vs version>=?)))
79                       (and (pair? vs)
80                            (make-pathname tagdir (car vs)))))))
81          (begin
82            (when version
83              (warning "extension has no such version - using trunk" egg version))
84            (or (and hastrunk trunkdir)
85                eggdir)))))
86
87  (define (list-eggs/svn repo #!optional username password)
88    (call/cc
89     (lambda (k)
90       (define (runcmd cmd)
91         (unless (zero? (system cmd))
92           (k #f)))
93       (let* ((uarg (if username (string-append "--username='" username "'") ""))
94              (parg (if password (string-append "--password='" password "'") ""))
95              (cmd (sprintf "svn ls ~a ~a ~a" uarg parg (qs repo))))
96         (d "listing extension directory ...~%  ~a~%" cmd)
97         (string-concatenate
98          (map (lambda (str) (string-append (string-chomp str "/") "\n"))
99               (with-input-from-pipe cmd read-lines)))))))
100 
101  (define (locate-egg/svn egg repo #!optional version destination username 
102                          password)
103    (call/cc
104     (lambda (k)
105       (define (runcmd cmd)
106         (unless (zero? (system cmd))
107           (k #f)))
108       (let* ((uarg (if username (string-append "--username='" username "'") ""))
109              (parg (if password (string-append "--password='" password "'") ""))
110              (cmd (sprintf "svn ls ~a ~a -R ~a" uarg parg (qs (make-pathname repo egg)))))
111         (d "checking available versions ...~%  ~a~%" cmd)
112         (let* ((files (with-input-from-pipe cmd read-lines))
113                (hastrunk (member "trunk/" files)) 
114                (filedir
115                 (or (let ((vs (filter-map
116                                (lambda (f)
117                                  (and-let* ((m (string-search "^tags/([^/]+)/" f)))
118                                    (cadr m)))
119                                files)))
120                       (if version
121                           (if (member version vs)
122                               (string-append "tags/" version)
123                               (error "version not found" egg version))
124                           (let ((vs (sort vs version>=?)))
125                             (and (pair? vs)
126                                  (string-append "tags/" (car vs))))))
127                     (begin
128                       (when version
129                         (warning "extension has no such version - using trunk" egg version))
130                       (and hastrunk "trunk") )
131                     ""))
132                (tmpdir (make-pathname (or destination (get-temporary-directory)) egg))
133                (cmd (sprintf "svn export ~a ~a \"~a/~a/~a\" \"~a\" ~a"
134                              uarg parg repo egg filedir 
135                              tmpdir
136                              (if *quiet* "1>&2" ""))))
137           (d "  ~a~%" cmd)
138           (runcmd cmd)
139           tmpdir)) )))
140
141  (define (deconstruct-url url)
142    (let ((m (string-match "(http://)?([^/:]+)(:([^:/]+))?(/.+)" url)))
143      (values
144       (if m (caddr m) url)
145       (if (and m (cadddr m)) 
146           (or (string->number (list-ref m 4)) 
147               (error "not a valid port" (list-ref m 4)))
148           80)
149       (if m (list-ref m 5) "/"))))
150
151  (define (locate-egg/http egg url #!optional version destination tests)
152    (let ((tmpdir (or destination (get-temporary-directory))))
153      (let-values (((host port loc) (deconstruct-url url)))
154        (let ((loc (string-append
155                    loc
156                    "?name=" egg
157                    (if version
158                        (string-append "&version=" version)
159                        "")
160                    (if tests
161                        "&tests=yes"
162                        "")))
163              (eggdir (make-pathname tmpdir egg)))
164          (unless (file-exists? eggdir)
165            (create-directory eggdir))
166          (http-fetch host port loc eggdir)
167          eggdir))))
168
169  (define (network-failure msg . args)
170    (signal
171     (make-composite-condition
172      (make-property-condition
173       'exn 'message "invalid response from server" 
174       'arguments args)
175      (make-property-condition 'http-fetch))))
176
177  (define (http-fetch host port loc dest)
178    (d "connecting to host ~s, port ~a ...~%" host port)
179    (let-values (((in out) (tcp-connect host port)))
180      (d "requesting ~s ...~%" loc)
181      (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"
182               loc (chicken-version) host port)
183      (close-output-port out)
184      (let ((chunked #f))
185        (let* ((h1 (read-line in))
186               (m (and (string? h1)
187                       (string-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" h1))))
188          (print h1)
189          ;;*** handle redirects here
190          (unless (and m (string=? "200" (cadr m)))
191            (network-failure "invalid response from server" h1))
192          (let loop ()
193            (let ((ln (read-line in)))
194              (unless (equal? "" ln)
195                (when (string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln)
196                  (set! chunked #t))
197                (print ln)
198                (loop)))))
199        (when chunked
200          (d "reading chunks ...~%")
201          (let ((data (read-chunks in)))
202            (close-input-port in)
203            (set! in (open-input-string data))))
204        (d "reading files ...~%")
205        (let loop ((files '()))
206          (let ((name (read in)))
207            (cond ((and (pair? name) (eq? 'error (car name)))
208                   (apply
209                    error 
210                    (string-append "[Server] " (cadr name))
211                    (cddr name)))
212                  ((or (eof-object? name) (not name))
213                   (close-input-port in)
214                   (reverse files) )
215                  ((not (string? name))
216                   (error "invalid file name - possibly corrupt transmission" name))
217                  ((string-suffix? "/" name)
218                   (read in)            ; skip size
219                   (d "  ~a~%" name)
220                   (create-directory (make-pathname dest name))
221                   (loop files))
222                  (else
223                   (d "  ~a~%" name)
224                   (let* ((size (read in))
225                          (_ (read-line in))
226                          (data (read-string size in)) )
227                     (with-output-to-file (make-pathname dest name)
228                       (cut display data) ) )
229                   (loop (cons name files)))))))) )
230
231  (define (read-chunks in)
232    (let loop ((data '()))
233      (let ((size (string->number (read-line in) 16)))
234        (if (zero? size)
235            (string-concatenate-reverse data) 
236            (let ((chunk (read-string size in)))
237              (read-line in)
238              (loop (cons chunk data)))))))
239
240  (define (retrieve-extension name transport location #!key version quiet 
241                              destination username password tests)
242    (fluid-let ((*quiet* quiet))
243      (case transport
244        ((local)
245         (when destination
246           (warning "destination for transport `local' ignored"))
247         (locate-egg/local name location version destination)) 
248        ((svn)
249         (locate-egg/svn name location version destination username password))
250        ((http)
251         (locate-egg/http name location version destination tests))
252        (else (error "cannot retrieve extension unsupported transport" transport)))) )
253
254  (define (list-extensions transport location #!key quiet username password)
255    (fluid-let ((*quiet* quiet))
256      (case transport
257        ((local)
258         (list-eggs/local location)) 
259        ((svn)
260         (list-eggs/svn location username password))
261        (else (error "cannot list extensions - unsupported transport" transport)))) )
262
263)
Note: See TracBrowser for help on using the repository browser.