1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
|
;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;; Copyright (C) 2003, 2004, 2006, 2009, 2020 GNUnet e.V.
;;
;; GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; GNUnet 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
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL-3.0-or-later
;;
;; As a special exception to the GNU Affero General Public License,
;; the file may be relicensed under any license used for
;; most source code of GNUnet 0.13.1, or later versions, as published by
;; GNUnet e.V.
;; This Scheme module allows for the construction of GNUnet directories.
;; Note that this isn't a binding to libgnunet_fs, but rather a Scheme
;; port of relevant bits. This is done this way because this module is
;; intended for use by Guix (for substitutes and/or distributing sources
;; over GNUnet), where directories may be formed independently by separate
;; systems, but should ideally only have a single representation in
;; the GNUnet FS.
;; Q: why not simply push tarballs/narballs into GNUnet FS?
;; A: deduplication
;; Limitations:
;; * Only CHK URI's are supported. This doesn't seem a likely issue,
;; as LOC URI's aren't generated by default (I think) and aren't
;; reproducible anyway.
;; Changes from upstream GNUnet:
;; * Pure API
;; * Linked lists are replaced with vectors
;; * BuilderEntry doesn't contain serialised meta-data,
;; instead it contains the non-serialised meta-data.
;; * URI's are represented by strings (note: GNUnet FS URI's are
;; always ASCII).
(library (gnu gnunet directory)
(export meta-data-mark-directory
make-directory-entry directory-entry?
directory-entry-uri directory-entry-meta
build-directory)
(import (rnrs base)
(rnrs control)
(rnrs records syntactic)
(rnrs bytevectors)
(only (guile) floor/ 1+)
(ice-9 receive)
(only (gnu gnunet fs-uri) chk-uri-file-length chk-uri-parse)
(only (srfi srfi-43) vector-unfold)
(only (gnu gnunet metadata) meta-data-extend)
(prefix (only (gnu extractor metatypes)
MIMETYPE GNUNET_FULL_DATA)
EXTRACTOR_METATYPE_)
(prefix (only (gnu extractor metaformats)
METAFORMAT_UTF8
METAFORMAT_BINARY)
EXTRACTOR_))
;; constant from gnunet-0.13.1/src/fs/fs.h
(define DBLOCK_SIZE (* 32 1024))
;; constant from gnunet-0.13.1/src/fs/fs_api.h
(define MAX_INLINE_SIZE 65536)
;; String that is used to indicate that a file
;; is a GNUnet directory.
(define directory-magic #u8(#x89 #x47 #x4e #x44 #x0d #x0a #x1a #x0a))
;; mime type for gnunet directories
(define directory-mime "application/gnunet-directory")
;; Corresponds to BuilderEntry, without the linked list
(define-record-type (<directory-entry> %make-directory-entry
directory-entry?)
(fields (immutable uri directory-entry-uri)
;; possibly contains inlined data
(immutable meta directory-entry-meta)))
;; DirectoryBuilder corresponds to a vector of <directory-entry>
(define (meta-data-mark-directory md)
"Set the MIMETYPE information for the given
metadata to \"application/gnunet-directory\"
The MIMETYPE may not be already set.
@param md metadata to add mimetype to"
;; TODO: check for pre-existing mime-types
(meta-data-extend md
"<gnunet>"
EXTRACTOR_METATYPE_MIMETYPE
EXTRACTOR_METAFORMAT_UTF8
"text/plain"
(string->utf8 directory-mime)))
(define (make-directory-entry uri meta-old data)
"Create a directory entry, possibly inlined.
@param uri uri of the entry (a string, must not be a KSK)
@param meta-old metadata of the entry, before inlining
@param data raw data of the entry, can be #f, otherwise
data must point to exactly the number of bytes specified
by the uri which must be of type CHK
For reproducibility, it is important to be consistent in the
use or inuse of data."
(let ((fsize (chk-uri-file-length (chk-uri-parse uri)))
(meta-old-size (meta-serialized-size meta-old)))
(receive (meta-to-use meta-size)
;; Try inlining data, except if it's too large.
(if (and data
(< fsize MAX-INLINE-SIZE)
(< 0 fsize)) ; data not too large?
(let* ((meta
(meta-data-extend meta-old
"<gnunet>"
EXTRACTOR_METATYPE_GNUNET_FULL_DATA
EXTRACTOR_METAFORMAT_BINARY
#f
data))
(slen (+ (string-length uri) 1))
(mdxs (meta-serialized-size meta)))
(if (= (floor/ (+ slen 4 mdxs -1) DBLOCK_SIZE)
(floor/ (+ slen 4 meta-old-size -1) DBLOCK_SIZE))
;; adding full data would not cause us to cross
;; additional blocks, so add it!
(values meta mdxs)
;; too large
(values meta-old meta-old-size)))
(values meta-old meta-old-size))
;; compute entry
(%make-directory-entry uri meta-to-use))))
(define (block-align! start count sizes perm)
"Compute a permuation of the blocks to
minimize the cost of alignment. Greedy packer.
@param start starting position for the first block
@param count size of the two arrays
@param sizes the sizes of the individual blocks
@param perm the permutation of the blocks (updated)"
(do ((i 0 (1+ i))
(cpos start (do-align start (+ (vector-ref sizes i) cpos))))
((>= i count))
(let loop ((j 1) (best #f) (badness #x7FFFFFFF))
(if (< j count)
(let* ((cval (vector-ref perm j))
(cend (+ cpos (vector-ref sizes cval)))
(cbad (cond ((= (mod cpos DBLOCK_SIZE) 0)
(- (mod cend DBLOCK_SIZE)))
((= (floor/ cpos DBLOCK_SIZE)
(floor/ cend DBLOCK_SIZE))
;; Data fits into the same block!
;; Prefer small left-overs!
(- DBLOCK_SIZE (mod cend DBLOCK_SIZE)))
(else
;; Would have to waste space to re-align,
;; add big factor, this case is a real loss
;; (proportional to space wasted)!
(* DBLOCK_SIZE (- DBLOCK_SIZE
(mod cpos DBLOCK_SIZE)))))))
(if (< cbad badness)
(loop (1+ j) j cbad)
(loop (1+ j) best badness))))
(let ((old-perm (vector-ref perm i)))
(vector-set! perm i (vector-ref perm best))
(vector-set! perm best old-perm)))))
(define (do-align start end)
"Given the start and end position of a block of
data, return the end position of that data
after alignment to the DBLOCK_SIZE."
(let ((align (- end (mod end DBLOCK_SIZE))))
(if (and (< start align) (> end align))
(+ align end (- start))
end)))
(define (directory-size-etc meta dir-vector)
"Compute the size of the encoded directory,
passed as a vector, and some other things.
The directory itself must have some sensible meta-data defined."
(let* ((header-size (+ (bytevector-length directory-magic) 4))
(with-meta-size (+ header-size (meta-serialized-size meta))))
(if (< 0 (vector-length dir-vector))
(let ((sizes (vector-map entry-length dir-vector))
(perm (vector-unfold values (vector-length dir-vector))))
(block-align! with-meta-size (vector-length dir-vector) sizes perm)
;; compute final size with alignment
(let loop ((i 0)
(size with-meta-size)
(psize with-meta-size))
(if (< i (vector-length dir-vector))
(loop (1+ i)
(do-align (+ size (vector-length sizes)) size)
size)
(values size sizes perm))))
(values with-meta-size #f #f))))
(define (build-directory meta dir-vector)
"Finish building the directory.
Returns the directory in-memory as a bytevector.
@param dir-vector directory entries of directory
@param meta metadata of directory (see meta-data-mark-directory)
@return the directory as a bytevector"
(receive (size sizes perm)
(directory-size-etc meta dir-vector)
(let* ((bv (make-bytevector size 0))
(offset0 (bytevector-length directory-magic))
(meta-serialize-ret ; TODO: is this a size?
(meta-data-serialize-full! meta bv offset0 (- size offset0 4))))
(bytevector-copy! directory-magic 0 bv 0
(bytevector-length directory-magic))
(bytevector-u32-set! bv offset0 meta-serialize-ret (endianness big))
(let loop ((j 0) (offset (+ offset0 4 meta-serialize-ret)))
(if (< j (vector-length dir-vector))
(let* ((i (vector-ref perm j))
(psize offset)
(offset (do-align psize (+ offset (vector-ref sizes i)))))
(bytevector-copy!
(directory-entry-bv (vector-ref dir-vector i)) 0
bv (- offset (vector-ref sizes i)) (vector-ref sizes i))
(loop (1+ j) offset))
(begin (assert (= offset size))
bv)))))))
|
