Commit | Line | Data |
---|---|---|
b18f45c2 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix ipfs) | |
20 | #:use-module (json) | |
21 | #:use-module (guix base64) | |
22 | #:use-module ((guix build utils) #:select (dump-port)) | |
23 | #:use-module (srfi srfi-1) | |
24 | #:use-module (srfi srfi-11) | |
25 | #:use-module (srfi srfi-26) | |
26 | #:use-module (rnrs io ports) | |
27 | #:use-module (rnrs bytevectors) | |
28 | #:use-module (ice-9 match) | |
29 | #:use-module (ice-9 ftw) | |
30 | #:use-module (web uri) | |
31 | #:use-module (web client) | |
32 | #:use-module (web response) | |
33 | #:export (%ipfs-base-url | |
34 | add-data | |
35 | add-file | |
36 | ||
37 | content? | |
38 | content-name | |
39 | content-hash | |
40 | content-size | |
41 | ||
42 | add-empty-directory | |
43 | add-to-directory | |
44 | read-contents | |
45 | publish-name)) | |
46 | ||
47 | ;;; Commentary: | |
48 | ;;; | |
49 | ;;; This module implements bindings for the HTTP interface of the IPFS | |
50 | ;;; gateway, documented here: <https://docs.ipfs.io/reference/api/http/>. It | |
51 | ;;; allows you to add and retrieve files over IPFS, and a few other things. | |
52 | ;;; | |
53 | ;;; Code: | |
54 | ||
55 | (define %ipfs-base-url | |
56 | ;; URL of the IPFS gateway. | |
57 | (make-parameter "http://localhost:5001")) | |
58 | ||
59 | (define* (call url decode #:optional (method http-post) | |
60 | #:key body (false-if-404? #t) (headers '())) | |
61 | "Invoke the endpoint at URL using METHOD. Decode the resulting JSON body | |
62 | using DECODE, a one-argument procedure that takes an input port; when DECODE | |
63 | is false, return the input port. When FALSE-IF-404? is true, return #f upon | |
64 | 404 responses." | |
65 | (let*-values (((response port) | |
66 | (method url #:streaming? #t | |
67 | #:body body | |
68 | ||
69 | ;; Always pass "Connection: close". | |
70 | #:keep-alive? #f | |
71 | #:headers `((connection close) | |
72 | ,@headers)))) | |
73 | (cond ((= 200 (response-code response)) | |
74 | (if decode | |
75 | (let ((result (decode port))) | |
76 | (close-port port) | |
77 | result) | |
78 | port)) | |
79 | ((and false-if-404? | |
80 | (= 404 (response-code response))) | |
81 | (close-port port) | |
82 | #f) | |
83 | (else | |
84 | (close-port port) | |
85 | (throw 'ipfs-error url response))))) | |
86 | ||
87 | ;; Result of a file addition. | |
88 | (define-json-mapping <content> make-content content? | |
89 | json->content | |
90 | (name content-name "Name") | |
91 | (hash content-hash "Hash") | |
92 | (bytes content-bytes "Bytes") | |
93 | (size content-size "Size" string->number)) | |
94 | ||
95 | ;; Result of a 'patch/add-link' operation. | |
96 | (define-json-mapping <directory> make-directory directory? | |
97 | json->directory | |
98 | (hash directory-hash "Hash") | |
99 | (links directory-links "Links" json->links)) | |
100 | ||
101 | ;; A "link". | |
102 | (define-json-mapping <link> make-link link? | |
103 | json->link | |
104 | (name link-name "Name") | |
105 | (hash link-hash "Hash") | |
106 | (size link-size "Size" string->number)) | |
107 | ||
108 | ;; A "binding", also known as a "name". | |
109 | (define-json-mapping <binding> make-binding binding? | |
110 | json->binding | |
111 | (name binding-name "Name") | |
112 | (value binding-value "Value")) | |
113 | ||
114 | (define (json->links json) | |
115 | (match json | |
116 | (#f '()) | |
117 | (links (map json->link links)))) | |
118 | ||
119 | (define %multipart-boundary | |
120 | ;; XXX: We might want to find a more reliable boundary. | |
121 | (string-append (make-string 24 #\-) "2698127afd7425a6")) | |
122 | ||
123 | (define (bytevector->form-data bv port) | |
124 | "Write to PORT a 'multipart/form-data' representation of BV." | |
125 | (display (string-append "--" %multipart-boundary "\r\n" | |
126 | "Content-Disposition: form-data\r\n" | |
127 | "Content-Type: application/octet-stream\r\n\r\n") | |
128 | port) | |
129 | (put-bytevector port bv) | |
130 | (display (string-append "\r\n--" %multipart-boundary "--\r\n") | |
131 | port)) | |
132 | ||
133 | (define* (add-data data #:key (name "file.txt") recursive?) | |
134 | "Add DATA, a bytevector, to IPFS. Return a content object representing it." | |
135 | (call (string-append (%ipfs-base-url) | |
136 | "/api/v0/add?arg=" (uri-encode name) | |
137 | "&recursive=" | |
138 | (if recursive? "true" "false")) | |
139 | json->content | |
140 | #:headers | |
141 | `((content-type | |
142 | . (multipart/form-data | |
143 | (boundary . ,%multipart-boundary)))) | |
144 | #:body | |
145 | (call-with-bytevector-output-port | |
146 | (lambda (port) | |
147 | (bytevector->form-data data port))))) | |
148 | ||
149 | (define (not-dot? entry) | |
150 | (not (member entry '("." "..")))) | |
151 | ||
152 | (define* (add-file file #:key (name (basename file))) | |
153 | "Add FILE under NAME to the IPFS and return a content object for it." | |
154 | (add-data (match (call-with-input-file file get-bytevector-all) | |
155 | ((? eof-object?) #vu8()) | |
156 | (bv bv)) | |
157 | #:name name)) | |
158 | ||
159 | (define* (add-empty-directory #:key (name "directory")) | |
160 | "Return a content object for an empty directory." | |
161 | (add-data #vu8() #:recursive? #t #:name name)) | |
162 | ||
163 | (define* (add-to-directory directory file name) | |
164 | "Add FILE to DIRECTORY under NAME, and return the resulting directory. | |
165 | DIRECTORY and FILE must be hashes identifying objects in the IPFS store." | |
166 | (call (string-append (%ipfs-base-url) | |
167 | "/api/v0/object/patch/add-link?arg=" | |
168 | (uri-encode directory) | |
169 | "&arg=" (uri-encode name) "&arg=" (uri-encode file) | |
170 | "&create=true") | |
171 | json->directory)) | |
172 | ||
173 | (define* (read-contents object #:key offset length) | |
174 | "Return an input port to read the content of OBJECT from." | |
175 | (call (string-append (%ipfs-base-url) | |
176 | "/api/v0/cat?arg=" object) | |
177 | #f)) | |
178 | ||
179 | (define* (publish-name object) | |
180 | "Publish OBJECT under the current peer ID." | |
181 | (call (string-append (%ipfs-base-url) | |
182 | "/api/v0/name/publish?arg=" object) | |
183 | json->binding)) |