[bug#33899] [PATCH 3/5] Add (guix ipfs).

[Ludovic Courtès]

* 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 da3720e3a6..975d83db6c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -101,6 +101,7 @@ MODULES =                                   \
   guix/cve.scm                                 \
   guix/workers.scm                             \
   guix/zlib.scm                                        \
+  guix/ipfs.scm                                        \
   guix/build-system.scm                                \
   guix/build-system/android-ndk.scm            \
   guix/build-system/ant.scm                    \
@@ -384,6 +385,7 @@ SCM_TESTS =                                 \
   tests/cve.scm                                        \
   tests/workers.scm                            \
   tests/zlib.scm                               \
+  tests/ipfs.scm                               \
   tests/file-systems.scm                       \
   tests/uuid.scm                               \
   tests/system.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 <address@hidden>
+;;;
+;;; 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 <address@hidden>
+;;;
+;;; 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.20.1