[bug#69328] [PATCH 06/12] swh: ‘lookup-origin-revision’ handles branches pointing to directories.

["Ludovic Courtès" <ludo@gnu.org>]

Fixes <https://issues.guix.gnu.org/69070>.

* guix/swh.scm (branch-target): Add clause for 'directory and 'alias.
(lookup-origin-revision): Iterate over all the visits of ORIGIN instead
of just the first one.  Handle the case where ‘branch-target’ returns
something other than a release or revision.
* tests/swh.scm ("lookup-origin-revision"): New test.

Change-Id: I7f636739a719908763bca1d3e7376341dd62e816
---
 guix/swh.scm  | 60 ++++++++++++++++++++++-------------------
 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 @@ (define (lookup-snapshot-branch snapshot name)
           (_ #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 @@ (define (lookup-origin-revision url tag)
   (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 @@ (define-syntax-rule (with-json-result str exp ...)
                  (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
-- 
2.41.0