guix/build/download-nar.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix build download-nar)
  20   #:use-module (guix build download)
  21   #:use-module (guix build utils)
  22   #:use-module (guix serialization)
  23   #:use-module (guix zlib)
  24   #:use-module (guix progress)
  25   #:use-module (web uri)
  26   #:use-module (srfi srfi-11)
  27   #:use-module (srfi srfi-26)
  28   #:use-module (ice-9 format)
  29   #:use-module (ice-9 match)
  30   #:export (download-nar))
  31
  32 ;;; Commentary:
  33 ;;;
  34 ;;; Download a normalized archive or "nar", similar to what 'guix substitute'
  35 ;;; does.  The intent here is to use substitute servers as content-addressed
  36 ;;; mirrors of VCS checkouts.  This is mostly useful for users who have
  37 ;;; disabled substitutes.
  38 ;;;
  39 ;;; Code:
  40
  41 (define (urls-for-item item)
  42   "Return the fallback nar URL for ITEM--e.g.,
  43 \"/gnu/store/cabbag3…-foo-1.2-checkout\"."
  44   ;; Here we hard-code nar URLs without checking narinfos.  That's probably OK
  45   ;; though.  Use berlin.guix.gnu.org instead of its ci.guix.gnu.org front end to
  46   ;; avoid sending these requests to CDN providers without user consent.
  47   ;; TODO: Use HTTPS?  The downside is the extra dependency.
  48   (let ((bases '("http://berlin.guix.gnu.org"))
  49         (item  (basename item)))
  50     (append (map (cut string-append <> "/nar/gzip/" item) bases)
  51             (map (cut string-append <> "/nar/" item) bases))))
  52
  53 (define (restore-gzipped-nar port item size)
  54   "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to
  55 ITEM."
  56   ;; Since PORT is typically a non-file port (for instance because 'http-get'
  57   ;; returns a delimited port), create a child process so we're back to a file
  58   ;; port that can be passed to 'call-with-gzip-input-port'.
  59   (match (pipe)
  60     ((input . output)
  61      (match (primitive-fork)
  62        (0
  63         (dynamic-wind
  64           (const #t)
  65           (lambda ()
  66             (close-port output)
  67             (close-port port)
  68             (catch #t
  69               (lambda ()
  70                 (call-with-gzip-input-port input
  71                   (cut restore-file <> item)))
  72               (lambda (key . args)
  73                 (print-exception (current-error-port)
  74                                  (stack-ref (make-stack #t) 1)
  75                                  key args)
  76                 (primitive-exit 1))))
  77           (lambda ()
  78             (primitive-exit 0))))
  79        (child
  80         (close-port input)
  81         (dump-port* port output
  82                     #:reporter (progress-reporter/file item size
  83                                                        #:abbreviation
  84                                                        store-path-abbreviation))
  85         (close-port output)
  86         (newline)
  87         (match (waitpid child)
  88           ((_ . status)
  89            (unless (zero? status)
  90              (error "nar decompression failed" status)))))))))
  91
  92 (define (download-nar item)
  93   "Download and extract the normalized archive for ITEM.  Return #t on
  94 success, #f otherwise."
  95   ;; Let progress reports go through.
  96   (setvbuf (current-error-port) 'none)
  97   (setvbuf (current-output-port) 'none)
  98
  99   (let loop ((urls (urls-for-item item)))
 100     (match urls
 101       ((url rest ...)
 102        (format #t "Trying content-addressed mirror at ~a...~%"
 103                (uri-host (string->uri url)))
 104        (let-values (((port size)
 105                      (catch #t
 106                        (lambda ()
 107                          (http-fetch (string->uri url)))
 108                        (lambda args
 109                          (values #f #f)))))
 110          (if (not port)
 111              (loop rest)
 112              (begin
 113                (if size
 114                    (format #t "Downloading from ~a (~,2h MiB)...~%" url
 115                            (/ size (expt 2 20.)))
 116                    (format #t "Downloading from ~a...~%" url))
 117                (if (string-contains url "/gzip")
 118                    (restore-gzipped-nar port item size)
 119                    (begin
 120                      ;; FIXME: Add progress report.
 121                      (restore-file port item)
 122                      (close-port port)))
 123                #t))))
 124       (()
 125        #f))))