diff options
Diffstat (limited to 'guix/swh.scm')
| -rw-r--r-- | guix/swh.scm | 85 |
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))) |