[bug#52555] [PATCH v3 2/8] publish: Store ERIS encoded blocks to a local block store.

[pukkamustard <pukkamustard@posteo.net>]

* guix/eris.scm: New file.
* guix/eris/fs-store.scm: New file.
* Makefile.am (MODULES): Add new files.
* guix/scripts/publish.scm (bake-narinfo+nar): Use guix-eris-block-reducer.
---
 Makefile.am              |  2 ++
 guix/eris.scm            | 36 +++++++++++++++++++++
 guix/eris/fs-store.scm   | 67 ++++++++++++++++++++++++++++++++++++++++
 guix/scripts/publish.scm | 14 +++++----
 4 files changed, 113 insertions(+), 6 deletions(-)
 create mode 100644 guix/eris.scm
 create mode 100644 guix/eris/fs-store.scm

diff --git a/Makefile.am b/Makefile.am
index b54288c0fc..c549fc8580 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -132,6 +132,8 @@ MODULES =					\
   guix/least-authority.scm			\
   guix/read-print.scm				\
   guix/ipfs.scm					\
+  guix/eris.scm                                 \
+  guix/eris/fs-store.scm                        \
   guix/platform.scm                             \
   guix/platforms/arm.scm                        \
   guix/platforms/mips.scm                       \
diff --git a/guix/eris.scm b/guix/eris.scm
new file mode 100644
index 0000000000..29d5e7b1db
--- /dev/null
+++ b/guix/eris.scm
@@ -0,0 +1,36 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 pukkamustard <pukkamustard@posteo.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix eris)
+  #:use-module (eris)
+
+  #:use-module (guix config)
+  #:use-module (guix eris fs-store)
+
+  #:export (guix-eris-block-reducer
+
+            %eris-block-store-directory))
+
+(define %eris-block-store-directory
+  (make-parameter
+   (or (getenv "GUIX_ERIS_BLOCK_STORE_DIRECTORY")
+       (string-append %state-directory "/eris"))))
+
+(define (guix-eris-block-reducer)
+  "Returns a block reducer that stores blocks of ERIS encoded content."
+  (eris-fs-store-reducer (%eris-block-store-directory)))
diff --git a/guix/eris/fs-store.scm b/guix/eris/fs-store.scm
new file mode 100644
index 0000000000..2ef7607988
--- /dev/null
+++ b/guix/eris/fs-store.scm
@@ -0,0 +1,67 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2022 pukkamustard <pukkamustard@posteo.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix eris fs-store)
+  #:use-module (rnrs io ports)
+  #:use-module (guix build utils) ; for mkdir-p
+  #:use-module (eris utils base32)
+
+  #:export (eris-fs-store-reducer
+            eris-fs-store-ref))
+
+;;; Commentary:
+;;;
+;;; This module provides a file-system based store of ERIS encoded blocks.
+;;;
+;;; Code:
+
+(define (eris-fs-store-reducer store-directory)
+  (case-lambda
+    (() (mkdir-p store-directory))
+
+    ((result) result)
+
+    ((_ ref-block)
+     (let* ((ref (car ref-block))
+	    (b32 (base32-encode ref))
+	    (pre (substring b32 0 2))
+	    (suf (substring b32 2))
+	    (pre-dir (string-append store-directory "/" pre))
+	    (path (string-append pre-dir "/" suf))
+	    (block (cdr ref-block)))
+
+       (mkdir-p pre-dir)
+
+       (unless (file-exists? path)
+	 (call-with-output-file path
+	   (lambda (port) (put-bytevector port block))
+	   #:binary #t))
+
+       #t))))
+
+(define (eris-fs-store-ref store-directory)
+  (lambda (ref)
+    (let* ((b32 (base32-encode ref))
+	   (pre (substring b32 0 2))
+	   (suf (substring b32 2))
+	   (path (string-append store-directory "/" pre "/" suf)))
+      (if (file-exists? path)
+	  (call-with-input-file path
+	    (lambda (port) (get-bytevector-all port))
+	    #:binary #t)
+	  #f))))
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index 76b5a429f4..7f14e4d4d4 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -52,6 +52,7 @@ (define-module (guix scripts publish)
   #:use-module (guix base64)
   #:use-module (guix config)
   #:use-module (guix derivations)
+  #:use-module (guix eris)
   #:use-module (gcrypt hash)
   #:use-module (guix pki)
   #:use-module (gcrypt pk-crypto)
@@ -647,12 +648,13 @@ (define (eris-encode-nar compressions)
            (and stat
                 (call-with-input-file nar
                   (lambda (port)
-                    (let ((eris-urn _
-                                    (eris-encode port
-                                                 #:block-size 'large
-                                                 #:block-reducer rcount
-                                                 #:convergence-secret
-                                                 %null-convergence-secret)))
+                    (let ((eris-urn
+                           _ (eris-encode port
+                                          #:block-size 'large
+                                          #:block-reducer
+                                          (guix-eris-block-reducer)
+                                          #:convergence-secret
+                                          %null-convergence-secret)))
                       eris-urn)))))))
 
   (let ((compression (actual-compressions item compressions)))
-- 
2.38.1