[bug#52555] [RFC PATCH 3/3] publish: Add IPFS support.

[pukkamustard <pukkamustard@posteo.net>]

* guix/scripts/publish.scm: (show-help, %options): Add '--ipfs'.
  (render-narinfo/cached, bake-narinfo+nar, make-request-handler, run-publish-server): Add #:ipfs? and honor it.
  (guix-publish): Honor '--ipfs' and parameterize %ipfs-base-url.
---
 guix/scripts/publish.scm | 52 +++++++++++++++++++++++++++++++---------
 1 file changed, 41 insertions(+), 11 deletions(-)

diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 8e4b90789b..8e7fb47b9e 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -41,6 +41,8 @@ (define-module (guix scripts publish)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-71)
+  #:use-module (srfi srfi-171)
   #:use-module (web http)
   #:use-module (web request)
   #:use-module (web response)
@@ -52,6 +54,7 @@ (define-module (guix scripts publish)
   #:use-module (guix base64)
   #:use-module (guix config)
   #:use-module (guix derivations)
+  #:use-module ((guix ipfs) #:prefix ipfs:)
   #:use-module (gcrypt hash)
   #:use-module (guix pki)
   #:use-module (gcrypt pk-crypto)
@@ -59,6 +62,8 @@ (define-module (guix scripts publish)
   #:use-module (guix store)
   #:use-module ((guix serialization) #:select (write-file))
   #:use-module (eris)
+  #:use-module (eris read-capability)
+  #:use-module (eris blocks ipfs)
   #:use-module (zlib)
   #:autoload   (lzlib) (call-with-lzip-output-port
                         make-lzip-output-port)
@@ -83,6 +88,7 @@ (define-module (guix scripts publish)
             run-publish-server
             guix-publish))
 
+
 (define (show-help)
   (format #t (G_ "Usage: guix publish [OPTION]...
 Publish ~a over HTTP.\n") %store-directory)
@@ -102,6 +108,8 @@ (define (show-help)
   (display (G_ "
       --cache-bypass-threshold=SIZE
                          serve store items below SIZE even when not cached"))
+  (display (G_ "
+      --ipfs[=GATEWAY]   publish items over IPFS via GATEWAY"))
   (display (G_ "
       --workers=N        use N workers to bake items"))
   (display (G_ "
@@ -220,6 +228,10 @@ (define %options
                 (lambda (opt name arg result)
                   (alist-cons 'cache-bypass-threshold (size->number arg)
                               result)))
+        (option '("ipfs") #f #t
+                (lambda (opt name arg result)
+                  (alist-cons 'ipfs (or arg (ipfs:%ipfs-base-url))
+                              result)))
         (option '("workers") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'workers (string->number* arg)
@@ -526,7 +538,7 @@ (define (bypass-cache? store item)
 (define* (render-narinfo/cached store request hash
                                 #:key ttl (compressions (list %no-compression))
                                 (nar-path "nar") negative-ttl
-                                cache pool)
+                                cache pool ipfs?)
   "Respond to the narinfo request for REQUEST.  If the narinfo is available in
 CACHE, then send it; otherwise, return 404 and \"bake\" that nar and narinfo
 requested using POOL."
@@ -571,7 +583,8 @@ (define (delete-entry narinfo)
                  (bake-narinfo+nar cache item
                                    #:ttl ttl
                                    #:compressions compressions
-                                   #:nar-path nar-path)))
+                                   #:nar-path nar-path
+                                   #:ipfs? ipfs?)))
 
              (when ttl
                (single-baker 'cache-cleanup
@@ -631,7 +644,7 @@ (define (write-compressed-file call-with-compressed-output-port)
 
 (define* (bake-narinfo+nar cache item
                            #:key ttl (compressions (list %no-compression))
-                           (nar-path "/nar"))
+                           (nar-path "/nar") ipfs?)
   "Write the narinfo and nar for ITEM to CACHE."
   (define (compressed-nar-size compression)
     (let* ((nar  (nar-cache-file cache item #:compression compression))
@@ -641,9 +654,19 @@ (define (compressed-nar-size compression)
 
   (define (compressed-eris-urn compression)
     (let* ((nar (nar-cache-file cache item #:compression compression))
-           (stat (stat nar #f)))
+           (stat (stat nar #f))
+           (block-reducer (if ipfs?
+                              (eris-blocks-ipfs-reducer
+                               #:ipfs-base-url (ipfs:%ipfs-base-url))
+                              rcount)))
       (and stat
-           (cons compression (call-with-input-file nar eris-encode->urn)))))
+           (cons compression
+                 (call-with-input-file nar
+                   (lambda (port)
+                     (let ((read-cap _
+                                     (eris-encode port #:block-reducer
+                                                  block-reducer)))
+                       (read-capability->string read-cap))))))))
 
   (let ((compression (actual-compressions item compressions)))
 
@@ -1115,7 +1138,8 @@ (define* (make-request-handler store
                                cache pool
                                narinfo-ttl narinfo-negative-ttl
                                (nar-path "nar")
-                               (compressions (list %no-compression)))
+                               (compressions (list %no-compression))
+                               ipfs?)
   (define compression-type?
     string->compression-type)
 
@@ -1147,7 +1171,8 @@ (define (handle request body)
                                       #:ttl narinfo-ttl
                                       #:negative-ttl narinfo-negative-ttl
                                       #:nar-path nar-path
-                                      #:compressions compressions)
+                                      #:compressions compressions
+                                      #:ipfs? ipfs?)
                (render-narinfo store request hash
                                #:ttl narinfo-ttl
                                #:negative-ttl narinfo-negative-ttl
@@ -1218,7 +1243,7 @@ (define* (run-publish-server socket store
                              advertise? port
                              (compressions (list %no-compression))
                              (nar-path "nar") narinfo-ttl narinfo-negative-ttl
-                             cache pool)
+                             cache pool ipfs?)
   (when advertise?
     (let ((name (service-name)))
       ;; XXX: Use a callback from Guile-Avahi here, as Avahi can pick a
@@ -1234,7 +1259,8 @@ (define* (run-publish-server socket store
                                     #:nar-path nar-path
                                     #:narinfo-ttl narinfo-ttl
                                     #:narinfo-negative-ttl narinfo-negative-ttl
-                                    #:compressions compressions)
+                                    #:compressions compressions
+                                    #:ipfs? ipfs?)
               concurrent-http-server
               `(#:socket ,socket)))
 
@@ -1296,6 +1322,8 @@ (define-command (guix-publish . args)
            (repl-port (assoc-ref opts 'repl))
            (cache     (assoc-ref opts 'cache))
            (workers   (assoc-ref opts 'workers))
+           (ipfs      (assoc-ref opts 'ipfs))
+           (ipfs?     (if ipfs #t #f))
 
            ;; Read the key right away so that (1) we fail early on if we can't
            ;; access them, and (2) we can then drop privileges.
@@ -1315,7 +1343,8 @@ (define-command (guix-publish . args)
                      (%private-key private-key)
                      (cache-bypass-threshold
                       (or (assoc-ref opts 'cache-bypass-threshold)
-                          (cache-bypass-threshold))))
+                          (cache-bypass-threshold)))
+                     (ipfs:%ipfs-base-url ipfs))
         (info (G_ "publishing ~a on ~a, port ~d~%")
               %store-directory
               (inet-ntop (sockaddr:fam address) (sockaddr:addr address))
@@ -1344,7 +1373,8 @@ (define-command (guix-publish . args)
                               #:nar-path nar-path
                               #:compressions compressions
                               #:narinfo-negative-ttl negative-ttl
-                              #:narinfo-ttl ttl))))))
+                              #:narinfo-ttl ttl
+                              #:ipfs? ipfs?))))))
 
 ;;; Local Variables:
 ;;; eval: (put 'single-baker 'scheme-indent-function 1)
-- 
2.34.0