123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126 |
- (define-module (guix build download-nar)
- #:use-module (guix build download)
- #:use-module (guix build utils)
- #:use-module ((guix serialization) #:hide (dump-port*))
- #:autoload (zlib) (call-with-gzip-input-port)
- #:use-module (guix progress)
- #:use-module (web uri)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:use-module (ice-9 format)
- #:use-module (ice-9 match)
- #:export (download-nar))
- (define (urls-for-item item)
- "Return the fallback nar URL for ITEM--e.g.,
- \"/gnu/store/cabbag3…-foo-1.2-checkout\"."
-
-
-
-
- (let ((bases '("http://berlin.guix.gnu.org"))
- (item (basename item)))
- (append (map (cut string-append <> "/nar/gzip/" item) bases)
- (map (cut string-append <> "/nar/" item) bases))))
- (define (restore-gzipped-nar port item size)
- "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to
- ITEM."
-
-
-
- (match (pipe)
- ((input . output)
- (match (primitive-fork)
- (0
- (dynamic-wind
- (const #t)
- (lambda ()
- (close-port output)
- (close-port port)
- (catch #t
- (lambda ()
- (call-with-gzip-input-port input
- (cut restore-file <> item)))
- (lambda (key . args)
- (print-exception (current-error-port)
- (stack-ref (make-stack #t) 1)
- key args)
- (primitive-exit 1))))
- (lambda ()
- (primitive-exit 0))))
- (child
- (close-port input)
- (dump-port* port output
- #:reporter (progress-reporter/file item size
- #:abbreviation
- store-path-abbreviation))
- (close-port output)
- (newline)
- (match (waitpid child)
- ((_ . status)
- (unless (zero? status)
- (error "nar decompression failed" status)))))))))
- (define (download-nar item)
- "Download and extract the normalized archive for ITEM. Return #t on
- success, #f otherwise."
-
- (setvbuf (current-error-port) 'none)
- (setvbuf (current-output-port) 'none)
- (let loop ((urls (urls-for-item item)))
- (match urls
- ((url rest ...)
- (format #t "Trying content-addressed mirror at ~a...~%"
- (uri-host (string->uri url)))
- (let-values (((port size)
- (catch #t
- (lambda ()
- (http-fetch (string->uri url)))
- (lambda args
- (values #f #f)))))
- (if (not port)
- (loop rest)
- (begin
- (if size
- (format #t "Downloading from ~a (~,2h MiB)...~%" url
- (/ size (expt 2 20.)))
- (format #t "Downloading from ~a...~%" url))
- (if (string-contains url "/gzip")
- (restore-gzipped-nar port item size)
- (begin
-
- (restore-file port item)
- (close-port port)))
- #t))))
- (()
- #f))))
|