From 90c98b5a89038c41a0db0add9e2a3d4d1a1b6102 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 23 Aug 2019 18:16:13 +0200 Subject: swh: 'swh-download' checks return value of 'vault-fetch'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Reported by Björn Höfling in . * guix/swh.scm (swh-download): Check whether 'vault-fetch' return false before calling 'dump-port'. --- guix/swh.scm | 31 +++++++++++++++++-------------- 1 file changed, 17 insertions(+), 14 deletions(-) (limited to 'guix/swh.scm') diff --git a/guix/swh.scm b/guix/swh.scm index df2a138f04..1c416c8dd5 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -547,19 +547,22 @@ wait until it becomes available, which could take several minutes." ((? revision? revision) (call-with-temporary-directory (lambda (directory) - (let ((input (vault-fetch (revision-directory revision) 'directory)) - (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)))))) + (match (vault-fetch (revision-directory revision) 'directory) + (#f + #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)))))))) (#f #f))) -- cgit v1.2.3 From b8815c5ec4ee70c535693031072447671c1b781f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 11:10:55 +0200 Subject: swh: 'swh-download' prints debugging info. * guix/git-download.scm (git-fetch): Print a message before calling 'swh-download'. * guix/swh.scm (swh-download): Add #:log-port. Write debugging messages to LOG-PORT. --- guix/git-download.scm | 7 +++++-- guix/swh.scm | 12 ++++++++++-- 2 files changed, 15 insertions(+), 4 deletions(-) (limited to 'guix/swh.scm') diff --git a/guix/git-download.scm b/guix/git-download.scm index 8f84681d46..c62bb8ad0f 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -139,8 +139,11 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ;; As a last resort, attempt to download from Software Heritage. ;; XXX: Currently recursive checkouts are not supported. (and (not recursive?) - (swh-download (getenv "git url") (getenv "git commit") - #$output))))))) + (begin + (format (current-error-port) + "Trying to download from Software Heritage...~%") + (swh-download (getenv "git url") (getenv "git commit") + #$output)))))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build diff --git a/guix/swh.scm b/guix/swh.scm index 1c416c8dd5..b72d1c311e 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -533,7 +533,8 @@ delete it when leaving the dynamic extent of this call." (lambda () (false-if-exception (delete-file-recursively tmp-dir)))))) -(define (swh-download url reference output) +(define* (swh-download url reference output + #:key (log-port (current-error-port))) "Download from Software Heritage a checkout of the Git tag or commit REFERENCE originating from URL, and unpack it in OUTPUT. Return #t on success and #f on failure. @@ -545,10 +546,17 @@ wait until it becomes available, which could take several minutes." (lookup-revision reference) (lookup-origin-revision url reference)) ((? revision? revision) + (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) + (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" "-"))) -- cgit v1.2.3 From 8146c48632d39670afa7a8ec08a8891cc78d2b38 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 28 Aug 2019 11:31:18 +0200 Subject: swh: Correctly handle visits without a snapshot. As discussed at . * guix/swh.scm (string*): New procedure. ()[snapshot-url]: Pass 'string*' as the conversion procedure. [status]: Pass 'string->symbol' as the conversion procedure. (visit-snapshot): Return #f when 'visit-snapshot-url' returns #f. (lookup-origin-revision): Filter to visits for which 'visit-snapshot-url' is true. --- guix/swh.scm | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) (limited to 'guix/swh.scm') diff --git a/guix/swh.scm b/guix/swh.scm index b72d1c311e..c253e217da 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -190,6 +190,12 @@ Software Heritage." (ref 10)))))) str)) ;oops! +(define string* + ;; Converts "string or #nil" coming from JSON to "string or #f". + (match-lambda + ((? string? str) str) + ((? null?) #f))) + (define* (call url decode #:optional (method http-get) #:key (false-if-404? #t)) "Invoke the endpoint at URL using METHOD. Decode the resulting JSON body @@ -239,8 +245,8 @@ FALSE-IF-404? is true, return #f upon 404 responses." (date visit-date "date" string->date*) (origin visit-origin) (url visit-url "origin_visit_url") - (snapshot-url visit-snapshot-url "snapshot_url") - (status visit-status) + (snapshot-url visit-snapshot-url "snapshot_url" string*) ;string | #f + (status visit-status "status" string->symbol) ;'full | 'partial | 'ongoing (number visit-number "visit")) ;; @@ -378,9 +384,11 @@ FALSE-IF-404? is true, return #f upon 404 responses." (map json->visit (vector->list (json->scm port)))))) (define (visit-snapshot visit) - "Return the snapshot corresponding to VISIT." - (call (swh-url (visit-snapshot-url visit)) - json->snapshot)) + "Return the snapshot corresponding to VISIT or #f if no snapshot is +available." + (and (visit-snapshot-url visit) + (call (swh-url (visit-snapshot-url visit)) + json->snapshot))) (define (branch-target branch) "Return the target of BRANCH, either a or a ." @@ -396,7 +404,7 @@ FALSE-IF-404? is true, return #f upon 404 responses." "Return a corresponding to the given TAG for the repository coming from URL. Example: - (lookup-origin-release \"https://github.com/guix-mirror/guix/\" \"v0.8\") + (lookup-origin-revision \"https://github.com/guix-mirror/guix/\" \"v0.8\") => #< id: \"44941…\" …> The information is based on the latest visit of URL available. Return #f if @@ -404,7 +412,7 @@ URL could not be found." (match (lookup-origin url) (#f #f) (origin - (match (origin-visits origin) + (match (filter visit-snapshot-url (origin-visits origin)) ((visit . _) (let ((snapshot (visit-snapshot visit))) (match (and=> (find (lambda (branch) -- cgit v1.2.3