[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
05/05: download: Download a nar when a VCS checkout fails.
|
From: |
Ludovic Courtès |
|
Subject: |
05/05: download: Download a nar when a VCS checkout fails. |
|
Date: |
Thu, 19 Oct 2017 17:21:57 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 37ce440dcffa9ff4f5401bacbc9619bd8ea561c1
Author: Ludovic Courtès <address@hidden>
Date: Tue Oct 17 10:34:03 2017 +0200
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.
---
Makefile.am | 1 +
guix/build/download-nar.scm | 125 ++++++++++++++++++++++++++++++++++++++++++++
guix/cvs-download.scm | 38 ++++++++++----
guix/git-download.scm | 37 ++++++++++---
guix/hg-download.scm | 36 +++++++++----
5 files changed, 211 insertions(+), 26 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 071553b..2855b4e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -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 \
diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm
new file mode 100644
index 0000000..13f01fb
--- /dev/null
+++ b/guix/build/download-nar.scm
@@ -0,0 +1,125 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <address@hidden>
+;;;
+;;; 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))))
diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm
index 85744c5..8b46f8e 100644
--- a/guix/cvs-download.scm
+++ b/guix/cvs-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
;;; Copyright © 2014 Sree Harsha Totakura <address@hidden>
;;; Copyright © 2015 Mark H Weaver <address@hidden>
;;;
@@ -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
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 7397cbe..731e549 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -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
diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index 8420980..6b25b87 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
;;; Copyright © 2016 Ricardo Wurmus <address@hidden>
;;;
;;; 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