Factorize `download-and-store'.
* guix/download.scm (download-to-store): New procedure. * guix/scripts/download.scm (fetch-and-store): Remove. (guix-download): Use `download-to-store' instead. * guix/ui.scm (call-with-temporary-output-file): Move to... * guix/utils.scm (call-with-temporary-output-file): ... here.
This commit is contained in:
parent
6c365eca6d
commit
861693f3e7
|
@ -21,13 +21,15 @@
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (guix derivations)
|
#:use-module (guix derivations)
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
#:use-module ((guix store) #:select (derivation-path?))
|
#:use-module ((guix store) #:select (derivation-path? add-to-store))
|
||||||
|
#:use-module ((guix build download) #:renamer (symbol-prefix-proc 'build:))
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-11)
|
#:use-module (srfi srfi-11)
|
||||||
#:use-module (srfi srfi-26)
|
#:use-module (srfi srfi-26)
|
||||||
#:export (%mirrors
|
#:export (%mirrors
|
||||||
url-fetch))
|
url-fetch
|
||||||
|
download-to-store))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
@ -231,4 +233,17 @@ must be a list of symbol/URL-list pairs."
|
||||||
#:guile-for-build guile-for-build
|
#:guile-for-build guile-for-build
|
||||||
#:env-vars env-vars)))
|
#:env-vars env-vars)))
|
||||||
|
|
||||||
|
(define* (download-to-store store url #:optional (name (basename url))
|
||||||
|
#:key (log (current-error-port)))
|
||||||
|
"Download from URL to STORE, either under NAME or URL's basename if
|
||||||
|
omitted. Write progress reports to LOG."
|
||||||
|
(call-with-temporary-output-file
|
||||||
|
(lambda (temp port)
|
||||||
|
(let ((result
|
||||||
|
(parameterize ((current-output-port log))
|
||||||
|
(build:url-fetch url temp #:mirrors %mirrors))))
|
||||||
|
(close port)
|
||||||
|
(and result
|
||||||
|
(add-to-store store name #f "sha256" temp))))))
|
||||||
|
|
||||||
;;; download.scm ends here
|
;;; download.scm ends here
|
||||||
|
|
|
@ -21,30 +21,15 @@
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:use-module (guix base32)
|
#:use-module (guix base32)
|
||||||
#:use-module ((guix download) #:select (%mirrors))
|
#:use-module (guix download)
|
||||||
#:use-module (guix build download)
|
|
||||||
#:use-module (web uri)
|
#:use-module (web uri)
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-11)
|
|
||||||
#:use-module (srfi srfi-26)
|
|
||||||
#:use-module (srfi srfi-37)
|
#:use-module (srfi srfi-37)
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (rnrs io ports)
|
#:use-module (rnrs io ports)
|
||||||
#:export (guix-download))
|
#:export (guix-download))
|
||||||
|
|
||||||
(define (fetch-and-store store fetch name)
|
|
||||||
"Call FETCH for URI, and pass it the name of a file to write to; eventually,
|
|
||||||
copy data from that port to STORE, under NAME. Return the resulting
|
|
||||||
store path."
|
|
||||||
(call-with-temporary-output-file
|
|
||||||
(lambda (temp port)
|
|
||||||
(let ((result
|
|
||||||
(parameterize ((current-output-port (current-error-port)))
|
|
||||||
(fetch temp))))
|
|
||||||
(close port)
|
|
||||||
(and result
|
|
||||||
(add-to-store store name #f "sha256" temp))))))
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Command-line options.
|
;;; Command-line options.
|
||||||
|
@ -124,10 +109,8 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
|
||||||
(add-to-store store (basename (uri-path uri))
|
(add-to-store store (basename (uri-path uri))
|
||||||
#f "sha256" (uri-path uri)))
|
#f "sha256" (uri-path uri)))
|
||||||
(else
|
(else
|
||||||
(fetch-and-store store
|
(download-to-store store (uri->string uri)
|
||||||
(cut url-fetch arg <>
|
(basename (uri-path uri))))))
|
||||||
#:mirrors %mirrors)
|
|
||||||
(basename (uri-path uri))))))
|
|
||||||
(hash (call-with-input-file
|
(hash (call-with-input-file
|
||||||
(or path
|
(or path
|
||||||
(leave (_ "~a: download failed~%")
|
(leave (_ "~a: download failed~%")
|
||||||
|
|
16
guix/ui.scm
16
guix/ui.scm
|
@ -41,7 +41,6 @@
|
||||||
with-error-handling
|
with-error-handling
|
||||||
read/eval-package-expression
|
read/eval-package-expression
|
||||||
location->string
|
location->string
|
||||||
call-with-temporary-output-file
|
|
||||||
switch-symlinks
|
switch-symlinks
|
||||||
config-directory
|
config-directory
|
||||||
fill-paragraph
|
fill-paragraph
|
||||||
|
@ -205,21 +204,6 @@ available for download."
|
||||||
(($ <location> file line column)
|
(($ <location> file line column)
|
||||||
(format #f "~a:~a:~a" file line column))))
|
(format #f "~a:~a:~a" file line column))))
|
||||||
|
|
||||||
(define (call-with-temporary-output-file proc)
|
|
||||||
"Call PROC with a name of a temporary file and open output port to that
|
|
||||||
file; close the file and delete it when leaving the dynamic extent of this
|
|
||||||
call."
|
|
||||||
(let* ((template (string-copy "guix-file.XXXXXX"))
|
|
||||||
(out (mkstemp! template)))
|
|
||||||
(dynamic-wind
|
|
||||||
(lambda ()
|
|
||||||
#t)
|
|
||||||
(lambda ()
|
|
||||||
(proc template out))
|
|
||||||
(lambda ()
|
|
||||||
(false-if-exception (close out))
|
|
||||||
(false-if-exception (delete-file template))))))
|
|
||||||
|
|
||||||
(define (switch-symlinks link target)
|
(define (switch-symlinks link target)
|
||||||
"Atomically switch LINK, a symbolic link, to point to TARGET. Works
|
"Atomically switch LINK, a symbolic link, to point to TARGET. Works
|
||||||
both when LINK already exists and when it does not."
|
both when LINK already exists and when it does not."
|
||||||
|
|
|
@ -60,6 +60,7 @@
|
||||||
version-compare
|
version-compare
|
||||||
version>?
|
version>?
|
||||||
package-name->name+version
|
package-name->name+version
|
||||||
|
call-with-temporary-output-file
|
||||||
fold2))
|
fold2))
|
||||||
|
|
||||||
|
|
||||||
|
@ -464,6 +465,21 @@ introduce the version part."
|
||||||
((head tail ...)
|
((head tail ...)
|
||||||
(loop tail (cons head prefix))))))
|
(loop tail (cons head prefix))))))
|
||||||
|
|
||||||
|
(define (call-with-temporary-output-file proc)
|
||||||
|
"Call PROC with a name of a temporary file and open output port to that
|
||||||
|
file; close the file and delete it when leaving the dynamic extent of this
|
||||||
|
call."
|
||||||
|
(let* ((template (string-copy "guix-file.XXXXXX"))
|
||||||
|
(out (mkstemp! template)))
|
||||||
|
(dynamic-wind
|
||||||
|
(lambda ()
|
||||||
|
#t)
|
||||||
|
(lambda ()
|
||||||
|
(proc template out))
|
||||||
|
(lambda ()
|
||||||
|
(false-if-exception (close out))
|
||||||
|
(false-if-exception (delete-file template))))))
|
||||||
|
|
||||||
(define fold2
|
(define fold2
|
||||||
(case-lambda
|
(case-lambda
|
||||||
((proc seed1 seed2 lst)
|
((proc seed1 seed2 lst)
|
||||||
|
|
Loading…
Reference in New Issue