Subject: Ludo's patch rebased on master

From: Maxime Devos <[email-masked]>
Date: Tue, 29 Dec 2020 10:59:13 +0100

Hi Guix,

I've rebased Ludovic's patch on master
(08d8c2d3c08e4f35325553e75abc76da40630334),
resolving merge conflicts.

Make and make check succeed, except for
tests/cve.scm and tests/swh.scm. For completeness,
I've attached the logs of the failing tests.
I don't think they rare related to the changes
in the patch, though.

I most likely won't have time to test and complete
this patch in the near future.

On an unrelated note, I've changed e-mail addresses
due to excessive spam-filtering
-- 
Maxime Devos <[email-masked]>
PGP Key: C1F3 3EE2 0C52 8FDB 7DD7  011F 49E3 EE22 1917 25EE
Freenode handle: mdevos
From cc19a6bee26032fa32e83d2435d33dac76bec58d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <[email-masked]>
Date: Mon, 17 Dec 2018 00:05:55 +0100
Subject: [PATCH 1/5] Add (guix json).

* guix/swh.scm: Use (guix json).
(define-json-reader, define-json-mapping): Move to...
* guix/json.scm: ... here.  New file.
* Makefile.am (MODULES): Add it.
---
 Makefile.am   |  1 +
 guix/json.scm | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 64 insertions(+)
 create mode 100644 guix/json.scm

diff --git a/Makefile.am b/Makefile.am
index 1a3ca227a4..81f502d877 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -95,6 +95,7 @@ MODULES =					\
   guix/bzr-download.scm            		\
   guix/git-download.scm				\
   guix/hg-download.scm				\
+  guix/json.scm					\
   guix/swh.scm					\
   guix/monads.scm				\
   guix/monad-repl.scm				\
diff --git a/guix/json.scm b/guix/json.scm
new file mode 100644
index 0000000000..d446f6894e
--- /dev/null
+++ b/guix/json.scm
@@ -0,0 +1,63 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <[email-masked]>
+;;;
+;;; 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 json)
+  #:use-module (json)
+  #:use-module (srfi srfi-9)
+  #:export (define-json-mapping))
+
+;;; Commentary:
+;;;
+;;; This module provides tools to define mappings from JSON objects to SRFI-9
+;;; records.  This is useful when writing bindings to HTTP APIs.
+;;;
+;;; Code:
+
+(define-syntax-rule (define-json-reader json->record ctor spec ...)
+  "Define JSON->RECORD as a procedure that converts a JSON representation,
+read from a port, string, or hash table, into a record created by CTOR and
+following SPEC, a series of field specifications."
+  (define (json->record input)
+    (let ((table (cond ((port? input)
+                        (json->scm input))
+                       ((string? input)
+                        (json-string->scm input))
+                       ((hash-table? input)
+                        input))))
+      (let-syntax ((extract-field (syntax-rules ()
+                                    ((_ table (field key json->value))
+                                     (json->value (hash-ref table key)))
+                                    ((_ table (field key))
+                                     (hash-ref table key))
+                                    ((_ table (field))
+                                     (hash-ref table
+                                               (symbol->string 'field))))))
+        (ctor (extract-field table spec) ...)))))
+
+(define-syntax-rule (define-json-mapping rtd ctor pred json->record
+                      (field getter spec ...) ...)
+  "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9,
+and define JSON->RECORD as a conversion from JSON to a record of this type."
+  (begin
+    (define-record-type rtd
+      (ctor field ...)
+      pred
+      (field getter) ...)
+
+    (define-json-reader json->record ctor
+      (field spec ...) ...)))
-- 
2.29.2

From f4cbc586fa09f24214261d2ee4e1e6a213a6c2d5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <[email-masked]>
Date: Fri, 28 Dec 2018 15:58:58 +0100
Subject: [PATCH 2/5] =?UTF-8?q?tests:=20'file=3D=3F'=20now=20recurses=20on?=
 =?UTF-8?q?=20directories.?=

* guix/tests.scm (not-dot?): New procedure.
(file=?)[executable?]: New procedure.
In 'regular case, check whether the executable bit is preserved.
Add 'directory case.
---
 guix/tests.scm | 25 +++++++++++++++++++++----
 1 file changed, 21 insertions(+), 4 deletions(-)

diff --git a/guix/tests.scm b/guix/tests.scm
index fc3d521163..d0f9e6d35a 100644
--- a/guix/tests.scm
+++ b/guix/tests.scm
@@ -30,11 +30,13 @@
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages base)
   #:use-module (gnu packages bootstrap)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
   #:use-module (ice-9 binary-ports)
   #:use-module (web uri)
   #:export (open-connection-for-tests
@@ -182,16 +184,31 @@ too expensive to build entirely in the test store."
             (loop (1+ i)))
           bv))))
 
