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

Last change on this file since 11776 was 11776, checked in by felix winkelmann, 13 years ago

-version option for new setup tools; options for credentials

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