;;; 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))