From f44a1e0b528bc22ce0b861136efcee808c9783a6 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 28 Dec 2020 17:52:21 +0100
Subject: DRAFT publish: Handle /digest and /content URLs.

DRAFT: Missing tests, missing compression for /content, missing
'--cache' support for /content and /digest.

* guix/digests.scm (digest->sexp): New procedure.
* guix/scripts/publish.scm (render-digest)
(render-content-addressed-data): New procedures.
(make-request-handler): Handle /content and /digest.
---
 guix/digests.scm         | 23 ++++++++++++++++++++++-
 guix/scripts/publish.scm | 39 ++++++++++++++++++++++++++++++++++++++-
 2 files changed, 60 insertions(+), 2 deletions(-)

diff --git a/guix/digests.scm b/guix/digests.scm
index a1db2148d1..9b09b010f6 100644
--- a/guix/digests.scm
+++ b/guix/digests.scm
@@ -39,7 +39,9 @@
             store-deduplication-link
             file-tree-digest
             file-digest
-            restore-digest))
+            restore-digest
+
+            digest->sexp))
 
 ;;; Commentary:
 ;;;
@@ -211,3 +213,22 @@ false."
        (symlink source target)
        (utime target 1 1 0 0 AT_SYMLINK_NOFOLLOW)
        missing))))
+
+(define (digest->sexp digest)
+  "Return an sexp serialization of DIGEST."
+  (define (->sexp digest)
+    (match digest
+      (($ <digest> 'directory _ entries)
+       `(d ,@(map (match-lambda
+                    (($ <digest-entry> name digest)
+                     `(,name ,(->sexp digest))))
+                  entries)))
+      (($ <digest> (and type (or 'executable 'regular)) size
+                   (algorithm hash))
+       `(,(if (eq? type 'executable) 'x 'f) ,size
+         (,algorithm ,(bytevector->nix-base32-string hash))))
+      (($ <digest> 'symlink _ target)
+       `(l ,target))))
+
+  `(digest (version 0)
+           ,(->sexp digest)))
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 5a865c838d..ddaad08110 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -53,6 +53,8 @@
   #:use-module (guix workers)
   #:use-module (guix store)
   #:use-module ((guix serialization) #:select (write-file))
+  #:autoload   (guix digests) (store-deduplication-link
+                               file-digest digest->sexp)
   #:use-module (zlib)
   #:autoload   (lzlib) (call-with-lzip-output-port
                         make-lzip-output-port)
@@ -405,6 +407,13 @@ appropriate duration.  NAR-PATH specifies the prefix for nar URLs."
                                   #:compressions compressions)
                   <>)))))
 
+(define* (render-digest store request hash)
+  (let ((item (hash-part->path store hash)))
+    (if (string-null? item)
+        (not-found request #:phrase "")
+        (values `((content-type . (application/x-guix-digest)))
+                (object->string (digest->sexp (file-digest item)))))))
+
 (define* (nar-cache-file directory item
                              #:key (compression %no-compression))
   (string-append directory "/"
@@ -746,6 +755,21 @@ has the given HASH of type ALGO."
             (not-found request)))
       (not-found request)))
 
+(define* (render-content-addressed-data request algo hash
+                                        #:key (compression %no-compression))
+  "Return the file with HASH, a nar hash, from the content-addressed store."
+  (if (and (eq? algo 'sha256) (= 32 (bytevector-length hash)))
+      (let* ((file (store-deduplication-link hash))
+             (stat (stat file #f)))
+        (if stat
+            (values `((content-type . (application/octet-stream
+                                       (charset . "ISO-8859-1")))
+                      ;; TODO: Set 'Content-Encoding' to COMPRESSION.
+                      (x-raw-file . ,file))
+                    #f)
+            (not-found request)))
+      (not-found request)))
+
 (define (render-log-file store request name)
   "Render the log file for NAME, the base name of a store item.  Don't attempt
 to compress or decompress the log file; just return it as-is."
@@ -1006,7 +1030,7 @@ methods, return the applicable compression."
                                #:ttl narinfo-ttl
                                #:nar-path nar-path
                                #:compressions compressions)))
-          ;; /nar/file/NAME/sha256/HASH
+          ;; /file/NAME/sha256/HASH
           (("file" name "sha256" hash)
            (guard (c ((invalid-base32-character? c)
                       (not-found request)))
@@ -1014,6 +1038,19 @@ methods, return the applicable compression."
                (render-content-addressed-file store request
                                               name 'sha256 hash))))
 
+          ;; /content/sha256/HASH
+          (("content" "sha256" hash)
+           (guard (c ((invalid-base32-character? c)
+                      (not-found request)))
+             (let ((hash (nix-base32-string->bytevector hash)))
+               (render-content-addressed-data request 'sha256 hash
+                                              #:compression
+                                              (first compressions)))))
+
+          ;; /digest/HASH
+          (("digest" hash)
+           (render-digest store request hash))
+
           ;; /log/OUTPUT
           (("log" name)
            (render-log-file store request name))
-- 
cgit 1.4.1