diff options
| -rw-r--r-- | guix/swh.scm | 60 | ||||
| -rw-r--r-- | tests/swh.scm | 74 |
2 files changed, 107 insertions, 27 deletions
diff --git a/guix/swh.scm b/guix/swh.scm index 14c65f6806..f602cd89d1 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -516,14 +516,20 @@ could not be found." (_ #f))))) (define (branch-target branch) - "Return the target of BRANCH, either a <revision> or a <release>." + "Return the target of BRANCH: a <revision>, a <release>, or the SWHID of a +directory." (match (branch-target-type branch) ('release (call (swh-url (branch-target-url branch)) json->release)) ('revision (call (swh-url (branch-target-url branch)) - json->revision)))) + json->revision)) + ((or 'directory 'alias) + (match (string-tokenize (branch-target-url branch) + (char-set-complement (char-set #\/))) + ((_ ... "directory" id) + (string-append "swh:1:dir:" id)))))) (define (lookup-origin-revision url tag) "Return a <revision> corresponding to the given TAG for the repository @@ -537,31 +543,31 @@ URL could not be found." (match (lookup-origin url) (#f #f) (origin - (match (filter (lambda (visit) - ;; Return #f if (visit-snapshot VISIT) would return #f. - (and (visit-snapshot-url visit) - (eq? 'full (visit-status visit)))) - (origin-visits origin)) - ((visit . _) - (let ((snapshot (visit-snapshot visit))) - (match (and=> (find (lambda (branch) - (or - ;; Git specific. - (string=? (string-append "refs/tags/" tag) - (branch-name branch)) - ;; Hg specific. - (string=? tag - (branch-name branch)))) - (snapshot-branches snapshot)) - branch-target) - ((? release? release) - (release-target release)) - ((? revision? revision) - revision) - (#f ;tag not found - #f)))) - (() - #f))))) + (any (lambda (visit) + (and (visit-snapshot-url visit) + (eq? 'full (visit-status visit)) + (let ((snapshot (visit-snapshot visit))) + (match (and=> (find (lambda (branch) + (or + ;; Git specific. + (string=? (string-append "refs/tags/" tag) + (branch-name branch)) + ;; Hg specific. + (string=? tag + (branch-name branch)))) + (snapshot-branches snapshot)) + branch-target) + ((? release? release) + (release-target release)) + ((? revision? revision) + revision) + (_ + ;; Either the branch points to a directory rather than + ;; a revision (this is the case for visits of type + ;; 'git-checkout, 'hg-checkout, 'tarball-directory, + ;; etc.), or TAG was not found. + #f))))) + (origin-visits origin 30))))) (define (release-target release) "Return the revision that is the target of RELEASE." diff --git a/tests/swh.scm b/tests/swh.scm index e7ced6b50c..11dcbdddd8 100644 --- a/tests/swh.scm +++ b/tests/swh.scm @@ -109,6 +109,80 @@ (directory-entry-length entry))) (lookup-directory "123")))) +(test-equal "lookup-origin-revision" + '("cd86c72084993d9ef26fc9e24b73cea612b8c97b" + "d173c707ee88e3c89401ad77fafa65fcd9e9f5be") + (let () + ;; Make sure that 'lookup-origin-revision' does the job, and in particular + ;; that it doesn't stop until it has found an actual revision: + ;; 'git-checkout visits point to directories instead of revisions. + ;; See <https://issues.guix.gnu.org/69070>. + (define visits + ;; Two visits of differing types: the first visit (type 'git-checkout') + ;; points to a directory, the second one (type 'git') points to a + ;; revision. + "[ { + \"origin\": \"https://example.org/repo.git\", + \"visit\": 1, + \"type\": \"git-checkout\", + \"date\": \"2020-05-17T21:43:45.422977+00:00\", + \"status\": \"full\", + \"metadata\": {}, + \"type\": \"git-checkout\", + \"origin_visit_url\": \"/visit/42\", + \"snapshot_url\": \"/snapshot/1\" + }, { + \"origin\": \"https://example.org/repo.git\", + \"visit\": 2, + \"type\": \"git\", + \"date\": \"2020-05-17T21:43:49.422977+00:00\", + \"status\": \"full\", + \"metadata\": {}, + \"type\": \"git\", + \"origin_visit_url\": \"/visit/41\", + \"snapshot_url\": \"/snapshot/2\" + } ]") + (define snapshot-for-git-checkout + "{ \"id\": 42, + \"branches\": { \"1.3.2\": { + \"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\", + \"target_type\": \"directory\", + \"target_url\": \"/directory/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\" + }} + }") + (define snapshot-for-git + "{ \"id\": 42, + \"branches\": { \"1.3.2\": { + \"target\": \"e4a4be18fae8d9c6528abff3bc9088feb19a76c7\", + \"target_type\": \"revision\", + \"target_url\": \"/revision/e4a4be18fae8d9c6528abff3bc9088feb19a76c7\" + }} + }") + (define revision + "{ \"author\": {}, + \"committer\": {}, + \"committer_date\": \"2018-05-17T21:43:49.422977+00:00\", + \"date\": \"2018-05-17T21:43:49.422977+00:00\", + \"directory\": \"d173c707ee88e3c89401ad77fafa65fcd9e9f5be\", + \"directory_url\": \"/directory/d173c707ee88e3c89401ad77fafa65fcd9e9f5be\", + \"id\": \"cd86c72084993d9ef26fc9e24b73cea612b8c97b\", + \"merge\": false, + \"message\": \"Fix.\", + \"parents\": [], + \"type\": \"what type?\" + }") + + (with-http-server `((200 ,%origin) + (200 ,visits) + (200 ,snapshot-for-git-checkout) + (200 ,snapshot-for-git) + (200 ,revision)) + (parameterize ((%swh-base-url (%local-url))) + (let ((revision (lookup-origin-revision "https://example.org/repo.git" + "1.3.2"))) + (list (revision-id revision) + (revision-directory revision))))))) + (test-equal "lookup-directory-by-nar-hash" "swh:1:dir:84a8b34591712c0a90bab0af604188bcd1fe3153" (with-json-result %external-id |