[bug#52555] [PATCH v3 8/8] eris: Use IPFS to get ERIS blocks.

[pukkamustard <pukkamustard@posteo.net>]

* guix/eris/ipfs.scm: New files.
* Makefile.am (MODULES): Add it.
* guix/eris.scm (%eris-peers): Add IPFS.
  (peer->block-ref): Handle IPFS peer.
---
 Makefile.am        |   1 +
 guix/eris.scm      |  32 ++++---
 guix/eris/ipfs.scm | 214 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 237 insertions(+), 10 deletions(-)
 create mode 100644 guix/eris/ipfs.scm

diff --git a/Makefile.am b/Makefile.am
index 373f6b7c27..6f648a40a3 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -135,6 +135,7 @@ MODULES =					\
   guix/eris.scm                                 \
   guix/eris/fs-store.scm                        \
   guix/eris/http.scm                            \
+  guix/eris/ipfs.scm                            \
   guix/platform.scm                             \
   guix/platforms/arm.scm                        \
   guix/platforms/mips.scm                       \
diff --git a/guix/eris.scm b/guix/eris.scm
index d56643bec4..5b0c1ee36b 100644
--- a/guix/eris.scm
+++ b/guix/eris.scm
@@ -22,6 +22,7 @@ (define-module (guix eris)
   #:use-module (guix config)
   #:use-module (guix eris fs-store)
   #:use-module (guix eris http)
+  #:use-module (guix eris ipfs)
 
   #:use-module (web uri)
   #:use-module (ice-9 match)
@@ -42,8 +43,10 @@ (define (guix-eris-block-reducer)
 
 (define %eris-peers
   (make-parameter
-   ;; TODO
-   (list (string->uri "http://localhost:8081"))))
+   ;; TODO: make ERIS peers configurable somewhere
+   (list
+    (string->uri "http://localhost:8081")
+    'ipfs)))
 
 (define* (try-in-order ref #:key block-refs)
   (match block-refs
@@ -55,18 +58,27 @@ (define* (try-in-order ref #:key block-refs)
     (() #f)))
 
 (define* (peer->block-ref peer #:key open-connection)
-  (case (uri-scheme peer)
+  (cond
+   ((uri? peer) (case (uri-scheme peer)
 
-    ((http https)
-     (lambda (ref)
-       (eris-http-block-ref ref
-                            #:host peer
-                            #:open-connection open-connection)))
+                  ((http https)
+                   (lambda (ref)
+                     (eris-http-block-ref ref
+                                          #:host peer
+                                          #:open-connection open-connection)))
 
-    ;; unsupported ERIS peer URL
-    (else (lambda (_) #f))))
+                  ;; unsupported ERIS peer URL
+                  (else (lambda (_) #f))))
+
+   ((eqv? 'ipfs peer)
+    (lambda (ref)
+      (eris-ipfs-ref ref #:open-connection open-connection)))))
 
 (define* (guix-eris-block-ref ref #:key open-connection)
+  "Attempts to dereference a block of some ERIS encoded content with reference
+REF. First the local block store is checked, followed by remote peers as
+configured in the parameter %eris-peers (in order). Returns #f if the block
+could not be de-referenced."
   (try-in-order
    ref
    #:block-refs
diff --git a/guix/eris/ipfs.scm b/guix/eris/ipfs.scm
new file mode 100644
index 0000000000..9771414e7b
--- /dev/null
+++ b/guix/eris/ipfs.scm
@@ -0,0 +1,214 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; 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/>.
+
+
+;;; Commentary:
+;;;
+;;; This module provides an interface to the IPFS daemons HTTP API for storing
+;;; and retrieving blocks. This can be used to store blocks of ERIS encoded
+;;; content.
+;;; 
+;;; See also the IPFS API documentation:
+;;; https://docs.ipfs.io/reference/http/api/#api-v0-block-put
+
+(define-module (guix eris ipfs)
+  #:use-module (eris utils base32)
+  #:use-module (sodium generichash)
+  #:use-module (json)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (srfi srfi-71)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
+
+  #:use-module ((guix build download)
+                #:select ((open-connection-for-uri
+                           . guix:open-connection-for-uri)))
+  #:export (%ipfs-base-url
+
+	    eris-ipfs-reducer
+            eris-ipfs-ref))
+
+
+;; CID encoding
+
+;; Multicodec codes
+;; (https://github.com/multiformats/multicodec/blob/master/table.csv)
+(define multicodec-raw-code #x55)
+(define multicodec-blake2b-256-code #xb220)
+
+(define (blake2b-256->binary-cid hash)
+  "Encode a Blake2b-256 hash as binary CID"
+  (call-with-values
+      (lambda () (open-bytevector-output-port))
+    (lambda (port get-bytevector)
+      ;; CID version
+      (put-u8 port 1)
+      ;; multicoded content-type
+      (put-u8 port multicodec-raw-code)
+      ;; set multihash to blake2b-256. This is the manually encoded varint of
+      ;; 0xb220
+      (put-u8 port 160) (put-u8 port 228) (put-u8 port 2)
+      ;; set hash lenght
+      (put-u8 port 32)
+      ;; and finally the hash itself
+      (put-bytevector port hash)
+
+      ;; finalize and get the bytevector
+      (get-bytevector))))
+
+(define (binary-cid->cid bcid)
+  "Encode a binary CID as Base32 encoded CID"
+  ;; 'b' is the multibsae code for base32
+  (string-append "b"
+                 ;; the IPFS daemon uses lower-case, so to be consistent we
+                 ;; also.
+                 (string-downcase
+                  ;; base32 encode the binary cid
+                  (base32-encode bcid))))
+
+(define blake2b-256->cid
+  (compose binary-cid->cid blake2b-256->binary-cid))
+
+
+;; IPFS API
+
+(define %ipfs-base-url
+  ;; URL of the IPFS gateway.
+  (make-parameter "http://localhost:5001"))
+
+(define* (call url decode
+               #:optional
+               (method http-post)
+               #:key port body (false-if-404? #t) (headers '())
+               (keep-alive #t)
+               (open-connection guix:open-connection-for-uri)
+               (timeout 10))
+  "Invoke the endpoint at URL using METHOD.  Decode the resulting JSON body
+using DECODE, a one-argument procedure that takes an input port; when DECODE
+is false, return the input port.  When FALSE-IF-404? is true, return #f upon
+404 responses."
+  (let* ((url (if (string? url) (string->uri url)  url))
+         (port (or port (open-connection url #:timeout timeout)))
+         (response response-port
+                   (if keep-alive
+                       (method url #:streaming? #t
+                               #:body body
+                               #:port port
+                               #:keep-alive? #t)
+                       (method url #:streaming? #t
+                               #:body body
+                               #:port port
+                               ;; IPFS daemon seems to responds with bad
+                               ;; request if PUT requests are kept alive and
+                               ;; do not have "Connection: close" header.
+                               #:keep-alive? #f
+                               #:headers `((connection close)
+                                           ,@headers)))))
+    (cond ((= 200 (response-code response))
+           (if decode
+               (let ((result (decode response-port)))
+                 (close-port response-port)
+                 result)
+               response-port))
+          ((and false-if-404?
+                (= 404 (response-code response)))
+           (close-port response-port)
+           #f)
+          (else
+           (close-port response-port)
+           (format #t "~a\n" response)
+           (throw 'ipfs-error url response)))))
+
+(define-syntax-rule (false-if-ipfs-error exp)
+  "Return $f if EXP triggers a network related or IPFS related exception."
+  (with-exception-handler
+      (lambda (exn)
+        (let ((kind (exception-kind exn))
+              (errno (system-error-errno
+                      (cons 'system-error (exception-args exn)))))
+          (cond
+           ((= errno ECONNREFUSED) #f)
+           (else (raise-exception exp)))))
+    (lambda () exp)
+    #:unwind? #t))
+
+(define %multipart-boundary
+  ;; XXX: We might want to find a more reliable boundary.
+  (string-append (make-string 24 #\-) "2698127afd7425a6"))
+
+(define (bytevector->form-data bv port)
+  "Write to PORT a 'multipart/form-data' representation of BV."
+  (display (string-append "--" %multipart-boundary "\r\n"
+                          "Content-Disposition: form-data\r\n"
+                          "Content-Type: application/octet-stream\r\n\r\n")
+           port)
+  (put-bytevector port bv)
+  (display (string-append "\r\n--" %multipart-boundary "--\r\n")
+           port))
+
+(define (ipfs-block-put bv)
+  "Store a block on IPFS and return the CID of the block"
+  (call (string-append (%ipfs-base-url)
+                       "/api/v0/block/put"
+                       "?format=raw&mhtype=blake2b-256")
+        (lambda (port) (assoc-ref (json->scm port) "Key"))
+        #:headers `((content-type
+                     . (multipart/form-data
+                        (boundary . ,%multipart-boundary))))
+        #:body (call-with-bytevector-output-port
+                (lambda (port) (bytevector->form-data bv port)))
+        ;; IPFS daemon does not seem to accept connection re-use when putting
+        ;; blocks.
+        #:keep-alive #f))
+
+(define* (ipfs-block-get cid #:key
+                         (open-connection guix:open-connection-for-uri))
+  "Get a block from IPFS via the HTTP API"
+  (false-if-ipfs-error
+   (call (string-append (%ipfs-base-url)
+		        "/api/v0/block/get"
+		        "?arg=" cid)
+	 get-bytevector-all
+         #:timeout 5
+         #:open-connection open-connection)))
+
+;; ERIS block reducer
+
+(define eris-ipfs-reducer
+  (case-lambda
+    ;; initialization. Nothing to do here. In an improved implementation we
+    ;; might create a single HTTP connection and reuse it for all blocks.
+    (() '())
+
+    ;; Completion. Again, nothing to do.
+    ((_) 'done)
+
+    ;; store a block
+    ((_ ref-block)
+     ;; ref-block is a pair consisting of the reference to the block and the
+     ;; block itself.
+     (ipfs-block-put (cdr ref-block)))))
+
+(define* (eris-ipfs-ref ref #:key
+                        (open-connection guix:open-connection-for-uri))
+  "Dereference a block from IPFS"
+  (ipfs-block-get (blake2b-256->cid ref)
+                  #:open-connection open-connection))
-- 
2.38.1