~ 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 () (write-bytevector data))193 #:binary ) )194 (get-files (cons name files)) ) ) ) ) ))195196(define (http-retrieve-response in len)197 (d "reading response ...~%")198 (let ((data (read-string len in)))199 (close-input-port in)200 data))201202(define (server-error msg args)203 (abort204 (make-composite-condition205 (make-property-condition206 'exn207 'message (string-append "[Server] " msg)208 'arguments args)209 (make-property-condition 'setup-download-error))))210211(define (read-chunks in)212 (let get-chunks ((data '()))213 (let* ((line (read-line in))214 (size (and (not (eof-object? line))215 (string->number line 16))))216 (cond ((not size)217 (error "invalid response from server - please try again"))218 ((zero? size)219 (d "~%")220 (apply bytevector-append (reverse data)))221 (else222 (let ((chunk (read-bytevector size in)))223 (d ".")224 (read-line in)225 (get-chunks (cons chunk data)) ) ) ) ) ))226227(define (match-http-response rsp)228 (and (string? rsp)229 (irregex-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )230231(define (response-match-code? mrsp code)232 (and mrsp (string=? (number->string code)233 (irregex-match-substring mrsp 1))) )234235(define (match-chunked-transfer-encoding ln)236 (irregex-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )237238(define (match-location ln)239 (let ((m (irregex-match "[Ll]ocation:\\s*(.+)\\s*" ln)))240 (and m (irregex-match-substring m 1))))241242(define (match-content-length ln)243 (let ((m (irregex-match "[Cc]ontent-[Ll]ength:\\s*([0-9]+).*" ln)))244 (and m (string->number (irregex-match-substring m 1)))))245246(define (make-HTTP-GET/1.1 location user-agent host247 #!key248 (port 80)249 (connection "close")250 (accept "*")251 (content-length 0)252 proxy-host proxy-port proxy-user-pass)253 (conc254 "GET "255 (if proxy-host256 (string-append "http://" host location)257 location)258 " HTTP/1.1" "\r\n"259 "Connection: " connection "\r\n"260 "User-Agent: " user-agent "\r\n"261 "Accept: " accept "\r\n"262 "Host: " host #\: port "\r\n"263 (if proxy-user-pass264 (string-append "Proxy-Authorization: Basic " proxy-user-pass "\r\n")265 "")266 "Content-length: " content-length "\r\n"267 "\r\n") )268269(define (network-failure msg . args)270 (signal271 (make-composite-condition272 (make-property-condition273 'exn274 'message msg275 'arguments args)276 (make-property-condition 'http-fetch))) )277278279;; entry points280281(define (list-versions egg url)282 (receive (host port locn) (deconstruct-url url)283 (let ((locn (conc locn284 "?name=" egg285 "&release=" major-version286 "&mode=default"287 "&listversions=1")))288 (let ((data (http-query host port locn proxy-host289 proxy-port proxy-user-pass)))290 (string-split data)))))291292(define (try-list-versions name url #!key293 proxy-host proxy-port proxy-user-pass)294 (d "listing versions for ~a: ~a~%" name url)295 (condition-case (list-versions name url)296 ((exn net)297 (print "TCP connect timeout")298 #f)299 ((exn http-fetch)300 (print "HTTP protocol error")301 #f)302 (e (exn setup-download-error)303 (print "Server error:")304 (print-error-message e)305 #f)306 (e () (abort e) )))307308(define (download-egg egg url #!key version destination tests309 proxy-host proxy-port proxy-user-pass)310 (receive (host port locn) (deconstruct-url url)311 (let* ((locn (conc locn312 "?name=" egg313 "&release=" major-version314 (if version (string-append "&version=" version) "")315 "&mode=default"316 (if tests "&tests=yes" "")))317 (eggdir destination))318 (let ((fversion (http-fetch host port locn eggdir proxy-host319 proxy-port proxy-user-pass)))320 ;; If we get here then version of egg exists321 (values eggdir (or fversion version "")) )) ) )322323(define (try-download name url #!key version destination tests324 proxy-host proxy-port proxy-user-pass)325 (d "downloading ~a: ~a~%" name url)326 (condition-case327 (download-egg328 name url329 version: version330 destination: destination331 tests: tests332 proxy-host: proxy-host333 proxy-port: proxy-port334 proxy-user-pass: proxy-user-pass)335 ((exn net)336 (print "TCP connect timeout")337 (values #f "") )338 ((exn http-fetch)339 (print "HTTP protocol error")340 (values #f "") )341 (e (exn setup-download-error)342 (print "Server error:")343 (print-error-message e)344 (values #f ""))345 (e () (abort e) )))