mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
swh: Add a directory download procedure.
* guix/swh.scm (swh-directory-download): New procedure (with implementation extracted from 'swh-download'). (swh-download): Use it to download the revision directory.
This commit is contained in:
parent
3802bb0ba0
commit
4f59ef3edb
1 changed files with 36 additions and 29 deletions
65
guix/swh.scm
65
guix/swh.scm
|
@ -108,6 +108,7 @@ (define-module (guix swh)
|
|||
|
||||
commit-id?
|
||||
|
||||
swh-download-directory
|
||||
swh-download))
|
||||
|
||||
;;; Commentary:
|
||||
|
@ -558,12 +559,6 @@ (define* (vault-fetch id kind
|
|||
;;; High-level interface.
|
||||
;;;
|
||||
|
||||
(define (commit-id? reference)
|
||||
"Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if
|
||||
it is a tag name. This is based on a simple heuristic so use with care!"
|
||||
(and (= (string-length reference) 40)
|
||||
(string-every char-set:hex-digit reference)))
|
||||
|
||||
(define (call-with-temporary-directory proc) ;FIXME: factorize
|
||||
"Call PROC with a name of a temporary directory; close the directory and
|
||||
delete it when leaving the dynamic extent of this call."
|
||||
|
@ -577,6 +572,39 @@ (define (call-with-temporary-directory proc) ;FIXME: factorize
|
|||
(lambda ()
|
||||
(false-if-exception (delete-file-recursively tmp-dir))))))
|
||||
|
||||
(define* (swh-download-directory id output
|
||||
#:key (log-port (current-error-port)))
|
||||
"Download from Software Heritage the directory with the given ID, and
|
||||
unpack it to OUTPUT. Return #t on success and #f on failure"
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(match (vault-fetch id 'directory #:log-port log-port)
|
||||
(#f
|
||||
(format log-port
|
||||
"SWH: directory ~a could not be fetched from the vault~%"
|
||||
id)
|
||||
#f)
|
||||
((? port? input)
|
||||
(let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
|
||||
(dump-port input tar)
|
||||
(close-port input)
|
||||
(let ((status (close-pipe tar)))
|
||||
(unless (zero? status)
|
||||
(error "tar extraction failure" status)))
|
||||
|
||||
(match (scandir directory)
|
||||
(("." ".." sub-directory)
|
||||
(copy-recursively (string-append directory "/" sub-directory)
|
||||
output
|
||||
#:log (%make-void-port "w"))
|
||||
#t))))))))
|
||||
|
||||
(define (commit-id? reference)
|
||||
"Return true if REFERENCE is likely a commit ID, false otherwise---e.g., if
|
||||
it is a tag name. This is based on a simple heuristic so use with care!"
|
||||
(and (= (string-length reference) 40)
|
||||
(string-every char-set:hex-digit reference)))
|
||||
|
||||
(define* (swh-download url reference output
|
||||
#:key (log-port (current-error-port)))
|
||||
"Download from Software Heritage a checkout of the Git tag or commit
|
||||
|
@ -593,28 +621,7 @@ (define* (swh-download url reference output
|
|||
(format log-port "SWH: found revision ~a with directory at '~a'~%"
|
||||
(revision-id revision)
|
||||
(swh-url (revision-directory-url revision)))
|
||||
(call-with-temporary-directory
|
||||
(lambda (directory)
|
||||
(match (vault-fetch (revision-directory revision) 'directory
|
||||
#:log-port log-port)
|
||||
(#f
|
||||
(format log-port
|
||||
"SWH: directory ~a could not be fetched from the vault~%"
|
||||
(revision-directory revision))
|
||||
#f)
|
||||
((? port? input)
|
||||
(let ((tar (open-pipe* OPEN_WRITE "tar" "-C" directory "-xzvf" "-")))
|
||||
(dump-port input tar)
|
||||
(close-port input)
|
||||
(let ((status (close-pipe tar)))
|
||||
(unless (zero? status)
|
||||
(error "tar extraction failure" status)))
|
||||
|
||||
(match (scandir directory)
|
||||
(("." ".." sub-directory)
|
||||
(copy-recursively (string-append directory "/" sub-directory)
|
||||
output
|
||||
#:log (%make-void-port "w"))
|
||||
#t))))))))
|
||||
(swh-download-directory (revision-directory revision) output
|
||||
#:log-port log-port))
|
||||
(#f
|
||||
#f)))
|
||||
|
|
Loading…
Reference in a new issue