From: Timothy Sample <samplet@ngyro.com>
To: 47336@debbugs.gnu.org
Subject: bug#47336: [PATCH 1/2] swh: Add a directory download procedure.
Date: Tue, 23 Mar 2021 00:52:12 -0400 [thread overview]
Message-ID: <20210323045213.9419-1-samplet@ngyro.com> (raw)
In-Reply-To: <87eeg6o50b.fsf@ngyro.com>
* guix/swh.scm (swh-directory-download): New procedure (with
implementation extracted from 'swh-download').
(swh-download): Use it to download the revision directory.
---
guix/swh.scm | 65 +++++++++++++++++++++++++++++-----------------------
1 file changed, 36 insertions(+), 29 deletions(-)
diff --git a/guix/swh.scm b/guix/swh.scm
index f11b7ea2d5..2402ec98e6 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -108,6 +108,7 @@
commit-id?
+ swh-download-directory
swh-download))
;;; Commentary:
@@ -558,12 +559,6 @@ requested bundle cooking, waiting for completion...~%"))
;;; 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 @@ delete it when leaving the dynamic extent of this call."
(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 @@ wait until it becomes available, which could take several minutes."
(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)))
--
2.31.0
next prev parent reply other threads:[~2021-03-23 4:53 UTC|newest]
Thread overview: 16+ messages / expand[flat|nested] mbox.gz Atom feed top
2021-03-23 4:42 bug#47336: Disarchive as a fallback for downloads Timothy Sample
2021-03-23 4:52 ` Timothy Sample [this message]
2021-03-23 4:52 ` bug#47336: [PATCH 2/2] download: Use Disarchive as a last resort Timothy Sample
2021-03-27 10:57 ` [bug#47336] Disarchive as a fallback for downloads Ludovic Courtès
2021-03-27 10:40 ` Ludovic Courtès
2021-04-10 20:52 ` Ludovic Courtès
2021-04-26 9:49 ` Ludovic Courtès
2021-04-28 2:30 ` bug#47336: " Timothy Sample
2021-04-28 7:01 ` [bug#47336] " Timothy Sample
2021-04-29 7:48 ` Ludovic Courtès
2021-04-29 17:24 ` bug#47336: " Timothy Sample
2021-03-23 5:11 ` Timothy Sample
2021-03-23 9:35 ` [bug#47336] " zimoun
2021-03-23 14:31 ` Timothy Sample
2021-03-27 10:39 ` Ludovic Courtès
2021-05-14 21:36 ` Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20210323045213.9419-1-samplet@ngyro.com \
--to=samplet@ngyro.com \
--cc=47336@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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.