05/09: swh: Adjust to new vault API.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit ff613c2b68aac539262822490448e637d8f315ba
Author: Ludovic Courtès <ludovic.courtes@inria.fr>
AuthorDate: Fri Sep 10 11:42:25 2021 +0200

    swh: Adjust to new vault API.
    
    Previously the path to query the vault or request cooking of a directory
    was /api/1/vault/directory/ID.  It is now deprecated in favor if
    /api/1/vault/flat/SWHID.  This commit adjusts code accordingly and also
    prepares for 'git-bare' support.
    
    * guix/swh.scm (vault-url): New procedure.
    (query-vault, request-cooking): Make 'kind' optional, and add 
#:archive-type.
    Use 'vault-url'.
    (vault-fetch): Make 'kind' optional and add #:archive-type.  Adjust
    'query-vault' and 'request-cooking' calls accordingly.
---
 guix/swh.scm | 76 +++++++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 50 insertions(+), 26 deletions(-)

diff --git a/guix/swh.scm b/guix/swh.scm
index 76234b4..3d5d2a4 100644
--- a/guix/swh.scm
+++ b/guix/swh.scm
@@ -538,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 (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)
+(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.
+
+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.
-
-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)))
+(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.
+
+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
@@ -586,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)))
@@ -601,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)))))))))
 
 
 ;;;