download: Download a nar when a VCS checkout fails.
Fixes <https://bugs.gnu.org/28709>. * guix/build/download-nar.scm: New file. * Makefile.am (MODULES): Add it. * guix/cvs-download.scm (cvs-fetch)[zlib, config.scm, modules]: New variables. [build]: Use MODULES. Add call to 'download-nar'. * guix/git-download.scm (git-fetch): Likewise. * guix/hg-download.scm (hg-fetch): Likewise.
This commit is contained in:
Ludovic Courtès
Ludovic Courtès
parent
8c3488259e
commit
37ce440dcf
|
|
@ -106,6 +106,7 @@ MODULES = \
|
|||
guix/ui.scm \
|
||||
guix/build/ant-build-system.scm \
|
||||
guix/build/download.scm \
|
||||
guix/build/download-nar.scm \
|
||||
guix/build/cargo-build-system.scm \
|
||||
guix/build/cmake-build-system.scm \
|
||||
guix/build/dub-build-system.scm \
|
||||
|
|
|
|||
|
|
@ -0,0 +1,125 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (guix build download-nar)
|
||||
#:use-module (guix build download)
|
||||
#:use-module (guix build utils)
|
||||
#:use-module (guix serialization)
|
||||
#:use-module (guix zlib)
|
||||
#: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))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; Download a normalized archive or "nar", similar to what 'guix substitute'
|
||||
;;; does. The intent here is to use substitute servers as content-addressed
|
||||
;;; mirrors of VCS checkouts. This is mostly useful for users who have
|
||||
;;; disabled substitutes.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define (urls-for-item item)
|
||||
"Return the fallback nar URL for ITEM--e.g.,
|
||||
\"/gnu/store/cabbag3…-foo-1.2-checkout\"."
|
||||
;; Here we hard-code nar URLs without checking narinfos. That's probably OK
|
||||
;; though.
|
||||
;; TODO: Use HTTPS? The downside is the extra dependency.
|
||||
(let ((bases '("http://mirror.hydra.gnu.org/guix"
|
||||
"http://berlin.guixsd.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."
|
||||
;; Since PORT is typically a non-file port (for instance because 'http-get'
|
||||
;; returns a delimited port), create a child process so we're back to a file
|
||||
;; port that can be passed to 'call-with-gzip-input-port'.
|
||||
(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."
|
||||
;; Let progress reports go through.
|
||||
(setvbuf (current-error-port) _IONBF)
|
||||
(setvbuf (current-output-port) _IONBF)
|
||||
|
||||
(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
|
||||
;; FIXME: Add progress report.
|
||||
(restore-file port item)
|
||||
(close-port port)))
|
||||
#t))))
|
||||
(()
|
||||
#f))))
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
|
||||
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
|
||||
;;;
|
||||
|
|
@ -23,6 +23,7 @@
|
|||
#:use-module (guix gexp)
|
||||
#:use-module (guix store)
|
||||
#:use-module (guix monads)
|
||||
#:use-module (guix modules)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (cvs-reference
|
||||
|
|
@ -59,16 +60,35 @@
|
|||
"Return a fixed-output derivation that fetches REF, a <cvs-reference>
|
||||
object. The output is expected to have recursive hash HASH of type
|
||||
HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
|
||||
(define zlib
|
||||
(module-ref (resolve-interface '(gnu packages compression)) 'zlib))
|
||||
|
||||
(define config.scm
|
||||
(scheme-file "config.scm"
|
||||
#~(begin
|
||||
(define-module (guix config)
|
||||
#:export (%libz))
|
||||
|
||||
(define %libz
|
||||
#+(file-append zlib "/lib/libz")))))
|
||||
|
||||
(define modules
|
||||
(cons `((guix config) => ,config.scm)
|
||||
(delete '(guix config)
|
||||
(source-module-closure '((guix build cvs)
|
||||
(guix build download-nar))))))
|
||||
(define build
|
||||
(with-imported-modules '((guix build cvs)
|
||||
(guix build utils))
|
||||
(with-imported-modules modules
|
||||
#~(begin
|
||||
(use-modules (guix build cvs))
|
||||
(cvs-fetch '#$(cvs-reference-root-directory ref)
|
||||
'#$(cvs-reference-module ref)
|
||||
'#$(cvs-reference-revision ref)
|
||||
#$output
|
||||
#:cvs-command (string-append #+cvs "/bin/cvs")))))
|
||||
(use-modules (guix build cvs)
|
||||
(guix build download-nar))
|
||||
|
||||
(or (cvs-fetch '#$(cvs-reference-root-directory ref)
|
||||
'#$(cvs-reference-module ref)
|
||||
'#$(cvs-reference-revision ref)
|
||||
#$output
|
||||
#:cvs-command (string-append #+cvs "/bin/cvs"))
|
||||
(download-nar #$output)))))
|
||||
|
||||
(mlet %store-monad ((guile (package->derivation guile system)))
|
||||
(gexp->derivation (or name "cvs-checkout") build
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@
|
|||
#:use-module (guix monads)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix modules)
|
||||
#:autoload (guix build-system gnu) (standard-packages)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 popen)
|
||||
|
|
@ -77,12 +78,31 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
|
|||
(standard-packages)
|
||||
'()))
|
||||
|
||||
(define zlib
|
||||
(module-ref (resolve-interface '(gnu packages compression)) 'zlib))
|
||||
|
||||
(define config.scm
|
||||
(scheme-file "config.scm"
|
||||
#~(begin
|
||||
(define-module (guix config)
|
||||
#:export (%libz))
|
||||
|
||||
(define %libz
|
||||
#+(file-append zlib "/lib/libz")))))
|
||||
|
||||
(define modules
|
||||
(cons `((guix config) => ,config.scm)
|
||||
(delete '(guix config)
|
||||
(source-module-closure '((guix build git)
|
||||
(guix build utils)
|
||||
(guix build download-nar))))))
|
||||
|
||||
(define build
|
||||
(with-imported-modules '((guix build git)
|
||||
(guix build utils))
|
||||
(with-imported-modules modules
|
||||
#~(begin
|
||||
(use-modules (guix build git)
|
||||
(guix build utils)
|
||||
(guix build download-nar)
|
||||
(ice-9 match))
|
||||
|
||||
;; The 'git submodule' commands expects Coreutils, sed,
|
||||
|
|
@ -92,12 +112,13 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
|
|||
(((names dirs) ...)
|
||||
dirs)))
|
||||
|
||||
(git-fetch (getenv "git url") (getenv "git commit")
|
||||
#$output
|
||||
#:recursive? (call-with-input-string
|
||||
(getenv "git recursive?")
|
||||
read)
|
||||
#:git-command (string-append #+git "/bin/git")))))
|
||||
(or (git-fetch (getenv "git url") (getenv "git commit")
|
||||
#$output
|
||||
#:recursive? (call-with-input-string
|
||||
(getenv "git recursive?")
|
||||
read)
|
||||
#:git-command (string-append #+git "/bin/git"))
|
||||
(download-nar #$output)))))
|
||||
|
||||
(mlet %store-monad ((guile (package->derivation guile system)))
|
||||
(gexp->derivation (or name "git-checkout") build
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
|
|
@ -22,6 +22,7 @@
|
|||
#:use-module (guix store)
|
||||
#:use-module (guix monads)
|
||||
#:use-module (guix records)
|
||||
#:use-module (guix modules)
|
||||
#:use-module (guix packages)
|
||||
#:autoload (guix build-system gnu) (standard-packages)
|
||||
#:use-module (ice-9 match)
|
||||
|
|
@ -59,18 +60,35 @@
|
|||
"Return a fixed-output derivation that fetches REF, a <hg-reference>
|
||||
object. The output is expected to have recursive hash HASH of type
|
||||
HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
|
||||
(define zlib
|
||||
(module-ref (resolve-interface '(gnu packages compression)) 'zlib))
|
||||
|
||||
(define config.scm
|
||||
(scheme-file "config.scm"
|
||||
#~(begin
|
||||
(define-module (guix config)
|
||||
#:export (%libz))
|
||||
|
||||
(define %libz
|
||||
#+(file-append zlib "/lib/libz")))))
|
||||
|
||||
(define modules
|
||||
(cons `((guix config) => ,config.scm)
|
||||
(delete '(guix config)
|
||||
(source-module-closure '((guix build hg)
|
||||
(guix build download-nar))))))
|
||||
|
||||
(define build
|
||||
(with-imported-modules '((guix build hg)
|
||||
(guix build utils))
|
||||
(with-imported-modules modules
|
||||
#~(begin
|
||||
(use-modules (guix build hg)
|
||||
(guix build utils)
|
||||
(ice-9 match))
|
||||
(guix build download-nar))
|
||||
|
||||
(hg-fetch '#$(hg-reference-url ref)
|
||||
'#$(hg-reference-changeset ref)
|
||||
#$output
|
||||
#:hg-command (string-append #+hg "/bin/hg")))))
|
||||
(or (hg-fetch '#$(hg-reference-url ref)
|
||||
'#$(hg-reference-changeset ref)
|
||||
#$output
|
||||
#:hg-command (string-append #+hg "/bin/hg"))
|
||||
(download-nar #$output)))))
|
||||
|
||||
(mlet %store-monad ((guile (package->derivation guile system)))
|
||||
(gexp->derivation (or name "hg-checkout") build
|
||||
|
|
|
|||
Loading…
Reference in New Issue