+(define (not-dot? entry)
+  (not (member entry '("." ".."))))
+
 (define (file=? a b)
-  "Return true if files A and B have the same type and same content."
+  "Return true if files A and B have the same type and same content,
+recursively."
+  (define (executable? file)
+    (->bool (logand (stat:mode (lstat file)) #o100)))
+
   (and (eq? (stat:type (lstat a)) (stat:type (lstat b)))
        (case (stat:type (lstat a))
          ((regular)
-          (equal?
-           (call-with-input-file a get-bytevector-all)
-           (call-with-input-file b get-bytevector-all)))
+          (and (eqv? (executable? a) (executable? b))
+               (equal?
+                (call-with-input-file a get-bytevector-all)
+                (call-with-input-file b get-bytevector-all))))
          ((symlink)
           (string=? (readlink a) (readlink b)))
+         ((directory)
+          (let ((lst1 (scandir a not-dot?))
+                (lst2 (scandir b not-dot?)))
+            (and (equal? lst1 lst2)
+                 (every file=?
+                        (map (cut string-append a "/" <>) lst1)
+                        (map (cut string-append b "/" <>) lst2)))))
          (else
           (error "what?" (lstat a))))))
 
-- 
2.29.2

From 3dcd999dbb6860317459a006bc03bbc8d9d1fdc0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <[email-masked]>
Date: Fri, 28 Dec 2018 01:07:58 +0100
Subject: [PATCH 3/5] Add (guix ipfs).

* guix/ipfs.scm, tests/ipfs.scm: New files.
* Makefile.am (MODULES, SCM_TESTS): Add them.
---
 Makefile.am    |   2 +
 guix/ipfs.scm  | 250 +++++++++++++++++++++++++++++++++++++++++++++++++
 tests/ipfs.scm |  55 +++++++++++
 3 files changed, 307 insertions(+)
 create mode 100644 guix/ipfs.scm
 create mode 100644 tests/ipfs.scm

diff --git a/Makefile.am b/Makefile.am
index 81f502d877..ff7deacc44 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -123,6 +123,7 @@ MODULES =					\
   guix/cache.scm				\
   guix/cve.scm					\
   guix/workers.scm				\
+  guix/ipfs.scm					\
   guix/build-system.scm				\
   guix/build-system/android-ndk.scm		\
   guix/build-system/ant.scm			\
@@ -450,6 +451,7 @@ SCM_TESTS =					\
   tests/hackage.scm				\
   tests/import-utils.scm			\
   tests/inferior.scm				\
+  tests/ipfs.scm				\
   tests/lint.scm				\
   tests/modules.scm				\
   tests/monads.scm				\
diff --git a/guix/ipfs.scm b/guix/ipfs.scm
new file mode 100644
index 0000000000..e941feda6f
--- /dev/null
+++ b/guix/ipfs.scm
@@ -0,0 +1,250 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <[email-masked]>
+;;;
+;;; 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 ipfs)
+  #:use-module (guix json)
+  #:use-module (guix base64)
+  #:use-module ((guix build utils) #:select (dump-port))
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
+  #:use-module (web uri)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:export (%ipfs-base-url
+            add-file
+            add-file-tree
+            restore-file-tree
+
+            content?
+            content-name
+            content-hash
+            content-size
+
+            add-empty-directory
+            add-to-directory
+            read-contents
+            publish-name))
+
+;;; Commentary:
+;;;
+;;; This module implements bindings for the HTTP interface of the IPFS
+;;; gateway, documented here: <https://docs.ipfs.io/reference/api/http/>.  It
+;;; allows you to add and retrieve files over IPFS, and a few other things.
+;;;
+;;; Code:
+
+(define %ipfs-base-url
+  ;; URL of the IPFS gateway.
+  (make-parameter "http://localhost:5001"))
+
+(define* (call url decode #:optional (method http-post)
+               #:key body (false-if-404? #t) (headers '()))
+  "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*-values (((response port)
+                 (method url #:streaming? #t
+                         #:body body
+
+                         ;; Always pass "Connection: close".
+                         #:keep-alive? #f
+                         #:headers `((connection close)
+                                     ,@headers))))
+    (cond ((= 200 (response-code response))
+           (if decode
+               (let ((result (decode port)))
+                 (close-port port)
+                 result)
+               port))
+          ((and false-if-404?
+                (= 404 (response-code response)))
+           (close-port port)
+           #f)
+          (else
+           (close-port port)
+           (throw 'ipfs-error url response)))))
+
+;; Result of a file addition.
+(define-json-mapping <content> make-content content?
+  json->content
+  (name   content-name "Name")
+  (hash   content-hash "Hash")
+  (bytes  content-bytes "Bytes")
+  (size   content-size "Size" string->number))
+
+;; Result of a 'patch/add-link' operation.
+(define-json-mapping <directory> make-directory directory?
+  json->directory
+  (hash   directory-hash "Hash")
+  (links  directory-links "Links" json->links))
+
+;; A "link".
+(define-json-mapping <link> make-link link?
+  json->link
+  (name   link-name "Name")
+  (hash   link-hash "Hash")
+  (size   link-size "Size" string->number))
+
+;; A "binding", also known as a "name".
+(define-json-mapping <binding> make-binding binding?
+  json->binding
+  (name   binding-name "Name")
+  (value  binding-value "Value"))
+
+(define (json->links json)
+  (match json
+    (#f    '())
+    (links (map json->link links))))
+
+(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* (add-data data #:key (name "file.txt") recursive?)
+  "Add DATA, a bytevector, to IPFS.  Return a content object representing it."
+  (call (string-append (%ipfs-base-url)
+                       "/api/v0/add?arg=" (uri-encode name)
+                       "&recursive="
+                       (if recursive? "true" "false"))
+        json->content
+        #:headers
+        `((content-type
+           . (multipart/form-data
+              (boundary . ,%multipart-boundary))))
+        #:body
+        (call-with-bytevector-output-port
+         (lambda (port)
+           (bytevector->form-data data port)))))
+
+(define (not-dot? entry)
+  (not (member entry '("." ".."))))
+
+(define (file-tree->sexp file)
+  "Add FILE, recursively, to the IPFS, and return an sexp representing the
+directory's tree structure.
+
+Unlike IPFS's own \"UnixFS\" structure, this format preserves exactly what we
+need: like the nar format, it preserves the executable bit, but does not save
+the mtime or other Unixy attributes irrelevant in the store."
+  ;; The natural approach would be to insert each directory listing as an
+  ;; object of its own in IPFS.  However, this does not buy us much in terms
+  ;; of deduplication, but it does cause a lot of extra round trips when
+  ;; fetching it.  Thus, this sexp is \"flat\" in that only the leaves are
+  ;; inserted into the IPFS.
+  (let ((st (lstat file)))
+    (match (stat:type st)
+      ('directory
+       (let* ((parent  file)
+              (entries (map (lambda (file)
+                              `(entry ,file
+                                      ,(file-tree->sexp
+                                        (string-append parent "/" file))))
+                            (scandir file not-dot?)))
+              (size    (fold (lambda (entry total)
+                               (match entry
+                                 (('entry name (kind value size))
+                                  (+ total size))))
+                             0
+                             entries)))
+         `(directory ,entries ,size)))
+      ('symlink
+       `(symlink ,(readlink file) 0))
+      ('regular
+       (let ((size (stat:size st)))
+         (if (zero? (logand (stat:mode st) #o100))
+             `(file ,(content-name (add-file file)) ,size)
+             `(executable ,(content-name (add-file file)) ,size)))))))
+
+(define (add-file-tree file)
+  "Add FILE to the IPFS, recursively, using our own canonical directory
+format.  Return the resulting content object."
+  (add-data (string->utf8 (object->string
+                           `(file-tree (version 0)
+                                       ,(file-tree->sexp file))))))
+
+(define (restore-file-tree object file)
+  "Restore to FILE the tree pointed to by OBJECT."
+  (let restore ((tree (match (read (read-contents object))
+                        (('file-tree ('version 0) tree)
+                         tree)))
+                (file file))
+    (match tree
+      (('file object size)
+       (call-with-output-file file
+         (lambda (output)
+           (dump-port (read-contents object) output))))
+      (('executable object size)
+       (call-with-output-file file
+         (lambda (output)
+           (dump-port (read-contents object) output)))
+       (chmod file #o555))
+      (('symlink target size)
+       (symlink target file))
+      (('directory (('entry names entries) ...) size)
+       (mkdir file)
+       (for-each restore entries
+                 (map (cut string-append file "/" <>) names))))))
+
+(define* (add-file file #:key (name (basename file)))
+  "Add FILE under NAME to the IPFS and return a content object for it."
+  (add-data (match (call-with-input-file file get-bytevector-all)
+              ((? eof-object?) #vu8())
+              (bv bv))
+            #:name name))
+
+(define* (add-empty-directory #:key (name "directory"))
+  "Return a content object for an empty directory."
+  (add-data #vu8() #:recursive? #t #:name name))
+
+(define* (add-to-directory directory file name)
+  "Add FILE to DIRECTORY under NAME, and return the resulting directory.
+DIRECTORY and FILE must be hashes identifying objects in the IPFS store."
+  (call (string-append (%ipfs-base-url)
+                       "/api/v0/object/patch/add-link?arg="
+                       (uri-encode directory)
+                       "&arg=" (uri-encode name) "&arg=" (uri-encode file)
+                       "&create=true")
+        json->directory))
+
+(define* (read-contents object #:key offset length)
+  "Return an input port to read the content of OBJECT from."
+  (call (string-append (%ipfs-base-url)
+                       "/api/v0/cat?arg=" object)
+        #f))
+
+(define* (publish-name object)
+  "Publish OBJECT under the current peer ID."
+  (call (string-append (%ipfs-base-url)
+                       "/api/v0/name/publish?arg=" object)
+        json->binding))
diff --git a/tests/ipfs.scm b/tests/ipfs.scm
new file mode 100644
index 0000000000..3b662b22bd
--- /dev/null
+++ b/tests/ipfs.scm
@@ -0,0 +1,55 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <[email-masked]>
+;;;
+;;; 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 (test-ipfs)
+  #:use-module (guix ipfs)
+  #:use-module ((guix utils) #:select (call-with-temporary-directory))
+  #:use-module (guix tests)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-64))
+
+;; Test the (guix ipfs) module.
+
+(define (ipfs-gateway-running?)
+  "Return true if the IPFS gateway is running at %IPFS-BASE-URL."
+  (let* ((uri    (string->uri (%ipfs-base-url)))
+         (socket (socket AF_INET SOCK_STREAM 0)))
+    (define connected?
+      (catch 'system-error
+        (lambda ()
+          (format (current-error-port)
+                  "probing IPFS gateway at localhost:~a...~%"
+                  (uri-port uri))
+          (connect socket AF_INET INADDR_LOOPBACK (uri-port uri))
+          #t)
+        (const #f)))
+
+    (close-port socket)
+    connected?))
+
+(unless (ipfs-gateway-running?)
+  (test-skip 1))
+
+(test-assert "add-file-tree + restore-file-tree"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (let* ((source  (dirname (search-path %load-path "guix/base32.scm")))
+            (target  (string-append directory "/r"))
+            (content (pk 'content (add-file-tree source))))
+       (restore-file-tree (content-name content) target)
+       (file=? source target)))))
-- 
2.29.2

From 21cf092c67e10e60682f3c14d6b438ce7d905eef Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <[email-masked]>
Date: Fri, 28 Dec 2018 18:27:59 +0100
Subject: [PATCH 4/5] publish: Add IPFS support.

* guix/scripts/publish.scm (show-help, %options): Add '--ipfs'.
(narinfo-string): Add IPFS parameter and honor it.
(render-narinfo/cached): Add #:ipfs? and honor it.
(bake-narinfo+nar, make-request-handler, run-publish-server): Likewise.
(guix-publish): Honor '--ipfs' and parameterize %IPFS-BASE-URL.
---
 doc/guix.texi            | 34 +++++++++++++++++++
 guix/scripts/publish.scm | 73 +++++++++++++++++++++++++++-------------
 2 files changed, 83 insertions(+), 24 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 1f33fd3b76..e52083fc5d 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -12267,6 +12267,16 @@ http://example.org/file/hello-2.10.tar.gz/sha256/0ssi1@dots{}ndq1i
 Obviously, these URLs only work for files that are in the store; in
 other cases, they return 404 (``Not Found'').
 
+@cindex peer-to-peer, substitute distribution
+@cindex distributed storage, of substitutes
+@cindex IPFS, for substitutes
+
+It is also possible to publish substitutes over @uref{https://ipfs.io, IFPS},
+a distributed, peer-to-peer storage mechanism.  To enable it, pass the
+@option{--ipfs} option alongside @option{--cache}, and make sure you're
+running @command{ipfs daemon}.  Capable clients will then be able to choose
+whether to fetch substitutes over HTTP or over IPFS.
+
 @cindex build logs, publication
 Build logs are available from @code{/log} URLs like:
 
@@ -12363,6 +12373,30 @@ thread per CPU core is created, but this can be customized.  See
 When @option{--ttl} is used, cached entries are automatically deleted
 when they have expired.
 
+@item --ifps[=@var{gateway}]
+When used in conjunction with @option{--cache}, instruct @command{guix
+publish} to publish substitutes over the @uref{https://ipfs.io, IPFS
+distributed data store} in addition to HTTP.
+
+@quotation Note
+As of version @value{VERSION}, IPFS support is experimental.  You're welcome
+to share your experience with the developers by emailing
+@email{guix-devel@@gnu.org}!
+@end quotation
+
+The IPFS HTTP interface must be reachable at @var{gateway}, by default
+@code{localhost:5001}.  To get it up and running, it is usually enough to
+install IPFS and start the IPFS daemon:
+
+@example
+$ guix package -i go-ipfs
+$ ipfs init
+$ ipfs daemon
+@end example
+
+For more information on how to get started with IPFS, please refer to the
+@uref{https://docs.ipfs.io/introduction/usage/, IPFS documentation}.
+
 @item --workers=@var{N}
 When @option{--cache} is used, request the allocation of @var{N} worker
 threads to ``bake'' archives.
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index c31cef3181..998dfa560d 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -64,8 +64,8 @@
   #:use-module ((guix build utils)
                 #:select (dump-port mkdir-p find-files))
   #:use-module ((guix build syscalls) #:select (set-thread-name))
+  #:use-module ((guix ipfs) #:prefix ipfs:)
   #:export (%default-gzip-compression
-
             %public-key
             %private-key
             signed-string
@@ -94,6 +94,8 @@ Publish ~a over HTTP.\n") %store-directory)
   (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_ "
@@ -210,6 +212,10 @@ usage."
                 (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)
@@ -308,14 +314,16 @@ with COMPRESSION, starting at NAR-PATH."
 
 (define* (narinfo-string store store-path key
                          #:key (compressions (list %no-compression))
-                         (nar-path "nar") (file-sizes '()))
+                         (nar-path "nar") (file-sizes '()) ipfs)
   "Generate a narinfo key/value string for STORE-PATH; an exception is raised
 if STORE-PATH is invalid.  Produce a URL that corresponds to COMPRESSION.  The
 narinfo is signed with KEY.  NAR-PATH specifies the prefix for nar URLs.
 
 Optionally, FILE-SIZES is a list of compression/integer pairs, where the
 integer is size in bytes of the compressed NAR; it informs the client of how
-much needs to be downloaded."
+much needs to be downloaded.
+
+When IPFS is true, it is the IPFS object identifier for STORE-PATH."
   (let* ((path-info  (query-path-info store store-path))
          (compressions (actual-compressions store-path compressions))
          (hash       (bytevector->nix-base32-string
@@ -363,7 +371,12 @@ References: ~a~%"
                                  (apply throw args))))))
          (signature  (base64-encode-string
                       (canonical-sexp->string (signed-string info)))))
-    (format #f "~aSignature: 1;~a;~a~%" info (gethostname) signature)))
+    (format #f "~aSignature: 1;~a;~a~%~a" info (gethostname) signature
+
+            ;; Append IPFS info below the signed part.
+            (if ipfs
+                (string-append "IPFS: " ipfs "\n")
+                ""))))
 
 (define* (not-found request
                     #:key (phrase "Resource not found")
@@ -510,10 +523,12 @@ interpreted as the basename of a store item."
 (define* (render-narinfo/cached store request hash
                                 #:key ttl (compressions (list %no-compression))
                                 (nar-path "nar")
-                                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."
+requested using POOL.
+
+When IPFS? is true, additionally publish binaries over IPFS."
   (define (delete-entry narinfo)
     ;; Delete NARINFO and the corresponding nar from CACHE.
     (let* ((nar     (string-append (string-drop-right narinfo
@@ -556,7 +571,8 @@ requested using POOL."
                  (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
@@ -617,7 +633,7 @@ requested using POOL."
 
 (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))
@@ -644,7 +660,11 @@ requested using POOL."
                                           (%private-key)
                                           #:nar-path nar-path
                                           #:compressions compressions
-                                          #:file-sizes sizes)
+                                          #:file-sizes sizes
+                                          #:ipfs
+                                          (and ipfs?
+                                               (ipfs:content-name
+                                                (ipfs:add-file-tree item))))
                           port)))
 
              ;; Make the cached narinfo world-readable, contrary to what
@@ -996,7 +1016,8 @@ methods, return the applicable compression."
                                cache pool
                                narinfo-ttl
                                (nar-path "nar")
-                               (compressions (list %no-compression)))
+                               (compressions (list %no-compression))
+                               ipfs?)
   (define compression-type?
     string->compression-type)
 
@@ -1027,7 +1048,9 @@ methods, return the applicable compression."
                                       #:pool pool
                                       #:ttl narinfo-ttl
                                       #:nar-path nar-path
-                                      #:compressions compressions)
+                                      #:compressions compressions
+                                      #:compressions compressions
+                                      #:ipfs? ipfs?)
                (render-narinfo store request hash
                                #:ttl narinfo-ttl
                                #:nar-path nar-path
@@ -1089,7 +1112,7 @@ methods, return the applicable compression."
                              advertise? port
                              (compressions (list %no-compression))
                              (nar-path "nar") narinfo-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
@@ -1098,13 +1121,13 @@ methods, return the applicable compression."
       (avahi-publish-service-thread name
                                     #:type publish-service-type
                                     #:port port)))
-
   (run-server (make-request-handler store
                                     #:cache cache
                                     #:pool pool
                                     #:nar-path nar-path
                                     #:narinfo-ttl narinfo-ttl
-                                    #:compressions compressions)
+                                    #:compressions compressions
+                                    #:ipfs? ipfs?)
               concurrent-http-server
               `(#:socket ,socket)))
 
@@ -1166,6 +1189,7 @@ methods, return the applicable compression."
            (repl-port (assoc-ref opts 'repl))
            (cache     (assoc-ref opts 'cache))
            (workers   (assoc-ref opts 'workers))
+           (ipfs      (assoc-ref opts 'ipfs))
 
            ;; 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.
@@ -1204,16 +1228,17 @@ consider using the '--user' option!~%")))
         (set-thread-name "guix publish")
 
         (with-store store
-          (run-publish-server socket store
-                              #:advertise? advertise?
-                              #:port port
-                              #:cache cache
-                              #:pool (and cache (make-pool workers
-                                                           #:thread-name
-                                                           "publish worker"))
-                              #:nar-path nar-path
-                              #:compressions compressions
-                              #:narinfo-ttl ttl))))))
+          (parameterize ((ipfs:%ipfs-base-url ipfs))
+            (run-publish-server socket store
+                                #:advertise? advertise?
+                                #:port port
+                                #:cache cache
+                                #:pool (and cache (make-pool workers
+                                                             #:thread-name
+                                                             "publish worker"))
+                                #:nar-path nar-path
+                                #:compressions compressions
+                                #:narinfo-ttl ttl)))))))
 
 ;;; Local Variables:
 ;;; eval: (put 'single-baker 'scheme-indent-function 1)
-- 
2.29.2

From d300bd6b37680f26fbc9b339264476fcc35e1787 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <[email-masked]>
Date: Fri, 28 Dec 2018 18:40:06 +0100
Subject: [PATCH 5/5] DRAFT substitute: Add IPFS support.

Missing:

  - documentation
  - command-line options
  - progress report when downloading over IPFS
  - fallback when we fail to fetch from IPFS

* guix/scripts/substitute.scm (<narinfo>)[ipfs]: New field.
(read-narinfo): Read "IPFS".
(process-substitution/http): New procedure, with code formerly in
'process-substitution'.
(process-substitution): Check for IPFS and call 'ipfs:restore-file-tree'
when IPFS is true.
---
 guix/scripts/substitute.scm | 112 ++++++++++++++++++++----------------
 1 file changed, 63 insertions(+), 49 deletions(-)

diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index feae2df9cb..8a888c5e01 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -43,6 +43,7 @@
   #:use-module (guix progress)
   #:use-module ((guix build syscalls)
                 #:select (set-thread-name))
+  #:use-module ((guix ipfs) #:prefix ipfs:)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
@@ -233,7 +234,7 @@ provide."
 (define-record-type <narinfo>
   (%make-narinfo path uri-base uris compressions file-sizes file-hashes
                  nar-hash nar-size references deriver system
-                 signature contents)
+                 ipfs signature contents)
   narinfo?
   (path         narinfo-path)
   (uri-base     narinfo-uri-base)        ;URI of the cache it originates from
@@ -246,6 +247,7 @@ provide."
   (references   narinfo-references)
   (deriver      narinfo-deriver)
   (system       narinfo-system)
+  (ipfs         narinfo-ipfs)
   (signature    narinfo-signature)      ; canonical sexp
   ;; The original contents of a narinfo file.  This field is needed because we
   ;; want to preserve the exact textual representation for verification purposes.
@@ -288,7 +290,7 @@ s-expression: ~s~%")
 must contain the original contents of a narinfo file."
   (lambda (path urls compressions file-hashes file-sizes
                 nar-hash nar-size references deriver system
-                signature)
+                ipfs signature)
     "Return a new <narinfo> object."
     (define len (length urls))
     (%make-narinfo path cache-url
@@ -312,6 +314,7 @@ must contain the original contents of a narinfo file."
                      ((or #f "") #f)
                      (_ deriver))
                    system
+                   ipfs
                    (false-if-exception
                     (and=> signature narinfo-signature->canonical-sexp))
                    str)))
@@ -330,7 +333,7 @@ No authentication and authorization checks are performed here!"
                    (narinfo-maker str url)
                    '("StorePath" "URL" "Compression"
                      "FileHash" "FileSize" "NarHash" "NarSize"
-                     "References" "Deriver" "System"
+                     "References" "Deriver" "System" "IPFS"
                      "Signature")
                    '("URL" "Compression" "FileSize" "FileHash"))))
 
@@ -962,6 +965,48 @@ the URI, its compression method (a string), and the compressed file size."
     (((uri compression file-size) _ ...)
      (values uri compression file-size))))
 
+(define* (process-substitution/http narinfo destination uri
+                                    compression
+                                    #:key print-build-trace?)
+  (unless print-build-trace?
+    (format (current-error-port)
+            (G_ "Downloading ~a...~%") (uri->string uri)))
+  (let*-values (((raw download-size)
+                 ;; Note that Hydra currently generates Nars on the fly
+                 ;; and doesn't specify a Content-Length, so
+                 ;; DOWNLOAD-SIZE is #f in practice.
+                 (fetch uri #:buffered? #f #:timeout? #f))
+                ((progress)
+                 (let* ((dl-size  (or download-size
+                                      (and (equal? compression "none")
+                                           (narinfo-size narinfo))))
+                        (reporter (if print-build-trace?
+                                      (progress-reporter/trace
+                                       destination
+                                       (uri->string uri) dl-size
+                                       (current-error-port))
+                                      (progress-reporter/file
+                                       (uri->string uri) dl-size
+                                       (current-error-port)
+                                       #:abbreviation nar-uri-abbreviation))))
+                   (progress-report-port reporter raw)))
+                ((input pids)
+                 ;; NOTE: This 'progress' port of current process will be
+                 ;; closed here, while the child process doing the
+                 ;; reporting will close it upon exit.
+                 (decompressed-port (string->symbol compression)
+                                    progress)))
+    ;; Unpack the Nar at INPUT into DESTINATION.
+    (restore-file input destination)
+    (close-port input)
+
+    ;; Wait for the reporter to finish.
+    (every (compose zero? cdr waitpid) pids)
+
+    ;; Skip a line after what 'progress-reporter/file' printed, and another
+    ;; one to visually separate substitutions.
+    (display "\n\n" (current-error-port))))
+
 (define* (process-substitution store-item destination
                                #:key cache-urls acl print-build-trace?)
   "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
@@ -969,55 +1014,24 @@ DESTINATION as a nar file.  Verify the substitute against ACL."
   (define narinfo
     (lookup-narinfo cache-urls store-item
                     (cut valid-narinfo? <> acl)))
-
+  (define ipfs (and=> narinfo narinfo-ipfs))
   (unless narinfo
     (leave (G_ "no valid substitute for '~a'~%")
            store-item))
-
-  (let-values (((uri compression file-size)
-                (narinfo-best-uri narinfo)))
-    ;; Tell the daemon what the expected hash of the Nar itself is.
-    (format #t "~a~%" (narinfo-hash narinfo))
-
-    (unless print-build-trace?
-      (format (current-error-port)
-              (G_ "Downloading ~a...~%") (uri->string uri)))
-
-    (let*-values (((raw download-size)
-                   ;; Note that Hydra currently generates Nars on the fly
-                   ;; and doesn't specify a Content-Length, so
-                   ;; DOWNLOAD-SIZE is #f in practice.
-                   (fetch uri #:buffered? #f #:timeout? #f))
-                  ((progress)
-                   (let* ((dl-size  (or download-size
-                                        (and (equal? compression "none")
-                                             (narinfo-size narinfo))))
-                          (reporter (if print-build-trace?
-                                        (progress-reporter/trace
-                                         destination
-                                         (uri->string uri) dl-size
-                                         (current-error-port))
-                                        (progress-reporter/file
-                                         (uri->string uri) dl-size
-                                         (current-error-port)
-                                         #:abbreviation nar-uri-abbreviation))))
-                     (progress-report-port reporter raw)))
-                  ((input pids)
-                   ;; NOTE: This 'progress' port of current process will be
-                   ;; closed here, while the child process doing the
-                   ;; reporting will close it upon exit.
-                   (decompressed-port (string->symbol compression)
-                                      progress)))
-      ;; Unpack the Nar at INPUT into DESTINATION.
-      (restore-file input destination)
-      (close-port input)
-
-      ;; Wait for the reporter to finish.
-      (every (compose zero? cdr waitpid) pids)
-
-      ;; Skip a line after what 'progress-reporter/file' printed, and another
-      ;; one to visually separate substitutions.
-      (display "\n\n" (current-error-port)))))
+  ;; Tell the daemon what the expected hash of the Nar itself is.
+  (format #t "~a~%" (narinfo-hash narinfo))
+  (if ipfs
+      (begin
+        (unless print-build-trace?
+          (format (current-error-port)
+                  (G_ "Downloading from IPFS ~s...~%") ipfs))
+        (ipfs:restore-file-tree ipfs destination))
+      (let-values (((uri compression file-size)
+                    (narinfo-best-uri narinfo)))
+        (process-substitution/http narinfo destination uri
+                                   compression
+                                   #:print-build-trace?
+                                   print-build-trace?))))
 
 
 ;;;
-- 
2.29.2