source: project/chicken/branches/hygienic/setup-download.scm @ 11978

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

bugfix in setup-download module

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