From b9005200195f21ee6b43c9376a3c4a77b6781e50 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 28 Dec 2018 01:07:58 +0100 Subject: 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 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 +;;; +;;; 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 . + +(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: . 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 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 make-directory directory? + json->directory + (hash directory-hash "Hash") + (links directory-links "Links" json->links)) + +;; A "link". +(define-json-mapping 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 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 +;;; +;;; 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 . + +(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))))) -- cgit 1.4.1