Toggle diff (339 lines)
diff --git a/Makefile.am b/Makefile.am
index da3720e3a6..975d83db6c 100644
@@ -101,6 +101,7 @@ MODULES = \
guix/build-system/android-ndk.scm \
guix/build-system/ant.scm \
@@ -384,6 +385,7 @@ SCM_TESTS = \
diff --git a/guix/ipfs.scm b/guix/ipfs.scm
index 0000000000..e941feda6f
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; 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 client)
+ #:use-module (web response)
+ #:export (%ipfs-base-url
+;;; 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.
+ ;; 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
+ (let*-values (((response port)
+ (method url #:streaming? #t
+ ;; Always pass "Connection: close".
+ #:headers `((connection close)
+ (cond ((= 200 (response-code response))
+ (let ((result (decode port)))
+ (= 404 (response-code response)))
+ (throw 'ipfs-error url response)))))
+;; Result of a file addition.
+(define-json-mapping <content> make-content 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?
+ (hash directory-hash "Hash")
+ (links directory-links "Links" json->links))
+(define-json-mapping <link> make-link 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?
+ (name binding-name "Name")
+ (value binding-value "Value"))
+(define (json->links json)
+ (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")
+ (put-bytevector port bv)
+ (display (string-append "\r\n--" %multipart-boundary "--\r\n")
+(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)
+ (if recursive? "true" "false"))
+ (boundary . ,%multipart-boundary))))
+ (call-with-bytevector-output-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)))
+ (entries (map (lambda (file)
+ (string-append parent "/" file))))
+ (scandir file not-dot?)))
+ (size (fold (lambda (entry total)
+ (('entry name (kind value size))
+ `(directory ,entries ,size)))
+ `(symlink ,(readlink file) 0))
+ (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)
+ (call-with-output-file file
+ (dump-port (read-contents object) output))))
+ (('executable object size)
+ (call-with-output-file file
+ (dump-port (read-contents object) output)))
+ (('symlink target size)
+ (('directory (('entry names entries) ...) size)
+ (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())
+(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="
+ "&arg=" (uri-encode name) "&arg=" (uri-encode file)
+(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)
+(define* (publish-name object)
+ "Publish OBJECT under the current peer ID."
+ (call (string-append (%ipfs-base-url)
+ "/api/v0/name/publish?arg=" object)
diff --git a/tests/ipfs.scm b/tests/ipfs.scm
index 0000000000..3b662b22bd
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
+;;; 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 (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)))
+ (format (current-error-port)
+ "probing IPFS gateway at localhost:~a...~%"
+ (connect socket AF_INET INADDR_LOOPBACK (uri-port uri))
+(unless (ipfs-gateway-running?)
+(test-assert "add-file-tree + restore-file-tree"
+ (call-with-temporary-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)))))