aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAnonymized <anonymous@example.com>2018-01-20 02:01:04 +0100
committerAnonymized <anonymous@example.com>2018-01-20 02:01:04 +0100
commitddb16c130f1583d35f0e5703d0317745881c7ad8 (patch)
treea76ad7191b057e324f0157470f4d533ffef647bb
parentf50fa35cef38cbc52862dd4ed5a8677b2eab4620 (diff)
downloadgnunet-guile2-ddb16c130f1583d35f0e5703d0317745881c7ad8.tar.gz
gnunet-guile2-ddb16c130f1583d35f0e5703d0317745881c7ad8.zip
c3b2: publish on gnunet
-rw-r--r--prototypes/c3b2/hmac.scm54
-rw-r--r--prototypes/c3b2/sha-2.scm583
-rwxr-xr-xprototypes/c3b2/web.scm50
3 files changed, 666 insertions, 21 deletions
diff --git a/prototypes/c3b2/hmac.scm b/prototypes/c3b2/hmac.scm
new file mode 100644
index 0000000..2a3fa02
--- /dev/null
+++ b/prototypes/c3b2/hmac.scm
@@ -0,0 +1,54 @@
1;; -*- mode: scheme; coding: utf-8 -*-
2;; Copyright © 2009, 2012 Göran Weinholt <goran@weinholt.se>
3
4;; Permission is hereby granted, free of charge, to any person obtaining a
5;; copy of this software and associated documentation files (the "Software"),
6;; to deal in the Software without restriction, including without limitation
7;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
8;; and/or sell copies of the Software, and to permit persons to whom the
9;; Software is furnished to do so, subject to the following conditions:
10
11;; The above copyright notice and this permission notice shall be included in
12;; all copies or substantial portions of the Software.
13
14;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
17;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
18;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
19;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
20;; DEALINGS IN THE SOFTWARE.
21#!r6rs
22
23;; RFC 2104, FIPS-198-1.
24
25(library (hmac)
26 (export make-hmac)
27 (import (rnrs))
28
29 ;; Returns a procedure that calculates the HMAC given a secret and
30 ;; data (both of which are bytevectors).
31 (define (make-hmac block-length hash ->bytevector make-hash update! finish! clear!)
32 (lambda (secret . data)
33 (let lp ((secret secret))
34 (if (> (bytevector-length secret) block-length)
35 (lp (->bytevector (hash secret)))
36 (let ((k-ipad (make-bytevector block-length 0))
37 (k-opad (make-bytevector block-length 0)))
38 (bytevector-copy! secret 0 k-ipad 0 (bytevector-length secret))
39 (bytevector-copy! secret 0 k-opad 0 (bytevector-length secret))
40 (do ((i 0 (fx+ i 1)))
41 ((fx=? i block-length))
42 (bytevector-u8-set! k-ipad i (fxxor #x36 (bytevector-u8-ref k-ipad i)))
43 (bytevector-u8-set! k-opad i (fxxor #x5c (bytevector-u8-ref k-opad i))))
44 (let ((state (make-hash)))
45 (update! state k-ipad)
46 (for-each (lambda (d) (update! state d)) data)
47 (finish! state)
48 (let ((digest (->bytevector state)))
49 (clear! state)
50 (update! state k-opad)
51 (update! state digest)
52 (finish! state)
53 state)))))))
54 )
diff --git a/prototypes/c3b2/sha-2.scm b/prototypes/c3b2/sha-2.scm
new file mode 100644
index 0000000..761cb71
--- /dev/null
+++ b/prototypes/c3b2/sha-2.scm
@@ -0,0 +1,583 @@
1;; -*- mode: scheme; coding: utf-8 -*-
2;; Copyright © 2009, 2010, 2012 Göran Weinholt <goran@weinholt.se>
3
4;; Permission is hereby granted, free of charge, to any person obtaining a
5;; copy of this software and associated documentation files (the "Software"),
6;; to deal in the Software without restriction, including without limitation
7;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
8;; and/or sell copies of the Software, and to permit persons to whom the
9;; Software is furnished to do so, subject to the following conditions:
10
11;; The above copyright notice and this permission notice shall be included in
12;; all copies or substantial portions of the Software.
13
14;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
17;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
18;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
19;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
20;; DEALINGS IN THE SOFTWARE.
21#!r6rs
22
23;; Byte-oriented SHA-224/256 and SHA-384/512 from FIPS 180-3
24
25;; RFC3874 SHA-224
26
27;; TODO: give an error if more than 2^64 / 2^128 bits are processed?
28;; TODO: Optimize. Should be simple enough with the help of a profiler.
29
30(library (sha-2)
31 (export make-sha-224 sha-224-update! sha-224-finish! sha-224-clear!
32 sha-224 sha-224-copy sha-224-finish sha-224-length
33 sha-224-copy-hash! sha-224-128-copy-hash!
34 sha-224->bytevector sha-224->string
35 sha-224-hash=? sha-224-128-hash=?
36 hmac-sha-224
37
38 make-sha-256 sha-256-update! sha-256-finish! sha-256-clear!
39 sha-256 sha-256-copy sha-256-finish sha-256-length
40 sha-256-copy-hash! sha-256-128-copy-hash!
41 sha-256->bytevector sha-256->string
42 sha-256-hash=? sha-256-128-hash=?
43 hmac-sha-256
44
45 make-sha-384 sha-384-update! sha-384-finish! sha-384-clear!
46 sha-384 sha-384-copy sha-384-finish sha-384-length
47 sha-384-copy-hash! sha-384-128-copy-hash!
48 sha-384->bytevector sha-384->string
49 sha-384-hash=? sha-384-128-hash=?
50 hmac-sha-384
51
52 make-sha-512 sha-512-update! sha-512-finish! sha-512-clear!
53 sha-512 sha-512-copy sha-512-finish sha-512-length
54 sha-512-copy-hash! sha-512-128-copy-hash!
55 sha-512->bytevector sha-512->string
56 sha-512-hash=? sha-512-128-hash=?
57 hmac-sha-512)
58 (import (rnrs)
59 (hmac))
60
61 (define (sha-224-length) 224/8)
62 (define (sha-256-length) 256/8)
63 (define (sha-384-length) 384/8)
64 (define (sha-512-length) 512/8)
65
66 (define (vector-copy x) (vector-map (lambda (i) i) x))
67
68 (define (ror32 n count)
69 (let ((field1 (bitwise-and #xffffffff (bitwise-arithmetic-shift-left n (- 32 count))))
70 (field2 (bitwise-arithmetic-shift-right n count)))
71 (bitwise-ior field1 field2)))
72
73 (define (ror64 n count)
74 (let ((field1 (bitwise-and #xffffffffffffffff
75 (bitwise-arithmetic-shift-left n (- 64 count))))
76 (field2 (bitwise-arithmetic-shift-right n count)))
77 (bitwise-ior field1 field2)))
78
79
80 (define-record-type sha-state
81 (fields (immutable H) ;Hash
82 (immutable init) ;initial hash
83 (immutable W) ;temporary data
84 (immutable m) ;unprocessed data
85 (mutable pending) ;length of unprocessed data
86 (mutable processed))) ;length of processed data
87
88 (define (make-sha-2 initial-hash)
89 (let ((W (make-vector 80 #f))
90 (m (make-bytevector (* 4 32))))
91 (make-sha-state (list->vector initial-hash)
92 initial-hash
93 W m 0 0)))
94
95 (define (make-sha-224) (make-sha-2 initial-hash224))
96 (define (make-sha-256) (make-sha-2 initial-hash256))
97 (define (make-sha-384) (make-sha-2 initial-hash384))
98 (define (make-sha-512) (make-sha-2 initial-hash512))
99
100 (define (sha-2-copy state)
101 (let ((H (vector-copy (sha-state-H state)))
102 (W (make-vector 80 #f))
103 (m (bytevector-copy (sha-state-m state))))
104 (make-sha-state H
105 (sha-state-init state)
106 W m
107 (sha-state-pending state)
108 (sha-state-processed state))))
109
110 (define (sha-224-copy x) (sha-2-copy x))
111 (define (sha-256-copy x) (sha-2-copy x))
112 (define (sha-384-copy x) (sha-2-copy x))
113 (define (sha-512-copy x) (sha-2-copy x))
114
115 (define (sha-2-clear! state)
116 (do ((init (sha-state-init state) (cdr init))
117 (i 0 (+ i 1)))
118 ((null? init))
119 (vector-set! (sha-state-H state) i (car init)))
120 (vector-fill! (sha-state-W state) #f)
121 (bytevector-fill! (sha-state-m state) 0)
122 (sha-state-pending-set! state 0)
123 (sha-state-processed-set! state 0))
124
125 (define (sha-224-clear! state) (sha-2-clear! state))
126 (define (sha-256-clear! state) (sha-2-clear! state))
127 (define (sha-384-clear! state) (sha-2-clear! state))
128 (define (sha-512-clear! state) (sha-2-clear! state))
129
130
131 (define initial-hash224 '(#xc1059ed8 #x367cd507 #x3070dd17 #xf70e5939
132 #xffc00b31 #x68581511 #x64f98fa7 #xbefa4fa4))
133
134 (define initial-hash256 '(#x6a09e667 #xbb67ae85 #x3c6ef372 #xa54ff53a
135 #x510e527f #x9b05688c #x1f83d9ab #x5be0cd19))
136
137 (define initial-hash384 '(#xcbbb9d5dc1059ed8 #x629a292a367cd507
138 #x9159015a3070dd17 #x152fecd8f70e5939
139 #x67332667ffc00b31 #x8eb44a8768581511
140 #xdb0c2e0d64f98fa7 #x47b5481dbefa4fa4))
141
142 (define initial-hash512 '(#x6a09e667f3bcc908 #xbb67ae8584caa73b
143 #x3c6ef372fe94f82b #xa54ff53a5f1d36f1
144 #x510e527fade682d1 #x9b05688c2b3e6c1f
145 #x1f83d9abfb41bd6b #x5be0cd19137e2179))
146
147
148 (define (Ch x y z)
149 (bitwise-xor (bitwise-and x y)
150 (bitwise-and (bitwise-not x) z)))
151
152 (define Parity bitwise-xor)
153
154 (define (Maj x y z)
155 (bitwise-xor (bitwise-and x y)
156 (bitwise-and x z)
157 (bitwise-and y z)))
158
159
160
161 (define (Sigma0-256 x)
162 (bitwise-xor (ror32 x 2)
163 (ror32 x 13)
164 (ror32 x 22)))
165
166 (define (Sigma1-256 x)
167 (bitwise-xor (ror32 x 6)
168 (ror32 x 11)
169 (ror32 x 25)))
170
171 (define (sigma0-256 x)
172 (bitwise-xor (ror32 x 7)
173 (ror32 x 18)
174 (bitwise-arithmetic-shift-right x 3)))
175
176 (define (sigma1-256 x)
177 (bitwise-xor (ror32 x 17)
178 (ror32 x 19)
179 (bitwise-arithmetic-shift-right x 10)))
180
181
182 (define (Sigma0-512 x)
183 (bitwise-xor (ror64 x 28)
184 (ror64 x 34)
185 (ror64 x 39)))
186
187 (define (Sigma1-512 x)
188 (bitwise-xor (ror64 x 14)
189 (ror64 x 18)
190 (ror64 x 41)))
191
192 (define (sigma0-512 x)
193 (bitwise-xor (ror64 x 1)
194 (ror64 x 8)
195 (bitwise-arithmetic-shift-right x 7)))
196
197 (define (sigma1-512 x)
198 (bitwise-xor (ror64 x 19)
199 (ror64 x 61)
200 (bitwise-arithmetic-shift-right x 6)))
201
202 (define k-256
203 '#(#x428a2f98 #x71374491 #xb5c0fbcf #xe9b5dba5
204 #x3956c25b #x59f111f1 #x923f82a4 #xab1c5ed5
205 #xd807aa98 #x12835b01 #x243185be #x550c7dc3
206 #x72be5d74 #x80deb1fe #x9bdc06a7 #xc19bf174
207 #xe49b69c1 #xefbe4786 #x0fc19dc6 #x240ca1cc
208 #x2de92c6f #x4a7484aa #x5cb0a9dc #x76f988da
209 #x983e5152 #xa831c66d #xb00327c8 #xbf597fc7
210 #xc6e00bf3 #xd5a79147 #x06ca6351 #x14292967
211 #x27b70a85 #x2e1b2138 #x4d2c6dfc #x53380d13
212 #x650a7354 #x766a0abb #x81c2c92e #x92722c85
213 #xa2bfe8a1 #xa81a664b #xc24b8b70 #xc76c51a3
214 #xd192e819 #xd6990624 #xf40e3585 #x106aa070
215 #x19a4c116 #x1e376c08 #x2748774c #x34b0bcb5
216 #x391c0cb3 #x4ed8aa4a #x5b9cca4f #x682e6ff3
217 #x748f82ee #x78a5636f #x84c87814 #x8cc70208
218 #x90befffa #xa4506ceb #xbef9a3f7 #xc67178f2))
219
220 (define k-512
221 '#(#x428a2f98d728ae22 #x7137449123ef65cd #xb5c0fbcfec4d3b2f #xe9b5dba58189dbbc
222 #x3956c25bf348b538 #x59f111f1b605d019 #x923f82a4af194f9b #xab1c5ed5da6d8118
223 #xd807aa98a3030242 #x12835b0145706fbe #x243185be4ee4b28c #x550c7dc3d5ffb4e2
224 #x72be5d74f27b896f #x80deb1fe3b1696b1 #x9bdc06a725c71235 #xc19bf174cf692694
225 #xe49b69c19ef14ad2 #xefbe4786384f25e3 #x0fc19dc68b8cd5b5 #x240ca1cc77ac9c65
226 #x2de92c6f592b0275 #x4a7484aa6ea6e483 #x5cb0a9dcbd41fbd4 #x76f988da831153b5
227 #x983e5152ee66dfab #xa831c66d2db43210 #xb00327c898fb213f #xbf597fc7beef0ee4
228 #xc6e00bf33da88fc2 #xd5a79147930aa725 #x06ca6351e003826f #x142929670a0e6e70
229 #x27b70a8546d22ffc #x2e1b21385c26c926 #x4d2c6dfc5ac42aed #x53380d139d95b3df
230 #x650a73548baf63de #x766a0abb3c77b2a8 #x81c2c92e47edaee6 #x92722c851482353b
231 #xa2bfe8a14cf10364 #xa81a664bbc423001 #xc24b8b70d0f89791 #xc76c51a30654be30
232 #xd192e819d6ef5218 #xd69906245565a910 #xf40e35855771202a #x106aa07032bbd1b8
233 #x19a4c116b8d2d0c8 #x1e376c085141ab53 #x2748774cdf8eeb99 #x34b0bcb5e19b48a8
234 #x391c0cb3c5c95a63 #x4ed8aa4ae3418acb #x5b9cca4f7763e373 #x682e6ff3d6b2b8a3
235 #x748f82ee5defb2fc #x78a5636f43172f60 #x84c87814a1f0ab72 #x8cc702081a6439ec
236 #x90befffa23631e28 #xa4506cebde82bde9 #xbef9a3f7b2c67915 #xc67178f2e372532b
237 #xca273eceea26619c #xd186b8c721c0c207 #xeada7dd6cde0eb1e #xf57d4f7fee6ed178
238 #x06f067aa72176fba #x0a637dc5a2c898a6 #x113f9804bef90dae #x1b710b35131c471b
239 #x28db77f523047d84 #x32caab7b40c72493 #x3c9ebe0a15c9bebc #x431d67c49c100d4c
240 #x4cc5d4becb3e42b6 #x597f299cfc657e2a #x5fcb6fab3ad6faec #x6c44198c4a475817))
241
242 ;; This function transforms a whole 512 bit block.
243 (define (sha-256-transform! H* W m offset)
244 ;; Copy the message block
245 (do ((t 0 (+ t 1)))
246 ((= t 16))
247 (vector-set! W t (bytevector-u32-ref m (+ (* t 4) offset) (endianness big))))
248 ;; Initialize W[16..63]
249 (do ((t 16 (+ t 1)))
250 ((= t 64))
251 (vector-set! W t (bitwise-and (+ (sigma1-256 (vector-ref W (- t 2)))
252 (vector-ref W (- t 7))
253 (sigma0-256 (vector-ref W (- t 15)))
254 (vector-ref W (- t 16)))
255 #xffffffff)))
256 ;; Do the hokey pokey
257 (let lp ((A (vector-ref H* 0))
258 (B (vector-ref H* 1))
259 (C (vector-ref H* 2))
260 (D (vector-ref H* 3))
261 (E (vector-ref H* 4))
262 (F (vector-ref H* 5))
263 (G (vector-ref H* 6))
264 (H (vector-ref H* 7))
265 (t 0))
266 (cond ((= t 64)
267 (vector-set! H* 0 (bitwise-and #xffffffff (+ A (vector-ref H* 0))))
268 (vector-set! H* 1 (bitwise-and #xffffffff (+ B (vector-ref H* 1))))
269 (vector-set! H* 2 (bitwise-and #xffffffff (+ C (vector-ref H* 2))))
270 (vector-set! H* 3 (bitwise-and #xffffffff (+ D (vector-ref H* 3))))
271 (vector-set! H* 4 (bitwise-and #xffffffff (+ E (vector-ref H* 4))))
272 (vector-set! H* 5 (bitwise-and #xffffffff (+ F (vector-ref H* 5))))
273 (vector-set! H* 6 (bitwise-and #xffffffff (+ G (vector-ref H* 6))))
274 (vector-set! H* 7 (bitwise-and #xffffffff (+ H (vector-ref H* 7)))))
275 (else
276 (let ((T1 (+ H (Sigma1-256 E) (Ch E F G)
277 (vector-ref k-256 t) (vector-ref W t)))
278 (T2 (+ (Sigma0-256 A) (Maj A B C))))
279 (lp (bitwise-and #xffffffff (+ T1 T2))
280 A B C
281 (bitwise-and #xffffffff (+ D T1))
282 E F G
283 (+ t 1)))))))
284
285 ;; This function transforms a whole 1024 bit block.
286 (define (sha-512-transform! H* W m offset)
287 ;; Copy the message block
288 (do ((t 0 (+ t 1)))
289 ((= t 16))
290 (vector-set! W t (bytevector-u64-ref m (+ (* t 8) offset) (endianness big))))
291 ;; Initialize W[16..63]
292 (do ((t 16 (+ t 1)))
293 ((= t 80))
294 (vector-set! W t (bitwise-and (+ (sigma1-512 (vector-ref W (- t 2)))
295 (vector-ref W (- t 7))
296 (sigma0-512 (vector-ref W (- t 15)))
297 (vector-ref W (- t 16)))
298 #xffffffffffffffff)))
299 ;; Do the hokey pokey
300 (let lp ((A (vector-ref H* 0))
301 (B (vector-ref H* 1))
302 (C (vector-ref H* 2))
303 (D (vector-ref H* 3))
304 (E (vector-ref H* 4))
305 (F (vector-ref H* 5))
306 (G (vector-ref H* 6))
307 (H (vector-ref H* 7))
308 (t 0))
309 (cond ((= t 80)
310 (vector-set! H* 0 (bitwise-and #xffffffffffffffff (+ A (vector-ref H* 0))))
311 (vector-set! H* 1 (bitwise-and #xffffffffffffffff (+ B (vector-ref H* 1))))
312 (vector-set! H* 2 (bitwise-and #xffffffffffffffff (+ C (vector-ref H* 2))))
313 (vector-set! H* 3 (bitwise-and #xffffffffffffffff (+ D (vector-ref H* 3))))
314 (vector-set! H* 4 (bitwise-and #xffffffffffffffff (+ E (vector-ref H* 4))))
315 (vector-set! H* 5 (bitwise-and #xffffffffffffffff (+ F (vector-ref H* 5))))
316 (vector-set! H* 6 (bitwise-and #xffffffffffffffff (+ G (vector-ref H* 6))))
317 (vector-set! H* 7 (bitwise-and #xffffffffffffffff (+ H (vector-ref H* 7)))))
318 (else
319 (let ((T1 (+ H (Sigma1-512 E) (Ch E F G)
320 (vector-ref k-512 t) (vector-ref W t)))
321 (T2 (+ (Sigma0-512 A) (Maj A B C))))
322 (lp (bitwise-and #xffffffffffffffff (+ T1 T2))
323 A B C
324 (bitwise-and #xffffffffffffffff (+ D T1))
325 E F G
326 (+ t 1)))))))
327
328 (define (sha-224-update! . x) (apply sha-256-update! x))
329
330 ;; Add a bytevector to the state. Align your data to whole blocks if
331 ;; you want this to go a little faster.
332 (define sha-256-update!
333 (case-lambda
334 ((state data start end)
335 (let ((m (sha-state-m state)) ;unprocessed data
336 (H (sha-state-H state))
337 (W (sha-state-W state)))
338 (let lp ((offset start))
339 (cond ((= (sha-state-pending state) 64)
340 ;; A whole block is pending
341 (sha-256-transform! H W m 0)
342 (sha-state-pending-set! state 0)
343 (sha-state-processed-set! state (+ 64 (sha-state-processed state)))
344 (lp offset))
345 ((= offset end)
346 (values))
347 ((or (> (sha-state-pending state) 0)
348 (> (+ offset 64) end))
349 ;; Pending data exists or less than a block remains.
350 ;; Add more pending data.
351 (let ((added (min (- 64 (sha-state-pending state))
352 (- end offset))))
353 (bytevector-copy! data offset
354 m (sha-state-pending state)
355 added)
356 (sha-state-pending-set! state (+ added (sha-state-pending state)))
357 (lp (+ offset added))))
358 (else
359 ;; Consume a whole block
360 (sha-256-transform! H W data offset)
361 (sha-state-processed-set! state (+ 64 (sha-state-processed state)))
362 (lp (+ offset 64)))))))
363 ((state data)
364 (sha-256-update! state data 0 (bytevector-length data)))))
365
366 (define (sha-384-update! . x) (apply sha-512-update! x))
367
368 (define sha-512-update!
369 (case-lambda
370 ((state data start end)
371 (let ((m (sha-state-m state)) ;unprocessed data
372 (H (sha-state-H state))
373 (W (sha-state-W state)))
374 (let lp ((offset start))
375 (cond ((= (sha-state-pending state) 128)
376 ;; A whole block is pending
377 (sha-512-transform! H W m 0)
378 (sha-state-pending-set! state 0)
379 (sha-state-processed-set! state (+ 128 (sha-state-processed state)))
380 (lp offset))
381 ((= offset end)
382 (values))
383 ((or (> (sha-state-pending state) 0)
384 (> (+ offset 128) end))
385 ;; Pending data exists or less than a block remains.
386 ;; Add more pending data.
387 (let ((added (min (- 128 (sha-state-pending state))
388 (- end offset))))
389 (bytevector-copy! data offset
390 m (sha-state-pending state)
391 added)
392 (sha-state-pending-set! state (+ added (sha-state-pending state)))
393 (lp (+ offset added))))
394 (else
395 ;; Consume a whole block
396 (sha-512-transform! H W data offset)
397 (sha-state-processed-set! state (+ 128 (sha-state-processed state)))
398 (lp (+ offset 128)))))))
399 ((state data)
400 (sha-512-update! state data 0 (bytevector-length data)))))
401
402
403 (define zero-block (make-bytevector 128 0))
404
405 (define (sha-224-finish! state) (sha-256-finish! state))
406
407 ;; Finish the state by adding a 1, zeros and the counter.
408 (define (sha-256-finish! state)
409 (let ((m (sha-state-m state))
410 (pending (+ (sha-state-pending state) 1)))
411 (bytevector-u8-set! m (sha-state-pending state) #x80)
412 (cond ((> pending 56)
413 (bytevector-copy! zero-block 0
414 m pending
415 (- 64 pending))
416 (sha-256-transform! (sha-state-H state)
417 (sha-state-W state)
418 m
419 0)
420 (bytevector-fill! m 0))
421 (else
422 (bytevector-copy! zero-block 0
423 m pending
424 (- 64 pending))))
425 ;; Number of bits in the data
426 (bytevector-u64-set! m 56
427 (* (+ (sha-state-processed state)
428 (- pending 1))
429 8)
430 (endianness big))
431 (sha-256-transform! (sha-state-H state)
432 (sha-state-W state)
433 m
434 0)))
435
436 (define (sha-384-finish! state) (sha-512-finish! state))
437
438 (define (sha-512-finish! state)
439 (let ((m (sha-state-m state))
440 (pending (+ (sha-state-pending state) 1)))
441 (bytevector-u8-set! m (sha-state-pending state) #x80)
442 (cond ((> pending 112)
443 (bytevector-copy! zero-block 0
444 m pending
445 (- 128 pending))
446 (sha-512-transform! (sha-state-H state)
447 (sha-state-W state)
448 m
449 0)
450 (bytevector-fill! m 0))
451 (else
452 (bytevector-copy! zero-block 0
453 m pending
454 (- 128 pending))))
455 ;; Number of bits in the data
456 (bytevector-uint-set! m 112
457 (* (+ (sha-state-processed state)
458 (- pending 1))
459 8)
460 (endianness big)
461 16)
462 (sha-512-transform! (sha-state-H state)
463 (sha-state-W state)
464 m
465 0)))
466
467 (define (sha-2-finish copy finish!)
468 (lambda (state)
469 (let ((copy (copy state)))
470 (finish! copy)
471 copy)))
472
473 (define sha-224-finish (sha-2-finish sha-224-copy sha-224-finish!))
474 (define sha-256-finish (sha-2-finish sha-256-copy sha-256-finish!))
475 (define sha-384-finish (sha-2-finish sha-384-copy sha-384-finish!))
476 (define sha-512-finish (sha-2-finish sha-512-copy sha-512-finish!))
477
478 ;; Find the message digest of the concatenation of the given bytevectors.
479 (define (sha-2 make update! finish!)
480 (lambda data
481 (let ((state (make)))
482 (for-each (lambda (d) (update! state d))
483 data)
484 (finish! state)
485 state)))
486
487 (define sha-224 (sha-2 make-sha-224 sha-224-update! sha-224-finish!))
488 (define sha-256 (sha-2 make-sha-256 sha-256-update! sha-256-finish!))
489 (define sha-384 (sha-2 make-sha-384 sha-384-update! sha-384-finish!))
490 (define sha-512 (sha-2 make-sha-512 sha-512-update! sha-512-finish!))
491
492 (define (sha-2/32-copy-hash! len)
493 (lambda (state bv off)
494 (do ((i 0 (+ i 1)))
495 ((= i len))
496 (bytevector-u32-set! bv (+ off (* 4 i))
497 (vector-ref (sha-state-H state) i)
498 (endianness big)))))
499
500 (define sha-224-copy-hash! (sha-2/32-copy-hash! 224/32))
501 (define sha-256-copy-hash! (sha-2/32-copy-hash! 256/32))
502 (define sha-224-128-copy-hash! (sha-2/32-copy-hash! 128/32))
503 (define sha-256-128-copy-hash! (sha-2/32-copy-hash! 128/32))
504
505 (define (sha-2/64-copy-hash! len)
506 (lambda (state bv off)
507 (do ((i 0 (+ i 1)))
508 ((= i len))
509 (bytevector-u64-set! bv (+ off (* 8 i))
510 (vector-ref (sha-state-H state) i)
511 (endianness big)))))
512
513 (define sha-384-copy-hash! (sha-2/64-copy-hash! 384/64))
514 (define sha-512-copy-hash! (sha-2/64-copy-hash! 512/64))
515 (define sha-384-128-copy-hash! (sha-2/64-copy-hash! 128/64))
516 (define sha-512-128-copy-hash! (sha-2/64-copy-hash! 128/64))
517
518 (define (sha-2->bytevector copy! len)
519 (lambda (state)
520 (let ((ret (make-bytevector (* 4 len))))
521 (copy! state ret 0)
522 ret)))
523
524 (define sha-224->bytevector (sha-2->bytevector sha-224-copy-hash! 224/32))
525 (define sha-256->bytevector (sha-2->bytevector sha-256-copy-hash! 256/32))
526 (define sha-384->bytevector (sha-2->bytevector sha-384-copy-hash! 384/32))
527 (define sha-512->bytevector (sha-2->bytevector sha-512-copy-hash! 512/32))
528
529 (define (sha-2->string ->bytevector)
530 (lambda (state)
531 (apply string-append
532 (map (lambda (x)
533 (if (< x #x10)
534 (string-append "0" (number->string x 16))
535 (number->string x 16)))
536 (bytevector->u8-list (->bytevector state))))))
537
538 (define sha-224->string (sha-2->string sha-224->bytevector))
539 (define sha-256->string (sha-2->string sha-256->bytevector))
540 (define sha-384->string (sha-2->string sha-384->bytevector))
541 (define sha-512->string (sha-2->string sha-512->bytevector))
542
543 (define (cmp/32 state bv len)
544 (do ((i 0 (fx+ i 1))
545 (diff 0 (+ diff
546 (bitwise-xor
547 (bytevector-u32-ref bv (* 4 i) (endianness big))
548 (vector-ref (sha-state-H state) i)))))
549 ((fx=? i len)
550 (zero? diff))))
551
552 (define (sha-224-hash=? state bv) (cmp/32 state bv 224/32))
553 (define (sha-256-hash=? state bv) (cmp/32 state bv 256/32))
554 (define (sha-384-hash=? state bv) (cmp/64 state bv 384/64))
555 (define (sha-512-hash=? state bv) (cmp/64 state bv 512/64))
556
557 (define (cmp/64 state bv len)
558 (do ((i 0 (fx+ i 1))
559 (diff 0 (+ diff
560 (bitwise-xor
561 (bytevector-u64-ref bv (* 8 i) (endianness big))
562 (vector-ref (sha-state-H state) i)))))
563 ((fx=? i len)
564 (zero? diff))))
565
566 (define (sha-224-128-hash=? state bv) (cmp/32 state bv 128/32))
567 (define (sha-256-128-hash=? state bv) (cmp/32 state bv 128/32))
568 (define (sha-384-128-hash=? state bv) (cmp/64 state bv 128/64))
569 (define (sha-512-128-hash=? state bv) (cmp/64 state bv 128/64))
570
571 (define hmac-sha-224
572 (make-hmac 64 sha-224 sha-224->bytevector make-sha-224 sha-224-update! sha-224-finish! sha-224-clear!))
573
574 (define hmac-sha-256
575 (make-hmac 64 sha-256 sha-256->bytevector make-sha-256 sha-256-update! sha-256-finish! sha-256-clear!))
576
577 (define hmac-sha-384
578 (make-hmac 128 sha-384 sha-384->bytevector make-sha-384 sha-384-update! sha-384-finish! sha-384-clear!))
579
580 (define hmac-sha-512
581 (make-hmac 128 sha-512 sha-512->bytevector make-sha-512 sha-512-update! sha-512-finish! sha-512-clear!))
582
583 )
diff --git a/prototypes/c3b2/web.scm b/prototypes/c3b2/web.scm
index 0f72aa0..1c430c3 100755
--- a/prototypes/c3b2/web.scm
+++ b/prototypes/c3b2/web.scm
@@ -23,6 +23,8 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
23(use-modules ((ice-9 match))) 23(use-modules ((ice-9 match)))
24(use-modules ((web request))) 24(use-modules ((web request)))
25(use-modules ((web uri))) 25(use-modules ((web uri)))
26(use-modules ((rnrs bytevectors)))
27(use-modules (ice-9 binary-ports))
26 28
27;; third party 29;; third party
28(use-modules ((fibers web server))) 30(use-modules ((fibers web server)))
@@ -37,34 +39,28 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
37(use-modules ((web html))) 39(use-modules ((web html)))
38(use-modules ((web mime-types))) 40(use-modules ((web mime-types)))
39(use-modules ((web static))) 41(use-modules ((web static)))
42(use-modules ((sha-2)))
40 43
44;; gnunet
45(use-modules ((gnunet sync)))
41 46
42(setlocale LC_ALL "")
43
44;;; helpers
45;;
46;; until we have real messages backend by wt and gnunet
47;;
48 47
49(define %loremipsum (string-split "Suspendisse potenti. Quisque ac orci sed metus molestie ornare. Nam in neque magna. Proin vel consectetur nisl, a suscipit est. Ut eget lectus maximus, scelerisque felis non, gravida leo. Pellentesque nisi risus, posuere vitae elit eget, efficitur euismod risus. Cras pulvinar, nisl vitae tincidunt hendrerit, dui nulla pellentesque libero, vel maximus erat arcu sed dui. Mauris porta dui nec arcu auctor, quis tristique massa dictum. Etiam consequat leo quis tortor vulputate, vitae eleifend lorem tempus. Lorem ipsum dolor sit amet, consectetur adipiscing elit. Quisque a enim scelerisque, tristique turpis sed, accumsan velit. Proin eleifend, augue sit amet efficitur volutpat, magna ipsum consequat elit, vel tempor est nulla et sem. Cras faucibus odio ac est vestibulum varius. Sed lobortis fringilla egestas. Vestibulum pulvinar est vel mauris malesuada, at dapibus nibh rutrum. Etiam pellentesque lacus nec sapien pharetra, quis ultrices lorem condimentum!" #\space)) 48(setlocale LC_ALL "")
50 49
51(define (choice lst)
52 (list-ref lst (random (length lst))))
53 50
54(define (loremipsum length) 51(define %configuration #f)
55 (string-join (map (lambda _ (choice %loremipsum)) (iota length)) " ")) 52(define %home #f)
56 53
57(define (make-message body parent) 54;;; helpers
58 `((parent . ,parent)
59 (body . ,body)))
60 55
61(define (make-random-topic) 56(define (make-hash bv)
62 (make-message (loremipsum 99) #f)) 57 (let ((hash (make-sha-512)))
58 (sha-512-update! hash bv)
59 (sha-512-finish! hash)
60 (sha-512->string hash)))
63 61
64;;; 62;;;
65 63
66(define %topics (map (lambda _ (make-random-topic)) (iota 0)))
67
68(define (c3b2/topics) 64(define (c3b2/topics)
69 "Return vertices of topics ie. messages without parent" 65 "Return vertices of topics ie. messages without parent"
70 (map get (fs:find 'parent #f))) 66 (map get (fs:find 'parent #f)))
@@ -73,7 +69,16 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
73 (let ((new-topic `((kind . message) 69 (let ((new-topic `((kind . message)
74 (body . ,body) 70 (body . ,body)
75 (parent . #f)))) 71 (parent . #f))))
76 (save (create-vertex new-topic)))) 72 (let ((topic (save (create-vertex new-topic))))
73 (let* ((payload (vertex-ref topic 'body))
74 (payload (string->utf8 payload))
75 (hash (make-hash payload))
76 (filepath (string-append %home "/" hash)))
77 (call-with-output-file filepath
78 (lambda (port)
79 (put-bytevector port payload))
80 #:binary #t)
81 (publish %configuration filepath '("c3b2://v1/topic"))))))
77 82
78;;; web 83;;; web
79 84
@@ -108,7 +113,7 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
108 (render-html (template "index" (template/index (c3b2/topics))))) 113 (render-html (template "index" (template/index (c3b2/topics)))))
109 114
110(define (route/index/post body) 115(define (route/index/post body)
111 (c3b2/topic-add! (assoc-ref (decode body) "body")) 116 (c3b2/topic-add! (car (assoc-ref (decode body) "body")))
112 (redirect "/")) 117 (redirect "/"))
113 118
114(define (router request body) 119(define (router request body)
@@ -120,7 +125,10 @@ exec guile -L $(pwd) -e '(@ (web) main)' -s "$0" "$@"
120 (_ (not-found (uri->string (request-uri request))))))) 125 (_ (not-found (uri->string (request-uri request)))))))
121 126
122 127
123(define-public (main _) 128(define-public (main args)
129 (set! %configuration (cadr args))
130 (set! %home (caddr args))
131 (pk %configuration %home)
124 (format #t "Server running @ http://localhost:8080\n") 132 (format #t "Server running @ http://localhost:8080\n")
125 (with-env (env-open* "wt" (list *feature-space*) "create,log=(enabled=true)") 133 (with-env (env-open* "wt" (list *feature-space*) "create,log=(enabled=true)")
126 (run-server router))) 134 (run-server router)))