Merge remote-tracking branch core-updates-frozen into core-updates

1 files changed, 96 insertions, 30 deletions

diff --git a/guix/swh.scm b/guix/swh.scm
index b5c800011d..a62567dd58 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -55,6 +55,11 @@
             visit-number
             visit-snapshot
 
+            snapshot?
+            snapshot-id
+            snapshot-branches
+            lookup-snapshot-branch
+
             branch?
             branch-name
             branch-target
@@ -99,10 +104,9 @@
             vault-reply?
             vault-reply-id
             vault-reply-fetch-url
-            vault-reply-object-id
-            vault-reply-object-type
             vault-reply-progress-message
             vault-reply-status
+            vault-reply-swhid
             query-vault
             request-cooking
             vault-fetch
@@ -183,6 +187,12 @@ Software Heritage."
                                  (ref 10))))))
       str))                                       ;oops!
 
+(define (maybe-null proc)
+  (match-lambda
+    ((? null?) #f)
+    ('null #f)
+    (obj (proc obj))))
+
 (define string*
   ;; Converts "string or #nil" coming from JSON to "string or #f".
   (match-lambda
@@ -287,6 +297,7 @@ FALSE-IF-404? is true, return #f upon 404 responses."
 ;; <https://archive.softwareheritage.org/api/1/snapshot/4334c3ed4bb208604ed780d8687fe523837f1bd1/>
 (define-json-mapping <snapshot> make-snapshot snapshot?
   json->snapshot
+  (id       snapshot-id)
   (branches snapshot-branches "branches" json->branches))
 
 ;; This is used for the "branches" field of snapshots.
@@ -316,10 +327,13 @@ FALSE-IF-404? is true, return #f upon 404 responses."
   (target-url  release-target-url "target_url"))
 
 ;; <https://archive.softwareheritage.org/api/1/revision/359fdda40f754bbf1b5dc261e7427b75463b59be/>
+;; Note: Some revisions, such as those for "nixguix" origins (e.g.,
+;; <https://archive.softwareheritage.org/api/1/revision/b8dbc65475bbedde8e015d4730ade8864c38fad3/>),
+;; have their 'date' field set to null.
 (define-json-mapping <revision> make-revision revision?
   json->revision
   (id            revision-id)
-  (date          revision-date "date" string->date*)
+  (date          revision-date "date" (maybe-null string->date*))
   (directory     revision-directory)
   (directory-url revision-directory-url "directory_url"))
 
@@ -376,10 +390,9 @@ FALSE-IF-404? is true, return #f upon 404 responses."
   json->vault-reply
   (id             vault-reply-id)
   (fetch-url      vault-reply-fetch-url "fetch_url")
-  (object-id      vault-reply-object-id "obj_id")
-  (object-type    vault-reply-object-type "obj_type" string->symbol)
   (progress-message vault-reply-progress-message "progress_message")
-  (status         vault-reply-status "status" string->symbol))
+  (status         vault-reply-status "status" string->symbol)
+  (swhid          vault-reply-swhid))
 
 
 ;;;
@@ -426,6 +439,32 @@ available."
        (call (swh-url (visit-snapshot-url visit))
              json->snapshot)))
 
