* bug#28709: Content-addressed mirrors for Git checkouts
@ 2017-10-04 21:49 Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
0 siblings, 1 reply; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-04 21:49 UTC (permalink / raw)
To: 28709
[-- Attachment #1: Type: text/plain, Size: 807 bytes --]
Hello!
Someone on #guix reported a failure to build Guile-Git from Guix 0.13.0
because the old repo at gitlab.com has disappeared.
For tarballs, we have content addressed mirrors, in particular the /file
URL of ‘guix publish’. However, that’s only for regular files, not for
directories like Git checkouts.
For directories (and store items in general), we have the /nar URLs
though (normally used for substitutes). This patch uses /nar URLs as a
fallback mirror (it’s content-addressed, even though the hash in the URL
is not directly the content hash) for Git clones that fail.
It’s rough on the edges (no TLS, no compression), but it shows that it’s
a viable solution. It would take some thought to avoid duplicating it
between git, hg, etc.
Thoughts?
Ludo’.
[-- Attachment #2: Type: text/x-patch, Size: 5667 bytes --]
diff --git a/guix/build/git.scm b/guix/build/git.scm
index c1af545a7..223e79227 100644
--- a/guix/build/git.scm
+++ b/guix/build/git.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,7 +17,14 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build git)
+ #:use-module (web uri)
+ #:use-module (web client)
+ #:use-module (web response)
+ #:use-module (guix serialization)
#:use-module (guix build utils)
+ #:use-module (srfi srfi-11)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
#:export (git-fetch))
;;; Commentary:
@@ -27,6 +34,37 @@
;;;
;;; Code:
+(define (urls-for-item item)
+ "Return the fallback nar URL for ITEM--e.g., \"cabbag3…-foo-1.2-checkout\"."
+ ;; TODO: Use the /gzip URLs, make it configurable, and use TLS.
+ (list (string-append "http://mirror.hydra.gnu.org/guix/nar/" item)
+ (string-append "http://berlin.guixsd.org/nar/" item)))
+
+(define (download-nar item directory)
+ "Download Git checkout ITEM to DIRECTORY as a nar."
+ (setvbuf (current-output-port) _IONBF)
+ (setvbuf (current-error-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 (((response port)
+ (http-get url #:streaming? #t)))
+ (if (= 200 (response-code response))
+ (let ((size (response-content-length response)))
+ (if size
+ (format #t "Downloading from ~a (~,2h MiB)...~%"
+ url (/ size (expt 2 20.)))
+ (format #t "Downloading from ~a...~%" url))
+ (restore-file port directory)
+ (close-port port)
+ #t)
+ (loop rest))))
+ (()
+ #f))))
+
(define* (git-fetch url commit directory
#:key (git-command "git") recursive?)
"Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit
@@ -39,26 +77,27 @@ recursively. Return #t on success, #f otherwise."
;; We cannot use "git clone --recursive" since the following "git checkout"
;; effectively removes sub-module checkouts as of Git 2.6.3.
- (and (zero? (system* git-command "clone" url directory))
- (with-directory-excursion directory
- (system* git-command "tag" "-l")
- (and (zero? (system* git-command "checkout" commit))
- (begin
- (when recursive?
- ;; Now is the time to fetch sub-modules.
- (unless (zero? (system* git-command "submodule" "update"
- "--init" "--recursive"))
- (error "failed to fetch sub-modules" url))
+ (if (zero? (system* git-command "clone" url directory))
+ (with-directory-excursion directory
+ (system* git-command "tag" "-l")
+ (and (zero? (system* git-command "checkout" commit))
+ (begin
+ (when recursive?
+ ;; Now is the time to fetch sub-modules.
+ (unless (zero? (system* git-command "submodule" "update"
+ "--init" "--recursive"))
+ (error "failed to fetch sub-modules" url))
- ;; In sub-modules, '.git' is a flat file, not a directory,
- ;; so we can use 'find-files' here.
- (for-each delete-file-recursively
- (find-files directory "^\\.git$")))
+ ;; In sub-modules, '.git' is a flat file, not a directory,
+ ;; so we can use 'find-files' here.
+ (for-each delete-file-recursively
+ (find-files directory "^\\.git$")))
- ;; The contents of '.git' vary as a function of the current
- ;; status of the Git repo. Since we want a fixed output, this
- ;; directory needs to be taken out.
- (delete-file-recursively ".git")
- #t)))))
+ ;; The contents of '.git' vary as a function of the current
+ ;; status of the Git repo. Since we want a fixed output, this
+ ;; directory needs to be taken out.
+ (delete-file-recursively ".git")
+ #t)))
+ (download-nar (basename directory) directory)))
;;; git.scm ends here
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 7397cbe7f..ffae8fcc3 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)
@@ -78,8 +79,8 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
'()))
(define build
- (with-imported-modules '((guix build git)
- (guix build utils))
+ (with-imported-modules (source-module-closure
+ '((guix build git)))
#~(begin
(use-modules (guix build git)
(guix build utils)
^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts
2017-10-04 21:49 bug#28709: Content-addressed mirrors for Git checkouts Ludovic Courtès
@ 2017-10-17 8:48 ` Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 1/4] download: Remove old-Guile leftovers Ludovic Courtès
` (4 more replies)
0 siblings, 5 replies; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-17 8:48 UTC (permalink / raw)
To: 28709
Hello,
Here’s a ready-to-merge patch series. Once applied, nars
(aka. “substitutes”) are downloaded and extracted when a VCS checkout
fails. This will address cases such as the recent Guile-Git repository
renaming for people who have disabled substitutes.
I’m Cc’ing 宋文武 because this also moves the progress-report code to
a new (guix progress) module.
Feedback welcome!
Ludo’.
Ludovic Courtès (4):
download: Remove old-Guile leftovers.
download: Make 'http-fetch' public.
Add (guix progress).
download: Download a nar when a VCS checkout fails.
Makefile.am | 2 +
guix/build/download-nar.scm | 125 ++++++++++++++++++++++++
guix/build/download.scm | 216 +++++------------------------------------
guix/cvs-download.scm | 38 ++++++--
guix/git-download.scm | 37 +++++--
guix/hg-download.scm | 36 +++++--
guix/progress.scm | 228 ++++++++++++++++++++++++++++++++++++++++++++
guix/scripts/download.scm | 4 +-
guix/scripts/substitute.scm | 5 +-
guix/utils.scm | 28 +-----
10 files changed, 470 insertions(+), 249 deletions(-)
create mode 100644 guix/build/download-nar.scm
create mode 100644 guix/progress.scm
--
2.14.2
^ permalink raw reply [flat|nested] 8+ messages in thread
* bug#28709: [PATCH 1/4] download: Remove old-Guile leftovers.
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
@ 2017-10-17 8:48 ` Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 2/4] download: Make 'http-fetch' public Ludovic Courtès
` (3 subsequent siblings)
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-17 8:48 UTC (permalink / raw)
To: 28709
This is a followup to 36626c556ed75219bce196ac93d148f6b9af984c.
* guix/build/download.scm (http-fetch): Rename 'port-or-bv' to 'port'.
Assume (port? port) is always true, and remove other branch.
---
guix/build/download.scm | 15 ++++++---------
1 file changed, 6 insertions(+), 9 deletions(-)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 9490f4805..e227ae598 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -774,7 +774,7 @@ certificates; otherwise simply ignore them."
#:timeout timeout
#:verify-certificate?
verify-certificate?))
- ((resp bv-or-port)
+ ((resp port)
(http-get uri #:port connection #:decode-body? #f
#:streaming? #t
#:headers headers))
@@ -787,14 +787,11 @@ certificates; otherwise simply ignore them."
(begin
(call-with-output-file file
(lambda (p)
- (if (port? bv-or-port)
- (begin
- (dump-port* bv-or-port p
- #:buffer-size %http-receive-buffer-size
- #:reporter (progress-reporter/file
- (uri-abbreviation uri) size))
- (newline))
- (put-bytevector p bv-or-port))))
+ (dump-port* port p
+ #:buffer-size %http-receive-buffer-size
+ #:reporter (progress-reporter/file
+ (uri-abbreviation uri) size))
+ (newline)))
file))
((301 ; moved permanently
302 ; found (redirection)
--
2.14.2
^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#28709: [PATCH 2/4] download: Make 'http-fetch' public.
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 1/4] download: Remove old-Guile leftovers Ludovic Courtès
@ 2017-10-17 8:48 ` Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 3/4] Add (guix progress) Ludovic Courtès
` (2 subsequent siblings)
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-17 8:48 UTC (permalink / raw)
To: 28709
* guix/build/download.scm (http-fetch): Remove 'file' parameter. Change
to return an input port and the content-length. Make public.
(url-fetch): Adjust accordingly.
---
guix/build/download.scm | 44 ++++++++++++++++++++++----------------------
1 file changed, 22 insertions(+), 22 deletions(-)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index e227ae598..3b89f9412 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -39,6 +39,7 @@
#:use-module (ice-9 format)
#:export (open-socket-for-uri
open-connection-for-uri
+ http-fetch
%x509-certificate-directory
close-connection
resolve-uri-reference
@@ -745,11 +746,11 @@ Return the resulting target URI."
#:query (uri-query ref)
#:fragment (uri-fragment ref)))))
-(define* (http-fetch uri file #:key timeout (verify-certificate? #t))
- "Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if
-the connection could not be established in less than TIMEOUT seconds. Return
-FILE on success. When VERIFY-CERTIFICATE? is true, verify HTTPS
-certificates; otherwise simply ignore them."
+(define* (http-fetch uri #:key timeout (verify-certificate? #t))
+ "Return an input port containing the data at URI, and the expected number of
+bytes available or #f. When TIMEOUT is true, bail out if the connection could
+not be established in less than TIMEOUT seconds. When VERIFY-CERTIFICATE? is
+true, verify HTTPS certificates; otherwise simply ignore them."
(define headers
`(;; Some web sites, such as http://dist.schmorp.de, would block you if
@@ -779,20 +780,10 @@ certificates; otherwise simply ignore them."
#:streaming? #t
#:headers headers))
((code)
- (response-code resp))
- ((size)
- (response-content-length resp)))
+ (response-code resp)))
(case code
((200) ; OK
- (begin
- (call-with-output-file file
- (lambda (p)
- (dump-port* port p
- #:buffer-size %http-receive-buffer-size
- #:reporter (progress-reporter/file
- (uri-abbreviation uri) size))
- (newline)))
- file))
+ (values port (response-content-length resp)))
((301 ; moved permanently
302 ; found (redirection)
303 ; see other
@@ -802,7 +793,7 @@ certificates; otherwise simply ignore them."
(format #t "following redirection to `~a'...~%"
(uri->string uri))
(close connection)
- (http-fetch uri file
+ (http-fetch uri
#:timeout timeout
#:verify-certificate? verify-certificate?)))
(else
@@ -873,10 +864,19 @@ otherwise simply ignore them."
file (uri->string uri))
(case (uri-scheme uri)
((http https)
- (false-if-exception* (http-fetch uri file
- #:verify-certificate?
- verify-certificate?
- #:timeout timeout)))
+ (false-if-exception*
+ (let-values (((port size)
+ (http-fetch uri
+ #:verify-certificate? verify-certificate?
+ #:timeout timeout)))
+ (call-with-output-file file
+ (lambda (output)
+ (dump-port* port output
+ #:buffer-size %http-receive-buffer-size
+ #:reporter (progress-reporter/file
+ (uri-abbreviation uri) size))
+ (newline)))
+ #t)))
((ftp)
(false-if-exception* (ftp-fetch uri file
#:timeout timeout)))
--
2.14.2
^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#28709: [PATCH 3/4] Add (guix progress).
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 1/4] download: Remove old-Guile leftovers Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 2/4] download: Make 'http-fetch' public Ludovic Courtès
@ 2017-10-17 8:48 ` Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 4/4] download: Download a nar when a VCS checkout fails Ludovic Courtès
2017-10-18 17:58 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Christopher Baines
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-17 8:48 UTC (permalink / raw)
To: 28709
Among other things, this removes (guix utils), (guix ui), (guix config),
etc. from the closure of (guix build download), as was the case since
798648515b77507c242752457b4dc17c155bad6e.
* guix/utils.scm (<progress-reporter>, call-with-progress-reporter):
Move to...
* guix/progress.scm: ... here. New file.
* Makefile.am (MODULES): Add it.
* guix/build/download.scm (current-terminal-columns)
(nearest-exact-integer, duration->seconds, seconds->string)
(byte-count->string, progress-bar, string-pad-middle)
(rate-limited, progress-reporter/file, dump-port*)
(time-monotonic): Move to progress.scm.
* guix/scripts/download.scm: Adjust accordingly.
* guix/scripts/substitute.scm: Likewise.
---
Makefile.am | 1 +
guix/build/download.scm | 167 +-------------------------------
guix/progress.scm | 228 ++++++++++++++++++++++++++++++++++++++++++++
guix/scripts/download.scm | 4 +-
guix/scripts/substitute.scm | 5 +-
guix/utils.scm | 28 +-----
6 files changed, 236 insertions(+), 197 deletions(-)
create mode 100644 guix/progress.scm
diff --git a/Makefile.am b/Makefile.am
index efbd07a35..071553b99 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -47,6 +47,7 @@ MODULES = \
guix/hash.scm \
guix/pk-crypto.scm \
guix/pki.scm \
+ guix/progress.scm \
guix/combinators.scm \
guix/memoization.scm \
guix/utils.scm \
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 3b89f9412..61c9c6d3f 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,7 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
-;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
@@ -27,7 +26,7 @@
#:use-module (guix base64)
#:use-module (guix ftp-client)
#:use-module (guix build utils)
- #:use-module (guix utils)
+ #:use-module (guix progress)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
@@ -46,8 +45,6 @@
maybe-expand-mirrors
url-fetch
byte-count->string
- current-terminal-columns
- progress-reporter/file
uri-abbreviation
nar-uri-abbreviation
store-path-abbreviation))
@@ -62,69 +59,6 @@
;; Size of the HTTP receive buffer.
65536)
-(define current-terminal-columns
- ;; Number of columns of the terminal.
- (make-parameter 80))
-
-(define (nearest-exact-integer x)
- "Given a real number X, return the nearest exact integer, with ties going to
-the nearest exact even integer."
- (inexact->exact (round x)))
-
-(define (duration->seconds duration)
- "Return the number of seconds represented by DURATION, a 'time-duration'
-object, as an inexact number."
- (+ (time-second duration)
- (/ (time-nanosecond duration) 1e9)))
-
-(define (seconds->string duration)
- "Given DURATION in seconds, return a string representing it in 'mm:ss' or
-'hh:mm:ss' format, as needed."
- (if (not (number? duration))
- "00:00"
- (let* ((total-seconds (nearest-exact-integer duration))
- (extra-seconds (modulo total-seconds 3600))
- (num-hours (quotient total-seconds 3600))
- (hours (and (positive? num-hours) num-hours))
- (mins (quotient extra-seconds 60))
- (secs (modulo extra-seconds 60)))
- (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs))))
-
-(define (byte-count->string size)
- "Given SIZE in bytes, return a string representing it in a human-readable
-way."
- (let ((KiB 1024.)
- (MiB (expt 1024. 2))
- (GiB (expt 1024. 3))
- (TiB (expt 1024. 4)))
- (cond
- ((< size KiB) (format #f "~dB" (nearest-exact-integer size)))
- ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB))))
- ((< size GiB) (format #f "~,1fMiB" (/ size MiB)))
- ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
- (else (format #f "~,3fTiB" (/ size TiB))))))
-
-(define* (progress-bar % #:optional (bar-width 20))
- "Return % as a string representing an ASCII-art progress bar. The total
-width of the bar is BAR-WIDTH."
- (let* ((fraction (/ % 100))
- (filled (inexact->exact (floor (* fraction bar-width))))
- (empty (- bar-width filled)))
- (format #f "[~a~a]"
- (make-string filled #\#)
- (make-string empty #\space))))
-
-(define (string-pad-middle left right len)
- "Combine LEFT and RIGHT with enough padding in the middle so that the
-resulting string has length at least LEN (it may overflow). If the string
-does not overflow, the last char in RIGHT will be flush with the LEN
-column."
- (let* ((total-used (+ (string-length left)
- (string-length right)))
- (num-spaces (max 1 (- len total-used)))
- (padding (make-string num-spaces #\space)))
- (string-append left padding right)))
-
(define* (ellipsis #:optional (port (current-output-port)))
"Make a rough guess at whether Unicode's HORIZONTAL ELLIPSIS can be written
in PORT's encoding, and return either that or ASCII dots."
@@ -143,105 +77,6 @@ Otherwise return STORE-PATH."
(string-drop base 32)))
store-path))
-(cond-expand
- (guile-2.2
- ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
- ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
- (define time-monotonic time-tai))
- (else #t))
-
-
-;; TODO: replace '(@ (guix build utils) dump-port))'.
-(define* (dump-port* in out
- #:key (buffer-size 16384)
- (reporter (make-progress-reporter noop noop noop)))
- "Read as much data as possible from IN and write it to OUT, using chunks of
-BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or
-less, report the total number of bytes transferred to the REPORTER, which
-should be a <progress-reporter> object."
- (define buffer
- (make-bytevector buffer-size))
-
- (call-with-progress-reporter reporter
- (lambda (report)
- (let loop ((total 0)
- (bytes (get-bytevector-n! in buffer 0 buffer-size)))
- (or (eof-object? bytes)
- (let ((total (+ total bytes)))
- (put-bytevector out buffer 0 bytes)
- (report total)
- (loop total (get-bytevector-n! in buffer 0 buffer-size))))))))
-
-(define (rate-limited proc interval)
- "Return a procedure that will forward the invocation to PROC when the time
-elapsed since the previous forwarded invocation is greater or equal to
-INTERVAL (a time-duration object), otherwise does nothing and returns #f."
- (let ((previous-at #f))
- (lambda args
- (let* ((now (current-time time-monotonic))
- (forward-invocation (lambda ()
- (set! previous-at now)
- (apply proc args))))
- (if previous-at
- (let ((elapsed (time-difference now previous-at)))
- (if (time>=? elapsed interval)
- (forward-invocation)
- #f))
- (forward-invocation))))))
-
-(define* (progress-reporter/file file size
- #:optional (log-port (current-output-port))
- #:key (abbreviation basename))
- "Return a <progress-reporter> object to show the progress of FILE's download,
-which is SIZE bytes long. The progress report is written to LOG-PORT, with
-ABBREVIATION used to shorten FILE for display."
- (let ((start-time (current-time time-monotonic))
- (transferred 0))
- (define (render)
- "Write the progress report to LOG-PORT."
- (define elapsed
- (duration->seconds
- (time-difference (current-time time-monotonic) start-time)))
- (if (number? size)
- (let* ((% (* 100.0 (/ transferred size)))
- (throughput (/ transferred elapsed))
- (left (format #f " ~a ~a"
- (abbreviation file)
- (byte-count->string size)))
- (right (format #f "~a/s ~a ~a~6,1f%"
- (byte-count->string throughput)
- (seconds->string elapsed)
- (progress-bar %) %)))
- (display "\r\x1b[K" log-port)
- (display (string-pad-middle left right
- (current-terminal-columns))
- log-port)
- (flush-output-port log-port))
- (let* ((throughput (/ transferred elapsed))
- (left (format #f " ~a"
- (abbreviation file)))
- (right (format #f "~a/s ~a | ~a transferred"
- (byte-count->string throughput)
- (seconds->string elapsed)
- (byte-count->string transferred))))
- (display "\r\x1b[K" log-port)
- (display (string-pad-middle left right
- (current-terminal-columns))
- log-port)
- (flush-output-port log-port))))
-
- (progress-reporter
- (start render)
- ;; Report the progress every 300ms or longer.
- (report
- (let ((rate-limited-render
- (rate-limited render (make-time time-monotonic 300000000 0))))
- (lambda (value)
- (set! transferred value)
- (rate-limited-render))))
- ;; Don't miss the last report.
- (stop render))))
-
(define* (uri-abbreviation uri #:optional (max-length 42))
"If URI's string representation is larger than MAX-LENGTH, return an
abbreviation of URI showing the scheme, host, and basename of the file."
diff --git a/guix/progress.scm b/guix/progress.scm
new file mode 100644
index 000000000..beca2c22a
--- /dev/null
+++ b/guix/progress.scm
@@ -0,0 +1,228 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
+;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
+;;;
+;;; 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 progress)
+ #:use-module (guix records)
+ #:use-module (srfi srfi-19)
+ #:use-module (rnrs io ports)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:export (<progress-reporter>
+ progress-reporter
+ make-progress-reporter
+ progress-reporter?
+ call-with-progress-reporter
+
+ progress-reporter/silent
+ progress-reporter/file
+
+ byte-count->string
+ current-terminal-columns
+
+ dump-port*))
+
+;;; Commentary:
+;;;
+;;; Helper to write progress report code for downloads, etc.
+;;;
+;;; Code:
+
+(define-record-type* <progress-reporter>
+ progress-reporter make-progress-reporter progress-reporter?
+ (start progress-reporter-start) ; thunk
+ (report progress-reporter-report) ; procedure
+ (stop progress-reporter-stop)) ; thunk
+
+(define (call-with-progress-reporter reporter proc)
+ "Start REPORTER for progress reporting, and call @code{(@var{proc} report)}
+with the resulting report procedure. When @var{proc} returns, the REPORTER is
+stopped."
+ (match reporter
+ (($ <progress-reporter> start report stop)
+ (dynamic-wind start (lambda () (proc report)) stop))))
+
+(define progress-reporter/silent
+ (make-progress-reporter noop noop noop))
+
+\f
+;;;
+;;; File download progress report.
+;;;
+
+(cond-expand
+ (guile-2.2
+ ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
+ ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
+ (define time-monotonic time-tai))
+ (else #t))
+
+(define (nearest-exact-integer x)
+ "Given a real number X, return the nearest exact integer, with ties going to
+the nearest exact even integer."
+ (inexact->exact (round x)))
+
+(define (duration->seconds duration)
+ "Return the number of seconds represented by DURATION, a 'time-duration'
+object, as an inexact number."
+ (+ (time-second duration)
+ (/ (time-nanosecond duration) 1e9)))
+
+(define (seconds->string duration)
+ "Given DURATION in seconds, return a string representing it in 'mm:ss' or
+'hh:mm:ss' format, as needed."
+ (if (not (number? duration))
+ "00:00"
+ (let* ((total-seconds (nearest-exact-integer duration))
+ (extra-seconds (modulo total-seconds 3600))
+ (num-hours (quotient total-seconds 3600))
+ (hours (and (positive? num-hours) num-hours))
+ (mins (quotient extra-seconds 60))
+ (secs (modulo extra-seconds 60)))
+ (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs))))
+
+(define (byte-count->string size)
+ "Given SIZE in bytes, return a string representing it in a human-readable
+way."
+ (let ((KiB 1024.)
+ (MiB (expt 1024. 2))
+ (GiB (expt 1024. 3))
+ (TiB (expt 1024. 4)))
+ (cond
+ ((< size KiB) (format #f "~dB" (nearest-exact-integer size)))
+ ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB))))
+ ((< size GiB) (format #f "~,1fMiB" (/ size MiB)))
+ ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
+ (else (format #f "~,3fTiB" (/ size TiB))))))
+
+(define (string-pad-middle left right len)
+ "Combine LEFT and RIGHT with enough padding in the middle so that the
+resulting string has length at least LEN (it may overflow). If the string
+does not overflow, the last char in RIGHT will be flush with the LEN
+column."
+ (let* ((total-used (+ (string-length left)
+ (string-length right)))
+ (num-spaces (max 1 (- len total-used)))
+ (padding (make-string num-spaces #\space)))
+ (string-append left padding right)))
+
+(define (rate-limited proc interval)
+ "Return a procedure that will forward the invocation to PROC when the time
+elapsed since the previous forwarded invocation is greater or equal to
+INTERVAL (a time-duration object), otherwise does nothing and returns #f."
+ (let ((previous-at #f))
+ (lambda args
+ (let* ((now (current-time time-monotonic))
+ (forward-invocation (lambda ()
+ (set! previous-at now)
+ (apply proc args))))
+ (if previous-at
+ (let ((elapsed (time-difference now previous-at)))
+ (if (time>=? elapsed interval)
+ (forward-invocation)
+ #f))
+ (forward-invocation))))))
+
+(define current-terminal-columns
+ ;; Number of columns of the terminal.
+ (make-parameter 80))
+
+(define* (progress-bar % #:optional (bar-width 20))
+ "Return % as a string representing an ASCII-art progress bar. The total
+width of the bar is BAR-WIDTH."
+ (let* ((fraction (/ % 100))
+ (filled (inexact->exact (floor (* fraction bar-width))))
+ (empty (- bar-width filled)))
+ (format #f "[~a~a]"
+ (make-string filled #\#)
+ (make-string empty #\space))))
+
+(define* (progress-reporter/file file size
+ #:optional (log-port (current-output-port))
+ #:key (abbreviation basename))
+ "Return a <progress-reporter> object to show the progress of FILE's download,
+which is SIZE bytes long. The progress report is written to LOG-PORT, with
+ABBREVIATION used to shorten FILE for display."
+ (let ((start-time (current-time time-monotonic))
+ (transferred 0))
+ (define (render)
+ "Write the progress report to LOG-PORT."
+ (define elapsed
+ (duration->seconds
+ (time-difference (current-time time-monotonic) start-time)))
+ (if (number? size)
+ (let* ((% (* 100.0 (/ transferred size)))
+ (throughput (/ transferred elapsed))
+ (left (format #f " ~a ~a"
+ (abbreviation file)
+ (byte-count->string size)))
+ (right (format #f "~a/s ~a ~a~6,1f%"
+ (byte-count->string throughput)
+ (seconds->string elapsed)
+ (progress-bar %) %)))
+ (display "\r\x1b[K" log-port)
+ (display (string-pad-middle left right
+ (current-terminal-columns))
+ log-port)
+ (force-output log-port))
+ (let* ((throughput (/ transferred elapsed))
+ (left (format #f " ~a"
+ (abbreviation file)))
+ (right (format #f "~a/s ~a | ~a transferred"
+ (byte-count->string throughput)
+ (seconds->string elapsed)
+ (byte-count->string transferred))))
+ (display "\r\x1b[K" log-port)
+ (display (string-pad-middle left right
+ (current-terminal-columns))
+ log-port)
+ (force-output log-port))))
+
+ (progress-reporter
+ (start render)
+ ;; Report the progress every 300ms or longer.
+ (report
+ (let ((rate-limited-render
+ (rate-limited render (make-time time-monotonic 300000000 0))))
+ (lambda (value)
+ (set! transferred value)
+ (rate-limited-render))))
+ ;; Don't miss the last report.
+ (stop render))))
+
+;; TODO: replace '(@ (guix build utils) dump-port))'.
+(define* (dump-port* in out
+ #:key (buffer-size 16384)
+ (reporter progress-reporter/silent))
+ "Read as much data as possible from IN and write it to OUT, using chunks of
+BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or
+less, report the total number of bytes transferred to the REPORTER, which
+should be a <progress-reporter> object."
+ (define buffer
+ (make-bytevector buffer-size))
+
+ (call-with-progress-reporter reporter
+ (lambda (report)
+ (let loop ((total 0)
+ (bytes (get-bytevector-n! in buffer 0 buffer-size)))
+ (or (eof-object? bytes)
+ (let ((total (+ total bytes)))
+ (put-bytevector out buffer 0 bytes)
+ (report total)
+ (loop total (get-bytevector-n! in buffer 0 buffer-size))))))))
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 8225f82bb..1b99bc62c 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -25,7 +25,9 @@
#:use-module (guix base32)
#:use-module ((guix download) #:hide (url-fetch))
#:use-module ((guix build download)
- #:select (url-fetch current-terminal-columns))
+ #:select (url-fetch))
+ #:use-module ((guix progress)
+ #:select (current-terminal-columns))
#:use-module ((guix build syscalls)
#:select (terminal-columns))
#:use-module (web uri)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 921a7c679..b9d86e3ff 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -33,13 +33,12 @@
#:use-module (guix pki)
#:use-module ((guix build utils) #:select (mkdir-p dump-port))
#:use-module ((guix build download)
- #:select (current-terminal-columns
- progress-reporter/file
- uri-abbreviation nar-uri-abbreviation
+ #:select (uri-abbreviation nar-uri-abbreviation
(open-connection-for-uri
. guix:open-connection-for-uri)
close-connection
store-path-abbreviation byte-count->string))
+ #:use-module (guix progress)
#:use-module ((guix build syscalls)
#:select (set-thread-name))
#:use-module (ice-9 rdelim)
diff --git a/guix/utils.scm b/guix/utils.scm
index de4aa6531..e1615fcf4 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -33,7 +33,6 @@
#:autoload (rnrs io ports) (make-custom-binary-input-port)
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
#:use-module (guix memoization)
- #:use-module (guix records)
#:use-module ((guix build utils) #:select (dump-port mkdir-p))
#:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
#:use-module (ice-9 format)
@@ -95,13 +94,7 @@
call-with-decompressed-port
compressed-output-port
call-with-compressed-output-port
- canonical-newline-port
-
- <progress-reporter>
- progress-reporter
- make-progress-reporter
- progress-reporter?
- call-with-progress-reporter))
+ canonical-newline-port))
\f
;;;
@@ -755,25 +748,6 @@ a location object."
(column . ,(location-column loc))
(filename . ,(location-file loc))))
-\f
-;;;
-;;; Progress reporter.
-;;;
-
-(define-record-type* <progress-reporter>
- progress-reporter make-progress-reporter progress-reporter?
- (start progress-reporter-start) ; thunk
- (report progress-reporter-report) ; procedure
- (stop progress-reporter-stop)) ; thunk
-
-(define (call-with-progress-reporter reporter proc)
- "Start REPORTER for progress reporting, and call @code{(@var{proc} report)}
-with the resulting report procedure. When @var{proc} returns, the REPORTER is
-stopped."
- (match reporter
- (($ <progress-reporter> start report stop)
- (dynamic-wind start (lambda () (proc report)) stop))))
-
;;; Local Variables:
;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
;;; End:
--
2.14.2
^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#28709: [PATCH 4/4] download: Download a nar when a VCS checkout fails.
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
` (2 preceding siblings ...)
2017-10-17 8:48 ` bug#28709: [PATCH 3/4] Add (guix progress) Ludovic Courtès
@ 2017-10-17 8:48 ` Ludovic Courtès
2017-10-18 17:58 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Christopher Baines
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-17 8:48 UTC (permalink / raw)
To: 28709; +Cc: Ludovic Courtès
From: Ludovic Courtès <ludovic.courtes@inria.fr>
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(-)
create mode 100644 guix/build/download-nar.scm
diff --git a/Makefile.am b/Makefile.am
index 071553b99..2855b4efd 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 000000000..13f01fb1e
--- /dev/null
+++ b/guix/build/download-nar.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))))
diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm
index 85744c5b5..8b46f8ef8 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 <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
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 7397cbe7f..731e549b3 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 842098090..6b25b87b6 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 <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
--
2.14.2
^ permalink raw reply related [flat|nested] 8+ messages in thread
* bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
` (3 preceding siblings ...)
2017-10-17 8:48 ` bug#28709: [PATCH 4/4] download: Download a nar when a VCS checkout fails Ludovic Courtès
@ 2017-10-18 17:58 ` Christopher Baines
2017-10-19 21:26 ` Ludovic Courtès
4 siblings, 1 reply; 8+ messages in thread
From: Christopher Baines @ 2017-10-18 17:58 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 28709
[-- Attachment #1: Type: text/plain, Size: 1511 bytes --]
On Tue, 17 Oct 2017 10:48:03 +0200
Ludovic Courtès <ludo@gnu.org> wrote:
> Hello,
>
> Here’s a ready-to-merge patch series. Once applied, nars
> (aka. “substitutes”) are downloaded and extracted when a VCS checkout
> fails. This will address cases such as the recent Guile-Git repository
> renaming for people who have disabled substitutes.
>
> I’m Cc’ing 宋文武 because this also moves the progress-report code to
> a new (guix progress) module.
>
> Feedback welcome!
>
> Ludo’.
>
> Ludovic Courtès (4):
> download: Remove old-Guile leftovers.
> download: Make 'http-fetch' public.
> Add (guix progress).
> download: Download a nar when a VCS checkout fails.
>
> Makefile.am | 2 +
> guix/build/download-nar.scm | 125 ++++++++++++++++++++++++
> guix/build/download.scm | 216 +++++------------------------------------
> guix/cvs-download.scm | 38 ++++++--
> guix/git-download.scm | 37 +++++--
> guix/hg-download.scm | 36 +++++--
> guix/progress.scm | 228 ++++++++++++++++++++++++++++++++++++++++++++
> guix/scripts/download.scm | 4 +-
> guix/scripts/substitute.scm | 5 +-
> guix/utils.scm | 28 +-----
> 10 files changed, 470 insertions(+), 249 deletions(-)
> create mode 100644 guix/build/download-nar.scm
> create mode 100644 guix/progress.scm
>
This all sounds good to me Ludo, and I didn't spot anything of note
when looking through the patches.
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 963 bytes --]
^ permalink raw reply [flat|nested] 8+ messages in thread
* bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts
2017-10-18 17:58 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Christopher Baines
@ 2017-10-19 21:26 ` Ludovic Courtès
0 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-19 21:26 UTC (permalink / raw)
To: Christopher Baines; +Cc: 28709-done
Howdy!
Christopher Baines <mail@cbaines.net> skribis:
> On Tue, 17 Oct 2017 10:48:03 +0200
> Ludovic Courtès <ludo@gnu.org> wrote:
[...]
>> Ludovic Courtès (4):
>> download: Remove old-Guile leftovers.
>> download: Make 'http-fetch' public.
>> Add (guix progress).
>> download: Download a nar when a VCS checkout fails.
>>
>> Makefile.am | 2 +
>> guix/build/download-nar.scm | 125 ++++++++++++++++++++++++
>> guix/build/download.scm | 216 +++++------------------------------------
>> guix/cvs-download.scm | 38 ++++++--
>> guix/git-download.scm | 37 +++++--
>> guix/hg-download.scm | 36 +++++--
>> guix/progress.scm | 228 ++++++++++++++++++++++++++++++++++++++++++++
>> guix/scripts/download.scm | 4 +-
>> guix/scripts/substitute.scm | 5 +-
>> guix/utils.scm | 28 +-----
>> 10 files changed, 470 insertions(+), 249 deletions(-)
>> create mode 100644 guix/build/download-nar.scm
>> create mode 100644 guix/progress.scm
>>
>
> This all sounds good to me Ludo, and I didn't spot anything of note
> when looking through the patches.
Thank you, pushed!
Ludo’.
^ permalink raw reply [flat|nested] 8+ messages in thread
end of thread, other threads:[~2017-10-19 21:27 UTC | newest]
Thread overview: 8+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2017-10-04 21:49 bug#28709: Content-addressed mirrors for Git checkouts Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 1/4] download: Remove old-Guile leftovers Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 2/4] download: Make 'http-fetch' public Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 3/4] Add (guix progress) Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 4/4] download: Download a nar when a VCS checkout fails Ludovic Courtès
2017-10-18 17:58 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Christopher Baines
2017-10-19 21:26 ` Ludovic Courtès
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.