summaryrefslogtreecommitdiff
path: root/guix/swh.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/swh.scm')
-rw-r--r--guix/swh.scm85
1 files changed, 50 insertions, 35 deletions
diff --git a/guix/swh.scm b/guix/swh.scm
index f11b7ea2d5..3005323fd1 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -108,6 +108,7 @@
commit-id?
+ swh-download-directory
swh-download))
;;; Commentary:
@@ -147,12 +148,20 @@
url
(string-append url "/")))
-;; XXX: Work around a bug in Guile 3.0.2 where #:verify-certificate? would
-;; be ignored (<https://bugs.gnu.org/40486>).
-(define* (http-get* uri #:rest rest)
- (apply http-request uri #:method 'GET rest))
-(define* (http-post* uri #:rest rest)
- (apply http-request uri #:method 'POST rest))
+(cond-expand
+ (guile-3
+ ;; XXX: Work around a bug in Guile 3.0.2 where #:verify-certificate? would
+ ;; be ignored (<https://bugs.gnu.org/40486>).
+ (define* (http-get* uri #:rest rest)
+ (apply http-request uri #:method 'GET rest))
+ (define* (http-post* uri #:rest rest)
+ (apply http-request uri #:method 'POST rest)))
+ (else ;Guile 2.2
+ ;; Guile 2.2 did not have #:verify-certificate? so ignore it.
+ (define* (http-get* uri #:key verify-certificate? streaming?)
+ (http-request uri #:method 'GET #:streaming? streaming?))
+ (define* (http-post* uri #:key verify-certificate? streaming?)
+ (http-request uri #:method 'POST #:streaming? streaming?))))
(define %date-regexp
;; Match strings like "2014-11-17T22:09:38+01:00" or
@@ -558,12 +567,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 +580,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 +629,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)))