+(define (snapshot-url snapshot branch-count first-branch)
+  "Return the URL of SNAPSHOT such that it contains information for
+BRANCH-COUNT branches, starting at FIRST-BRANCH."
+  (string-append (swh-url "/api/1/snapshot" (snapshot-id snapshot))
+                 "?branches_count=" (number->string branch-count)
+                 "&branches_from=" (uri-encode first-branch)))
+
+(define (lookup-snapshot-branch snapshot name)
+  "Look up branch NAME on SNAPSHOT.  Return the branch, or return #f if it
+could not be found."
+  (or (find (lambda (branch)
+              (string=? (branch-name branch) name))
+            (snapshot-branches snapshot))
+
+      ;; There's no API entry point to look up a snapshot branch by name.
+      ;; Work around that by using the paginated list of branches provided by
+      ;; the /api/1/snapshot API: ask for one branch, and start pagination at
+      ;; NAME.
+      (let ((snapshot (call (snapshot-url snapshot 1 name)
+                            json->snapshot)))
+        (match (snapshot-branches snapshot)
+          ((branch)
+           (and (string=? (branch-name branch) name)
+                branch))
+          (_ #f)))))
+
 (define (branch-target branch)
   "Return the target of BRANCH, either a <revision> or a <release>."
   (match (branch-target-type branch)
@@ -499,35 +538,57 @@ directory entries; if it has type 'file, return its <content> object."
   (path "/api/1/origin/save" type "url" url)
   json->save-reply)
 
-(define-query (query-vault id kind)
-  "Ask the availability of object ID and KIND to the vault, where KIND is
-'directory or 'revision.  Return #f if it could not be found, or a
-<vault-reply> on success."
-  ;; <https://docs.softwareheritage.org/devel/swh-vault/api.html#vault-api-ref>
-  ;; There's a single format supported for directories and revisions and for
-  ;; now, the "/format" bit of the URL *must* be omitted.
-  (path "/api/1/vault" (symbol->string kind) id)
-  json->vault-reply)
+(define* (vault-url id kind #:optional (archive-type 'flat))
+  "Return the vault query/cooking URL for ID and KIND.  Normally, ID is an
+SWHID and KIND is #f; the deprecated convention is to set ID to a raw
+directory or revision ID and KIND to 'revision or 'directory."
+  ;; Note: /api/1/vault/directory/ID was deprecated in favor of
+  ;; /api/1/vault/flat/SWHID; this procedure "converts" automatically.
+  (let ((id (match kind
+              ('directory (string-append "swh:1:dir:" id))
+              ('revision  (string-append "swh:1:rev:" id))
+              (#f         id))))
+    (swh-url "/api/1/vault" (symbol->string archive-type) id)))
+
+(define* (query-vault id #:optional kind #:key (archive-type 'flat))
+  "Ask the availability of object ID (an SWHID) to the vault.  Return #f if it
+could not be found, or a <vault-reply> on success.  ARCHIVE-TYPE can be 'flat
+for a tarball containing a directory, or 'git-bare for a tarball containing a
+bare Git repository corresponding to a revision.
+
+Passing KIND (one of 'directory or 'revision) together with a raw revision or
+directory identifier is deprecated."
+  (call (vault-url id kind archive-type)
+        json->vault-reply))
+
+(define* (request-cooking id #:optional kind #:key (archive-type 'flat))
+  "Request the cooking of object ID, an SWHID.  Return a <vault-reply>.
+ARCHIVE-TYPE can be 'flat for a tarball containing a directory, or 'git-bare
+for a tarball containing a bare Git repository corresponding to a revision.
 
-(define (request-cooking id kind)
-  "Request the cooking of object ID and KIND (one of 'directory or 'revision)
-to the vault.  Return a <vault-reply>."
-  (call (swh-url "/api/1/vault" (symbol->string kind) id)
+Passing KIND (one of 'directory or 'revision) together with a raw revision or
+directory identifier is deprecated."
+  (call (vault-url id kind archive-type)
         json->vault-reply
         http-post*))
 
-(define* (vault-fetch id kind
-                      #:key (log-port (current-error-port)))
-  "Return an input port from which a bundle of the object with the given ID
-and KIND (one of 'directory or 'revision) can be retrieved, or #f if the
-object could not be found.
+(define* (vault-fetch id
+                      #:optional kind
+                      #:key
+                      (archive-type 'flat)
+                      (log-port (current-error-port)))
+  "Return an input port from which a bundle of the object with the given ID,
+an SWHID, or #f if the object could not be found.
 
-For a directory, the returned stream is a gzip-compressed tarball.  For a
-revision, it is a gzip-compressed stream for 'git fast-import'."
-  (let loop ((reply (query-vault id kind)))
+ARCHIVE-TYPE can be 'flat for a tarball containing a directory, or 'git-bare
+for a tarball containing a bare Git repository corresponding to a revision."
+  (let loop ((reply (query-vault id kind
+                                 #:archive-type archive-type)))
     (match reply
       (#f
-       (and=> (request-cooking id kind) loop))
+       (and=> (request-cooking id kind
+                               #:archive-type archive-type)
+              loop))
       (_
        (match (vault-reply-status reply)
          ('done
@@ -547,7 +608,8 @@ revision, it is a gzip-compressed stream for 'git fast-import'."
           (format log-port "SWH vault: failure: ~a~%"
                   (vault-reply-progress-message reply))
           (format log-port "SWH vault: retrying...~%")
-          (loop (request-cooking id kind)))
+          (loop (request-cooking id kind
+                                 #:archive-type archive-type)))
          ((and (or 'new 'pending) status)
           ;; Wait until the bundle shows up.
           (let ((message (vault-reply-progress-message reply)))
@@ -562,7 +624,8 @@ requested bundle cooking, waiting for completion...~%"))
             ;; requests per hour per IP address.)
             (sleep (if (eq? status 'new) 60 30))
 
-            (loop (query-vault id kind)))))))))
+            (loop (query-vault id kind
+                               #:archive-type archive-type)))))))))
 
 
 ;;;
@@ -634,4 +697,7 @@ wait until it becomes available, which could take several minutes."
      (swh-download-directory (revision-directory revision) output
                              #:log-port log-port))
     (#f
+     (format log-port
+             "SWH: revision ~s originating from ~a could not be found~%"
+             reference url)
      #f)))