diff options
author | Anonymized <anonymous@example.com> | 2018-01-20 02:01:04 +0100 |
---|---|---|
committer | Anonymized <anonymous@example.com> | 2018-01-20 02:01:04 +0100 |
commit | ddb16c130f1583d35f0e5703d0317745881c7ad8 (patch) | |
tree | a76ad7191b057e324f0157470f4d533ffef647bb | |
parent | f50fa35cef38cbc52862dd4ed5a8677b2eab4620 (diff) | |
download | gnunet-guile2-ddb16c130f1583d35f0e5703d0317745881c7ad8.tar.gz gnunet-guile2-ddb16c130f1583d35f0e5703d0317745881c7ad8.zip |
c3b2: publish on gnunet
-rw-r--r-- | prototypes/c3b2/hmac.scm | 54 | ||||
-rw-r--r-- | prototypes/c3b2/sha-2.scm | 583 | ||||
-rwxr-xr-x | prototypes/c3b2/web.scm | 50 |
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))) |