~ chicken-core (chicken-5) /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))))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-string 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 (define (skip)148 (let ((ln (read-line in)))149 (cond ((or (eof-object? ln)150 (irregex-match " *#!eof *" ln))151 (open-input-string ""))152 ((irregex-match " *#\\|-+ +([^| ]*) *\\|#.*" ln) =>153 (lambda (m)154 (let ((v (irregex-match-substring m 1)))155 (cond ((or (string=? "" v) (string=? "#f" v)))156 ((and version (not (string=? v version)))157 (warning "files versions are not identical"158 ln version)159 (set! version #f))160 (else161 (set! version v)))162 (open-input-string ln))))163 ((irregex-match "^[ ]*\\(error .*\\)[ ]*$" ln)164 (open-input-string ln)) ; get-files deals with errors165 ((irregex-match '(* ("\x09\x0a\x0b\x0c\x0d\x20\xa0")) ln)166 (skip)) ; Blank line.167 (else168 (error "unrecognized file-information - possibly corrupt transmission"169 ln)))))170 (let get-files ((files '()))171 (let* ((ins (skip))172 (name (read ins)))173 (cond ((and (pair? name) (eq? 'error (car name)))174 (server-error (cadr name) (cddr name)))175 ((or (eof-object? name) (not name))176 (close-input-port in)177 (close-output-port out)178 version)179 ((not (string? name))180 (error "invalid file name - possibly corrupt transmission"181 name) )182 ((string-suffix? "/" name)183 (d " ~a~%" name)184 (create-directory (make-pathname dest name))185 (get-files files) )186 (else187 (d " ~a~%" name)188 (let* ((size (read ins))189 (data (read-string size in)) )190 (with-output-to-file (make-pathname dest name)191 (cut display data) #:binary ) )192 (get-files (cons name files)) ) ) ) ) ))193194(define (http-retrieve-response in len)195 (d "reading response ...~%")196 (let ((data (read-string len in)))197 (close-input-port in)198 data))199200(define (server-error msg args)201 (abort202 (make-composite-condition203 (make-property-condition204 'exn205 'message (string-append "[Server] " msg)206 'arguments args)207 (make-property-condition 'setup-download-error))))208209(define (read-chunks in)210 (let get-chunks ((data '()))211 (let* ((line (read-line in))212 (size (and (not (eof-object? line))213 (string->number line 16))))214 (cond ((not size)215 (error "invalid response from server - please try again"))216 ((zero? size)217 (d "~%")218 (string-intersperse (reverse data) ""))219 (else220 (let ((chunk (read-string size in)))221 (d ".")222 (read-line in)223 (get-chunks (cons chunk data)) ) ) ) ) ))224225(define (match-http-response rsp)226 (and (string? rsp)227 (irregex-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )228229(define (response-match-code? mrsp code)230 (and mrsp (string=? (number->string code)231 (irregex-match-substring mrsp 1))) )232233(define (match-chunked-transfer-encoding ln)234 (irregex-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )235236(define (match-location ln)237 (let ((m (irregex-match "[Ll]ocation:\\s*(.+)\\s*" ln)))238 (and m (irregex-match-substring m 1))))239240(define (match-content-length ln)241 (let ((m (irregex-match "[Cc]ontent-[Ll]ength:\\s*([0-9]+).*" ln)))242 (and m (string->number (irregex-match-substring m 1)))))243244(define (make-HTTP-GET/1.1 location user-agent host245 #!key246 (port 80)247 (connection "close")248 (accept "*")249 (content-length 0)250 proxy-host proxy-port proxy-user-pass)251 (conc252 "GET "253 (if proxy-host254 (string-append "http://" host location)255 location)256 " HTTP/1.1" "\r\n"257 "Connection: " connection "\r\n"258 "User-Agent: " user-agent "\r\n"259 "Accept: " accept "\r\n"260 "Host: " host #\: port "\r\n"261 (if proxy-user-pass262 (string-append "Proxy-Authorization: Basic " proxy-user-pass "\r\n")263 "")264 "Content-length: " content-length "\r\n"265 "\r\n") )266267(define (network-failure msg . args)268 (signal269 (make-composite-condition270 (make-property-condition271 'exn272 'message "invalid response from server"273 'arguments args)274 (make-property-condition 'http-fetch))) )275276277;; entry points278279(define (list-versions egg url)280 (receive (host port locn) (deconstruct-url url)281 (let ((locn (conc locn282 "?name=" egg283 "&release=" major-version284 "&mode=default"285 "&listversions=1")))286 (let ((data (http-query host port locn proxy-host287 proxy-port proxy-user-pass)))288 (string-split data)))))289290(define (try-list-versions name url #!key291 proxy-host proxy-port proxy-user-pass)292 (d "listing versions for ~a: ~a~%" name url)293 (condition-case (list-versions name url)294 ((exn net)295 (print "TCP connect timeout")296 #f)297 ((exn http-fetch)298 (print "HTTP protocol error")299 #f)300 (e (exn setup-download-error)301 (print "Server error:")302 (print-error-message e)303 #f)304 (e () (abort e) )))305306(define (download-egg egg url #!key version destination tests307 proxy-host proxy-port proxy-user-pass)308 (receive (host port locn) (deconstruct-url url)309 (let* ((locn (conc locn310 "?name=" egg311 "&release=" major-version312 (if version (string-append "&version=" version) "")313 "&mode=default"314 (if tests "&tests=yes" "")))315 (eggdir destination))316 (let ((fversion (http-fetch host port locn eggdir proxy-host317 proxy-port proxy-user-pass)))318 ;; If we get here then version of egg exists319 (values eggdir (or fversion version "")) )) ) )320321(define (try-download name url #!key version destination tests322 proxy-host proxy-port proxy-user-pass)323 (d "downloading ~a: ~a~%" name url)324 (condition-case325 (download-egg326 name url327 version: version328 destination: destination329 tests: tests330 proxy-host: proxy-host331 proxy-port: proxy-port332 proxy-user-pass: proxy-user-pass)333 ((exn net)334 (print "TCP connect timeout")335 (values #f "") )336 ((exn http-fetch)337 (print "HTTP protocol error")338 (values #f "") )339 (e (exn setup-download-error)340 (print "Server error:")341 (print-error-message e)342 (values #f ""))343 (e () (abort e) )))