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:
Ludovic Courtès 2013-04-21 22:40:23 +02:00
parent 6c365eca6d
commit 861693f3e7
4 changed files with 36 additions and 38 deletions

View File

@ -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

View File

@ -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~%")

View File

@ -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."

View File

@ -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)