~ chicken-core (master) /egg-download.scm
Trap1;;;; egg download2;3; Copyright (c) 2017-2022, The CHICKEN Team4; All rights reserved.5;6; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following7; conditions are met:8;9; Redistributions of source code must retain the above copyright notice, this list of conditions and the following10; disclaimer.11; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following12; 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 promote14; 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 EXPRESS17; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY18; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR19; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR20; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR21; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY22; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR23; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE24; POSSIBILITY OF SUCH DAMAGE.252627(define +default-tcp-connect-timeout+ 30000) ; 30 seconds28(define +default-tcp-read/write-timeout+ 30000) ; 30 seconds29(define +url-regex+ "(http://)?([^/:]+)(:([^:/]+))?(/.*)?")30(define +max-redirects+ 3)3132(tcp-connect-timeout +default-tcp-connect-timeout+)33(tcp-read-timeout +default-tcp-read/write-timeout+)34(tcp-write-timeout +default-tcp-read/write-timeout+)3536(define user-agent (conc "chicken-install " (chicken-version)))3738(define (deconstruct-url url)39 (let ((m (irregex-match +url-regex+ url)))40 (values41 (if m (irregex-match-substring m 2) url)42 (if (and m (irregex-match-substring m 3))43 (let ((port (irregex-match-substring m 4)))44 (or (string->number port)45 (error "not a valid port" port)))46 80)47 (or (and m (irregex-match-substring m 5))48 "/"))))4950(define (http-fetch host port locn dest proxy-host proxy-port proxy-user-pass)51 (let-values (((in out _)52 (http-connect host port locn proxy-host proxy-port53 proxy-user-pass)))54 (http-retrieve-files in out dest)))5556(define (http-query host port locn proxy-host proxy-port proxy-user-pass)57 (let-values (((in out len)58 (http-connect host port locn proxy-host proxy-port59 proxy-user-pass)))60 (close-output-port out)61 (http-retrieve-response in len)))6263(define (http-connect host port locn proxy-host proxy-port proxy-user-pass)64 (let next-req ((redirects 0)65 (host host)66 (port port)67 (locn locn)68 (req (make-HTTP-GET/1.169 locn user-agent host70 port: port accept: "*/*"71 proxy-host: proxy-host proxy-port: proxy-port)))7273 (when (= redirects +max-redirects+)74 (network-failure "too many redirects" redirects))7576 (d "connecting to host ~s, port ~a ~a...~%" host port77 (if proxy-host78 (sprintf "(via ~a:~a) " proxy-host proxy-port)79 ""))8081 (let-values (((in out)82 (tcp-connect (or proxy-host host) (or proxy-port port) 'binary)))83 (d "requesting ~s ...~%" locn)84 (display req out)85 (flush-output out)86 (d "reading response ...~%")87 (let* ((chunked #f)88 (datalen #f)89 (h1 (read-line in))90 (response-match (match-http-response h1)))9192 (define (process-headers)93 (let ((ln (read-line in)))94 (unless (equal? ln "")95 (cond ((match-chunked-transfer-encoding ln)96 (set! chunked #t))97 ((match-content-length ln) =>98 (lambda (sz) (set! datalen sz)))99 ((match-location ln) =>100 (lambda (new-locn)101 (set!-values (host port locn)102 (deconstruct-url new-locn)))))103 (d "~a~%" ln)104 (process-headers) ) ) )105106 (d "~a~%" h1)107108 (cond109 ((response-match-code? response-match 407)110 (close-input-port in)111 (close-output-port out)112113 (d "retrying with proxy auth ~a~%" locn)114 (next-req redirects host port locn115 (make-HTTP-GET/1.1116 locn user-agent host port: port117 accept: "*/*"118 proxy-host: proxy-host proxy-port: proxy-port119 proxy-user-pass: proxy-user-pass)))120121 ((or (response-match-code? response-match 301)122 (response-match-code? response-match 302))123 (process-headers)124 (close-input-port in)125 (close-output-port out)126127 (d "redirected to ~a~%" locn)128 (next-req (add1 redirects) host port locn129 (make-HTTP-GET/1.1130 locn user-agent host131 port: port accept: "*/*"132 proxy-host: proxy-host proxy-port: proxy-port)))133134 ((response-match-code? response-match 200)135 (process-headers)136 (when chunked137 (d "reading chunks ")138 (let ((data (read-chunks in)))139 (close-input-port in)140 (set! in (open-input-bytevector data))) )141 (values in out datalen))142 (else (network-failure "invalid response from server" h1)))))))143144(define (http-retrieve-files in out dest)145 (d "reading files ...~%")146 (let ((version #f)147 (ws (list->string '(#\tab #\newline #\x0b #\space #\x0c #\x0d #\xa0))))148 (define (skip)149 (let ((ln (read-line in)))150 (cond ((or (eof-object? ln)151 (irregex-match " *#!eof *" ln))152 (open-input-string ""))153 ((irregex-match " *#\\|-+ +([^| ]*) *\\|#.*" ln) =>154 (lambda (m)155 (let ((v (irregex-match-substring m 1)))156 (cond ((or (string=? "" v) (string=? "#f" v)))157 ((and version (not (string=? v version)))158 (warning "file versions are not identical"159 ln version)160 (set! version #f))161 (else162 (set! version v)))163 (open-input-string ln))))164 ((irregex-match "^[ ]*\\(error .*\\)[ ]*$" ln)165 (open-input-string ln)) ; get-files deals with errors166 ((irregex-match `(* (,ws)) ln)167 (skip)) ; Blank line.168 (else169 (error "unrecognized file-information - possibly corrupt transmission"170 ln)))))171 (let get-files ((files '()))172 (let* ((ins (skip))173 (name (read ins)))174 (cond ((and (pair? name) (eq? 'error (car name)))175 (server-error (cadr name) (cddr name)))176 ((or (eof-object? name) (not name))177 (close-input-port in)178 (close-output-port out)179 version)180 ((not (string? name))181 (error "invalid file name - possibly corrupt transmission"182 name) )183 ((string-suffix? "/" name)184 (d " ~a~%" name)185 (create-directory (make-pathname dest name))186 (get-files files) )187 (else188 (let* ((size (read ins))189 (_ (d " ~a (~a bytes)~%" name size))190 (data (read-bytevector size in)) )191 (with-output-to-file (make-pathname dest name)192 (lambda ()193 (if (eof-object? data)194 (display "")195 (write-bytevector data)))196 #:binary ) )197 (get-files (cons name files)) ) ) ) ) ))198199(define (http-retrieve-response in len)200 (d "reading response ...~%")201 (let ((data (read-string len in)))202 (close-input-port in)203 data))204205(define (server-error msg args)206 (abort207 (make-composite-condition208 (make-property-condition209 'exn210 'message (string-append "[Server] " msg)211 'arguments args)212 (make-property-condition 'setup-download-error))))213214(define (read-chunks in)215 (let get-chunks ((data '()))216 (let* ((line (read-line in))217 (size (and (not (eof-object? line))218 (string->number line 16))))219 (cond ((not size)220 (error "invalid response from server - please try again"))221 ((zero? size)222 (d "~%")223 (apply bytevector-append (reverse data)))224 (else225 (let ((chunk (read-bytevector size in)))226 (d ".")227 (read-line in)228 (get-chunks (cons chunk data)) ) ) ) ) ))229230(define (match-http-response rsp)231 (and (string? rsp)232 (irregex-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )233234(define (response-match-code? mrsp code)235 (and mrsp (string=? (number->string code)236 (irregex-match-substring mrsp 1))) )237238(define (match-chunked-transfer-encoding ln)239 (irregex-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )240241(define (match-location ln)242 (let ((m (irregex-match "[Ll]ocation:\\s*(.+)\\s*" ln)))243 (and m (irregex-match-substring m 1))))244245(define (match-content-length ln)246 (let ((m (irregex-match "[Cc]ontent-[Ll]ength:\\s*([0-9]+).*" ln)))247 (and m (string->number (irregex-match-substring m 1)))))248249(define (make-HTTP-GET/1.1 location user-agent host250 #!key251 (port 80)252 (connection "close")253 (accept "*")254 (content-length 0)255 proxy-host proxy-port proxy-user-pass)256 (conc257 "GET "258 (if proxy-host259 (string-append "http://" host location)260 location)261 " HTTP/1.1" "\r\n"262 "Connection: " connection "\r\n"263 "User-Agent: " user-agent "\r\n"264 "Accept: " accept "\r\n"265 "Host: " host #\: port "\r\n"266 (if proxy-user-pass267 (string-append "Proxy-Authorization: Basic " proxy-user-pass "\r\n")268 "")269 "Content-length: " content-length "\r\n"270 "\r\n") )271272(define (network-failure msg . args)273 (signal274 (make-composite-condition275 (make-property-condition276 'exn277 'message msg278 'arguments args)279 (make-property-condition 'http-fetch))) )280281282;; entry points283284(define (list-versions egg url)285 (receive (host port locn) (deconstruct-url url)286 (let ((locn (conc locn287 "?name=" egg288 "&release=" major-version289 "&mode=default"290 "&listversions=1")))291 (let ((data (http-query host port locn proxy-host292 proxy-port proxy-user-pass)))293 (string-split data)))))294295(define (try-list-versions name url #!key296 proxy-host proxy-port proxy-user-pass)297 (d "listing versions for ~a: ~a~%" name url)298 (condition-case (list-versions name url)299 ((exn net)300 (print "TCP connect timeout")301 #f)302 ((exn http-fetch)303 (print "HTTP protocol error")304 #f)305 (e (exn setup-download-error)306 (print "Server error:")307 (print-error-message e)308 #f)309 (e () (abort e) )))310311(define (download-egg egg url #!key version destination tests312 proxy-host proxy-port proxy-user-pass)313 (receive (host port locn) (deconstruct-url url)314 (let* ((locn (conc locn315 "?name=" egg316 "&release=" major-version317 (if version (string-append "&version=" version) "")318 "&mode=default"319 (if tests "&tests=yes" "")))320 (eggdir destination))321 (let ((fversion (http-fetch host port locn eggdir proxy-host322 proxy-port proxy-user-pass)))323 ;; If we get here then version of egg exists324 (values eggdir (or fversion version "")) )) ) )325326(define (try-download name url #!key version destination tests327 proxy-host proxy-port proxy-user-pass)328 (d "downloading ~a: ~a~%" name url)329 (condition-case330 (download-egg331 name url332 version: version333 destination: destination334 tests: tests335 proxy-host: proxy-host336 proxy-port: proxy-port337 proxy-user-pass: proxy-user-pass)338 ((exn net)339 (print "TCP connect timeout")340 (values #f "") )341 ((exn http-fetch)342 (print "HTTP protocol error")343 (values #f "") )344 (e (exn setup-download-error)345 (print "Server error:")346 (print-error-message e)347 (values #f ""))348 (e () (abort e) )))