Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
0d5d888474
|
|
@ -10,6 +10,6 @@ CONSTANT: adler-32-modulus 65521
|
|||
|
||||
M: adler-32 checksum-bytes ( bytes checksum -- value )
|
||||
drop
|
||||
[ sum 1+ ]
|
||||
[ sum 1 + ]
|
||||
[ [ dup length [1,b] <reversed> v. ] [ length ] bi + ] bi
|
||||
[ adler-32-modulus mod ] bi@ 16 shift bitor ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,48 @@
|
|||
USING: kernel io strings byte-arrays sequences namespaces math
|
||||
parser checksums.hmac tools.test checksums.md5 checksums.sha
|
||||
checksums ;
|
||||
IN: checksums.hmac.tests
|
||||
|
||||
[
|
||||
"\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
|
||||
] [
|
||||
16 11 <string> "Hi There" md5 hmac-bytes >string ] unit-test
|
||||
|
||||
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
|
||||
[ "Jefe" "what do ya want for nothing?" md5 hmac-bytes >string ] unit-test
|
||||
|
||||
[
|
||||
"V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
|
||||
]
|
||||
[
|
||||
16 HEX: aa <string>
|
||||
50 HEX: dd <repetition> md5 hmac-bytes >string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
|
||||
] [
|
||||
16 11 <string> "Hi There" sha1 hmac-bytes >string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y"
|
||||
] [
|
||||
"Jefe" "what do ya want for nothing?" sha1 hmac-bytes >string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
|
||||
] [
|
||||
16 HEX: aa <string>
|
||||
50 HEX: dd <repetition> sha1 hmac-bytes >string
|
||||
] unit-test
|
||||
|
||||
[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ]
|
||||
[ 20 HEX: b <string> "Hi There" sha-256 hmac-bytes hex-string ] unit-test
|
||||
|
||||
[ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ]
|
||||
[
|
||||
"JefeJefeJefeJefeJefeJefeJefeJefe"
|
||||
"what do ya want for nothing?" sha-256 hmac-bytes hex-string
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays checksums combinators fry io io.binary
|
||||
io.encodings.binary io.files io.streams.byte-array kernel
|
||||
locals math math.vectors memoize sequences ;
|
||||
IN: checksums.hmac
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ;
|
||||
|
||||
: opad ( checksum-state -- seq ) block-size>> HEX: 5c <array> ;
|
||||
|
||||
: ipad ( checksum-state -- seq ) block-size>> HEX: 36 <array> ;
|
||||
|
||||
:: init-K ( K checksum checksum-state -- o i )
|
||||
checksum-state block-size>> K length <
|
||||
[ K checksum checksum-bytes ] [ K ] if
|
||||
checksum-state block-size>> 0 pad-tail
|
||||
[ checksum-state opad seq-bitxor ]
|
||||
[ checksum-state ipad seq-bitxor ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: hmac-stream ( K stream checksum -- value )
|
||||
K checksum dup initialize-checksum-state
|
||||
dup :> checksum-state
|
||||
init-K :> Ki :> Ko
|
||||
checksum-state Ki add-checksum-bytes
|
||||
stream add-checksum-stream get-checksum
|
||||
checksum initialize-checksum-state
|
||||
Ko add-checksum-bytes swap add-checksum-bytes
|
||||
get-checksum ;
|
||||
|
||||
: hmac-file ( K path checksum -- value )
|
||||
[ binary <file-reader> ] dip hmac-stream ;
|
||||
|
||||
: hmac-bytes ( K seq checksum -- value )
|
||||
[ binary <byte-reader> ] dip hmac-stream ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test checksums.interleave checksums.sha ;
|
||||
IN: checksums.interleave.tests
|
||||
|
||||
[
|
||||
B{
|
||||
59 155 253 205 75 163 94 115 208 42 227 92 181 19 60 232
|
||||
119 65 178 131 210 48 241 230 204 216 30 156 4 215 80 84 93
|
||||
206 44 1 18 128 150 153
|
||||
}
|
||||
] [
|
||||
B{
|
||||
102 83 241 12 26 250 181 76 97 200 37 117 168 74 254 48 216
|
||||
170 26 58 150 150 179 24 153 146 191 225 203 127 166 167
|
||||
}
|
||||
sha1 interleaved-checksum
|
||||
] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs checksums grouping kernel locals math sequences ;
|
||||
IN: checksums.interleave
|
||||
|
||||
: seq>2seq ( seq -- seq1 seq2 )
|
||||
#! { abcdefgh } -> { aceg } { bdfh }
|
||||
2 group flip [ { } { } ] [ first2 ] if-empty ;
|
||||
|
||||
: 2seq>seq ( seq1 seq2 -- seq )
|
||||
#! { aceg } { bdfh } -> { abcdefgh }
|
||||
[ zip concat ] keep like ;
|
||||
|
||||
:: interleaved-checksum ( bytes checksum -- seq )
|
||||
bytes [ zero? ] trim-head
|
||||
dup length odd? [ rest-slice ] when
|
||||
seq>2seq [ checksum checksum-bytes ] bi@ 2seq>seq ;
|
||||
|
|
@ -1,4 +1,6 @@
|
|||
USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
|
||||
USING: byte-arrays checksums checksums.md5 io.encodings.binary
|
||||
io.streams.byte-array kernel math namespaces tools.test ;
|
||||
|
||||
|
||||
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
|
|
@ -8,3 +10,24 @@ USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
|
|||
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array md5 checksum-bytes hex-string ] unit-test
|
||||
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<md5-state> "asdf" add-checksum-bytes
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<md5-state> "" add-checksum-bytes
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<md5-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -3,57 +3,53 @@
|
|||
USING: kernel io io.binary io.files io.streams.byte-array math
|
||||
math.functions math.parser namespaces splitting grouping strings
|
||||
sequences byte-arrays locals sequences.private macros fry
|
||||
io.encodings.binary math.bitwise checksums
|
||||
checksums.common checksums.stream combinators ;
|
||||
io.encodings.binary math.bitwise checksums accessors
|
||||
checksums.common checksums.stream combinators combinators.smart
|
||||
specialized-arrays.uint literals ;
|
||||
IN: checksums.md5
|
||||
|
||||
! See http://www.faqs.org/rfcs/rfc1321.html
|
||||
SINGLETON: md5
|
||||
|
||||
INSTANCE: md5 stream-checksum
|
||||
|
||||
TUPLE: md5-state < checksum-state state old-state ;
|
||||
|
||||
: <md5-state> ( -- md5 )
|
||||
md5-state new-checksum-state
|
||||
64 >>block-size
|
||||
uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
|
||||
[ clone >>state ] [ >>old-state ] bi ;
|
||||
|
||||
M: md5 initialize-checksum-state drop <md5-state> ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOLS: a b c d old-a old-b old-c old-d ;
|
||||
: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
|
||||
|
||||
: T ( N -- Y )
|
||||
sin abs 32 2^ * >integer ; foldable
|
||||
: update-md5 ( md5 -- )
|
||||
[ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
|
||||
[ (>>old-state) ] [ (>>state) ] bi ; inline
|
||||
|
||||
: initialize-md5 ( -- )
|
||||
0 bytes-read set
|
||||
HEX: 67452301 dup a set old-a set
|
||||
HEX: efcdab89 dup b set old-b set
|
||||
HEX: 98badcfe dup c set old-c set
|
||||
HEX: 10325476 dup d set old-d set ;
|
||||
CONSTANT: T
|
||||
$[
|
||||
80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as
|
||||
]
|
||||
|
||||
: update-md ( -- )
|
||||
old-a a update-old-new
|
||||
old-b b update-old-new
|
||||
old-c c update-old-new
|
||||
old-d d update-old-new ;
|
||||
|
||||
:: (ABCD) ( x a b c d k s i func -- )
|
||||
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
|
||||
a [
|
||||
b get c get d get func call w+
|
||||
k x nth-unsafe w+
|
||||
i T w+
|
||||
s bitroll-32
|
||||
b get w+
|
||||
] change ; inline
|
||||
|
||||
: F ( X Y Z -- FXYZ )
|
||||
:: F ( X Y Z -- FXYZ )
|
||||
#! F(X,Y,Z) = XY v not(X) Z
|
||||
pick bitnot bitand [ bitand ] [ bitor ] bi* ;
|
||||
X Y bitand X bitnot Z bitand bitor ; inline
|
||||
|
||||
: G ( X Y Z -- GXYZ )
|
||||
:: G ( X Y Z -- GXYZ )
|
||||
#! G(X,Y,Z) = XZ v Y not(Z)
|
||||
dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
|
||||
X Z bitand Y Z bitnot bitand bitor ; inline
|
||||
|
||||
: H ( X Y Z -- HXYZ )
|
||||
#! H(X,Y,Z) = X xor Y xor Z
|
||||
bitxor bitxor ;
|
||||
bitxor bitxor ; inline
|
||||
|
||||
: I ( X Y Z -- IXYZ )
|
||||
:: I ( X Y Z -- IXYZ )
|
||||
#! I(X,Y,Z) = Y xor (X v not(Z))
|
||||
rot swap bitnot bitor bitxor ;
|
||||
Z bitnot X bitor Y bitxor ; inline
|
||||
|
||||
CONSTANT: S11 7
|
||||
CONSTANT: S12 12
|
||||
|
|
@ -72,10 +68,27 @@ CONSTANT: S42 10
|
|||
CONSTANT: S43 15
|
||||
CONSTANT: S44 21
|
||||
|
||||
MACRO: with-md5-round ( ops func -- )
|
||||
'[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ;
|
||||
CONSTANT: a 0
|
||||
CONSTANT: b 1
|
||||
CONSTANT: c 2
|
||||
CONSTANT: d 3
|
||||
|
||||
: (process-md5-block-F) ( block -- )
|
||||
:: (ABCD) ( x state a b c d k s i quot -- )
|
||||
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
|
||||
a state [
|
||||
b state nth-unsafe
|
||||
c state nth-unsafe
|
||||
d state nth-unsafe quot call w+
|
||||
k x nth-unsafe w+
|
||||
i T nth-unsafe w+
|
||||
s bitroll-32
|
||||
b state nth-unsafe w+ 32 bits
|
||||
] change-nth-unsafe ; inline
|
||||
|
||||
MACRO: with-md5-round ( ops quot -- )
|
||||
'[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
|
||||
|
||||
: (process-md5-block-F) ( block state -- )
|
||||
{
|
||||
[ a b c d 0 S11 1 ]
|
||||
[ d a b c 1 S12 2 ]
|
||||
|
|
@ -93,9 +106,9 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ d a b c 13 S12 14 ]
|
||||
[ c d a b 14 S13 15 ]
|
||||
[ b c d a 15 S14 16 ]
|
||||
} [ F ] with-md5-round ;
|
||||
} [ F ] with-md5-round ; inline
|
||||
|
||||
: (process-md5-block-G) ( block -- )
|
||||
: (process-md5-block-G) ( block state -- )
|
||||
{
|
||||
[ a b c d 1 S21 17 ]
|
||||
[ d a b c 6 S22 18 ]
|
||||
|
|
@ -113,9 +126,9 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ d a b c 2 S22 30 ]
|
||||
[ c d a b 7 S23 31 ]
|
||||
[ b c d a 12 S24 32 ]
|
||||
} [ G ] with-md5-round ;
|
||||
} [ G ] with-md5-round ; inline
|
||||
|
||||
: (process-md5-block-H) ( block -- )
|
||||
: (process-md5-block-H) ( block state -- )
|
||||
{
|
||||
[ a b c d 5 S31 33 ]
|
||||
[ d a b c 8 S32 34 ]
|
||||
|
|
@ -133,9 +146,9 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ d a b c 12 S32 46 ]
|
||||
[ c d a b 15 S33 47 ]
|
||||
[ b c d a 2 S34 48 ]
|
||||
} [ H ] with-md5-round ;
|
||||
} [ H ] with-md5-round ; inline
|
||||
|
||||
: (process-md5-block-I) ( block -- )
|
||||
: (process-md5-block-I) ( block state -- )
|
||||
{
|
||||
[ a b c d 0 S41 49 ]
|
||||
[ d a b c 7 S42 50 ]
|
||||
|
|
@ -153,38 +166,33 @@ MACRO: with-md5-round ( ops func -- )
|
|||
[ d a b c 11 S42 62 ]
|
||||
[ c d a b 2 S43 63 ]
|
||||
[ b c d a 9 S44 64 ]
|
||||
} [ I ] with-md5-round ;
|
||||
} [ I ] with-md5-round ; inline
|
||||
|
||||
: (process-md5-block) ( block -- )
|
||||
4 <groups> [ le> ] map {
|
||||
[ (process-md5-block-F) ]
|
||||
[ (process-md5-block-G) ]
|
||||
[ (process-md5-block-H) ]
|
||||
[ (process-md5-block-I) ]
|
||||
} cleave
|
||||
|
||||
update-md ;
|
||||
|
||||
: process-md5-block ( str -- )
|
||||
dup length [ bytes-read [ + ] change ] keep 64 = [
|
||||
(process-md5-block)
|
||||
M: md5-state checksum-block ( block state -- )
|
||||
[
|
||||
[ byte-array>uint-array ] [ state>> ] bi* {
|
||||
[ (process-md5-block-F) ]
|
||||
[ (process-md5-block-G) ]
|
||||
[ (process-md5-block-H) ]
|
||||
[ (process-md5-block-I) ]
|
||||
} 2cleave
|
||||
] [
|
||||
f bytes-read get pad-last-block
|
||||
[ (process-md5-block) ] each
|
||||
] if ;
|
||||
|
||||
: stream>md5 ( -- )
|
||||
64 read [ process-md5-block ] keep
|
||||
length 64 = [ stream>md5 ] when ;
|
||||
nip update-md5
|
||||
] 2bi ;
|
||||
|
||||
: get-md5 ( -- str )
|
||||
[ a b c d ] [ get 4 >le ] map concat >byte-array ;
|
||||
: md5>checksum ( md5 -- bytes ) state>> underlying>> ;
|
||||
|
||||
M: md5-state clone ( md5 -- new-md5 )
|
||||
call-next-method
|
||||
[ clone ] change-state
|
||||
[ clone ] change-old-state ;
|
||||
|
||||
M: md5-state get-checksum ( md5 -- bytes )
|
||||
clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri
|
||||
[ [ checksum-block ] curry each ] [ md5>checksum ] bi ;
|
||||
|
||||
M: md5 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <md5-state> ] dip add-checksum-stream get-checksum ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
SINGLETON: md5
|
||||
|
||||
INSTANCE: md5 stream-checksum
|
||||
|
||||
M: md5 checksum-stream ( stream -- byte-array )
|
||||
drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;
|
||||
|
|
|
|||
|
|
@ -32,6 +32,6 @@ ARTICLE: "checksums.openssl" "OpenSSL checksums"
|
|||
"An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:"
|
||||
{ $example "USING: byte-arrays checksums checksums.openssl ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" }
|
||||
"If we use the Factor implementation, we get the same result, just slightly slower:"
|
||||
{ $example "USING: byte-arrays checksums checksums.sha1 ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
|
||||
{ $example "USING: byte-arrays checksums checksums.sha ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
|
||||
|
||||
ABOUT: "checksums.openssl"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: accessors byte-arrays checksums checksums.openssl
|
||||
combinators.short-circuit kernel system tools.test ;
|
||||
IN: checksums.openssl.tests
|
||||
USING: byte-arrays checksums.openssl checksums tools.test
|
||||
accessors kernel system ;
|
||||
|
||||
[
|
||||
B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 }
|
||||
|
|
@ -22,7 +22,7 @@ accessors kernel system ;
|
|||
"Bad checksum test" >byte-array
|
||||
"no such checksum" <openssl-checksum>
|
||||
checksum-bytes
|
||||
] [ [ unknown-digest? ] [ name>> "no such checksum" = ] bi and ]
|
||||
] [ { [ unknown-digest? ] [ name>> "no such checksum" = ] } 1&& ]
|
||||
must-fail-with
|
||||
|
||||
[ ] [ image openssl-sha1 checksum-file drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,18 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: checksums.sha
|
||||
|
||||
HELP: sha-224
|
||||
{ $class-description "SHA-224 checksum algorithm." } ;
|
||||
|
||||
HELP: sha-256
|
||||
{ $class-description "SHA-256 checksum algorithm." } ;
|
||||
|
||||
ARTICLE: "checksums.sha" "SHA-2 checksum"
|
||||
"The SHA family of checksum algorithms are one-way hashes useful for checksumming data. SHA-1 is considered insecure, while SHA-2 It is generally considered to be pretty strong." $nl
|
||||
"SHA-2 checksums:"
|
||||
{ $subsection sha-224 }
|
||||
{ $subsection sha-256 }
|
||||
"SHA-1 checksum:"
|
||||
{ $subsection sha1 } ;
|
||||
|
||||
ABOUT: "checksums.sha"
|
||||
|
|
@ -1,10 +1,18 @@
|
|||
USING: arrays kernel math namespaces sequences tools.test
|
||||
checksums.sha2 checksums ;
|
||||
IN: checksums.sha2.tests
|
||||
USING: arrays checksums checksums.sha checksums.sha.private
|
||||
io.encodings.binary io.streams.byte-array kernel math
|
||||
namespaces sequences tools.test ;
|
||||
IN: checksums.sha.tests
|
||||
|
||||
: test-checksum ( text identifier -- checksum )
|
||||
checksum-bytes hex-string ;
|
||||
|
||||
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
|
||||
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
|
||||
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
|
||||
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
|
||||
10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
|
||||
|
||||
|
||||
[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
|
||||
[
|
||||
"abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
|
||||
|
|
@ -36,7 +44,27 @@ IN: checksums.sha2.tests
|
|||
] unit-test
|
||||
|
||||
|
||||
|
||||
|
||||
! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
|
||||
! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<sha1-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<sha-256-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
[
|
||||
t
|
||||
] [
|
||||
<sha-224-state> "asdf" binary <byte-reader> add-checksum-stream
|
||||
[ get-checksum ] [ get-checksum ] bi =
|
||||
] unit-test
|
||||
|
||||
|
|
@ -3,16 +3,40 @@
|
|||
USING: kernel splitting grouping math sequences namespaces make
|
||||
io.binary math.bitwise checksums checksums.common
|
||||
sbufs strings combinators.smart math.ranges fry combinators
|
||||
accessors locals ;
|
||||
IN: checksums.sha2
|
||||
accessors locals checksums.stream multiline literals
|
||||
generalizations ;
|
||||
IN: checksums.sha
|
||||
|
||||
SINGLETON: sha1
|
||||
INSTANCE: sha1 stream-checksum
|
||||
|
||||
SINGLETON: sha-224
|
||||
SINGLETON: sha-256
|
||||
|
||||
INSTANCE: sha-224 checksum
|
||||
INSTANCE: sha-256 checksum
|
||||
INSTANCE: sha-224 stream-checksum
|
||||
INSTANCE: sha-256 stream-checksum
|
||||
|
||||
TUPLE: sha2-state K H word-size block-size ;
|
||||
TUPLE: sha1-state < checksum-state K H W word-size ;
|
||||
|
||||
CONSTANT: initial-H-sha1
|
||||
{
|
||||
HEX: 67452301
|
||||
HEX: efcdab89
|
||||
HEX: 98badcfe
|
||||
HEX: 10325476
|
||||
HEX: c3d2e1f0
|
||||
}
|
||||
|
||||
CONSTANT: K-sha1
|
||||
$[
|
||||
20 HEX: 5a827999 <repetition>
|
||||
20 HEX: 6ed9eba1 <repetition>
|
||||
20 HEX: 8f1bbcdc <repetition>
|
||||
20 HEX: ca62c1d6 <repetition>
|
||||
4 { } nappend-as
|
||||
]
|
||||
|
||||
TUPLE: sha2-state < checksum-state K H word-size ;
|
||||
|
||||
TUPLE: sha2-short < sha2-state ;
|
||||
|
||||
|
|
@ -22,6 +46,11 @@ TUPLE: sha-224-state < sha2-short ;
|
|||
|
||||
TUPLE: sha-256-state < sha2-short ;
|
||||
|
||||
M: sha2-state clone
|
||||
call-next-method
|
||||
[ clone ] change-H
|
||||
[ clone ] change-K ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTANT: a 0
|
||||
|
|
@ -116,6 +145,33 @@ CONSTANT: K-384
|
|||
|
||||
ALIAS: K-512 K-384
|
||||
|
||||
: <sha1-state> ( -- sha1-state )
|
||||
sha1-state new-checksum-state
|
||||
64 >>block-size
|
||||
K-sha1 >>K
|
||||
initial-H-sha1 >>H
|
||||
4 >>word-size ;
|
||||
|
||||
: <sha-224-state> ( -- sha2-state )
|
||||
sha-224-state new-checksum-state
|
||||
64 >>block-size
|
||||
K-256 >>K
|
||||
initial-H-224 >>H
|
||||
4 >>word-size ;
|
||||
|
||||
: <sha-256-state> ( -- sha2-state )
|
||||
sha-256-state new-checksum-state
|
||||
64 >>block-size
|
||||
K-256 >>K
|
||||
initial-H-256 >>H
|
||||
4 >>word-size ;
|
||||
|
||||
M: sha1 initialize-checksum-state drop <sha1-state> ;
|
||||
|
||||
M: sha-224 initialize-checksum-state drop <sha-224-state> ;
|
||||
|
||||
M: sha-256 initialize-checksum-state drop <sha-256-state> ;
|
||||
|
||||
: s0-256 ( x -- x' )
|
||||
[
|
||||
[ -7 bitroll-32 ]
|
||||
|
|
@ -172,7 +228,7 @@ ALIAS: K-512 K-384
|
|||
[ -41 bitroll-64 ] tri
|
||||
] [ bitxor ] reduce-outputs ; inline
|
||||
|
||||
: process-M-256 ( n seq -- )
|
||||
: prepare-M-256 ( n seq -- )
|
||||
{
|
||||
[ [ 16 - ] dip nth ]
|
||||
[ [ 15 - ] dip nth s0-256 ]
|
||||
|
|
@ -181,7 +237,7 @@ ALIAS: K-512 K-384
|
|||
[ ]
|
||||
} 2cleave set-nth ; inline
|
||||
|
||||
: process-M-512 ( n seq -- )
|
||||
: prepare-M-512 ( n seq -- )
|
||||
{
|
||||
[ [ 16 - ] dip nth ]
|
||||
[ [ 15 - ] dip nth s0-512 ]
|
||||
|
|
@ -201,26 +257,6 @@ ALIAS: K-512 K-384
|
|||
|
||||
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
|
||||
|
||||
M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
|
||||
drop
|
||||
dup [
|
||||
HEX: 80 ,
|
||||
length
|
||||
[ 64 mod calculate-pad-length 0 <string> % ]
|
||||
[ 3 shift 8 >be % ] bi
|
||||
] "" make append ;
|
||||
|
||||
M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
|
||||
drop dup [
|
||||
HEX: 80 ,
|
||||
length
|
||||
[ 128 mod calculate-pad-length-long 0 <string> % ]
|
||||
[ 3 shift 8 >be % ] bi
|
||||
] "" make append ;
|
||||
|
||||
: seq>byte-array ( seq n -- string )
|
||||
'[ _ >be ] map B{ } join ;
|
||||
|
||||
:: T1-256 ( n M H sha2 -- T1 )
|
||||
n M nth
|
||||
n sha2 K>> nth +
|
||||
|
|
@ -257,7 +293,7 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
|
|||
[ word-size>> <sliced-groups> [ be> ] map ]
|
||||
[
|
||||
block-size>> [ 0 pad-tail 16 ] keep [a,b) over
|
||||
'[ _ process-M-256 ] each
|
||||
'[ _ prepare-M-256 ] each
|
||||
] bi ; inline
|
||||
|
||||
:: process-chunk ( M block-size cloned-H sha2 -- )
|
||||
|
|
@ -266,41 +302,110 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
|
|||
cloned-H T2-256
|
||||
cloned-H update-H
|
||||
] each
|
||||
cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
|
||||
sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline
|
||||
|
||||
: sha2-steps ( sliced-groups state -- )
|
||||
'[
|
||||
_
|
||||
[ prepare-message-schedule ]
|
||||
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
|
||||
] each ;
|
||||
M: sha2-short checksum-block
|
||||
[ prepare-message-schedule ]
|
||||
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
|
||||
|
||||
: byte-array>sha2 ( bytes state -- )
|
||||
[ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
|
||||
[ sha2-steps ] bi ;
|
||||
: seq>byte-array ( seq n -- string )
|
||||
'[ _ >be ] map B{ } join ;
|
||||
|
||||
: <sha-224-state> ( -- sha2-state )
|
||||
sha-224-state new
|
||||
K-256 >>K
|
||||
initial-H-224 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
: sha1>checksum ( sha2 -- bytes )
|
||||
H>> 4 seq>byte-array ;
|
||||
|
||||
: <sha-256-state> ( -- sha2-state )
|
||||
sha-256-state new
|
||||
K-256 >>K
|
||||
initial-H-256 >>H
|
||||
4 >>word-size
|
||||
64 >>block-size ;
|
||||
: sha-224>checksum ( sha2 -- bytes )
|
||||
H>> 7 head 4 seq>byte-array ;
|
||||
|
||||
: sha-256>checksum ( sha2 -- bytes )
|
||||
H>> 4 seq>byte-array ;
|
||||
|
||||
: pad-last-short-block ( state -- )
|
||||
[ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri
|
||||
[ checksum-block ] curry each ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: sha-224 checksum-bytes
|
||||
drop <sha-224-state>
|
||||
[ byte-array>sha2 ]
|
||||
[ H>> 7 head 4 seq>byte-array ] bi ;
|
||||
M: sha-224-state get-checksum
|
||||
clone
|
||||
[ pad-last-short-block ] [ sha-224>checksum ] bi ;
|
||||
|
||||
M: sha-256 checksum-bytes
|
||||
drop <sha-256-state>
|
||||
[ byte-array>sha2 ]
|
||||
[ H>> 4 seq>byte-array ] bi ;
|
||||
M: sha-256-state get-checksum
|
||||
clone
|
||||
[ pad-last-short-block ] [ sha-256>checksum ] bi ;
|
||||
|
||||
M: sha-224 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <sha-224-state> ] dip add-checksum-stream get-checksum ;
|
||||
|
||||
M: sha-256 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <sha-256-state> ] dip add-checksum-stream get-checksum ;
|
||||
|
||||
|
||||
|
||||
: sha1-W ( t seq -- )
|
||||
{
|
||||
[ [ 3 - ] dip nth ]
|
||||
[ [ 8 - ] dip nth bitxor ]
|
||||
[ [ 14 - ] dip nth bitxor ]
|
||||
[ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
|
||||
[ ]
|
||||
} 2cleave set-nth ;
|
||||
|
||||
: prepare-sha1-message-schedule ( seq -- w-seq )
|
||||
4 <sliced-groups> [ be> ] map
|
||||
80 0 pad-tail 16 80 [a,b) over
|
||||
'[ _ sha1-W ] each ; inline
|
||||
|
||||
: sha1-f ( B C D n -- f_nbcd )
|
||||
20 /i
|
||||
{
|
||||
{ 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
|
||||
{ 1 [ bitxor bitxor ] }
|
||||
{ 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
|
||||
{ 3 [ bitxor bitxor ] }
|
||||
} case ;
|
||||
|
||||
:: inner-loop ( n H W K -- temp )
|
||||
a H nth :> A
|
||||
b H nth :> B
|
||||
c H nth :> C
|
||||
d H nth :> D
|
||||
e H nth :> E
|
||||
[
|
||||
A 5 bitroll-32
|
||||
|
||||
B C D n sha1-f
|
||||
|
||||
E
|
||||
|
||||
n K nth
|
||||
|
||||
n W nth
|
||||
] sum-outputs 32 bits ;
|
||||
|
||||
:: process-sha1-chunk ( bytes H W K state -- )
|
||||
80 [
|
||||
H W K inner-loop
|
||||
d H nth e H set-nth
|
||||
c H nth d H set-nth
|
||||
b H nth 30 bitroll-32 c H set-nth
|
||||
a H nth b H set-nth
|
||||
a H set-nth
|
||||
] each
|
||||
state [ H [ w+ ] 2map ] change-H drop ; inline
|
||||
|
||||
M:: sha1-state checksum-block ( bytes state -- )
|
||||
bytes prepare-sha1-message-schedule state (>>W)
|
||||
|
||||
bytes
|
||||
state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ;
|
||||
|
||||
M: sha1-state get-checksum
|
||||
clone
|
||||
[ pad-last-short-block ] [ sha-256>checksum ] bi ;
|
||||
|
||||
M: sha1 checksum-stream ( stream checksum -- byte-array )
|
||||
drop
|
||||
[ <sha1-state> ] dip add-checksum-stream get-checksum ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
SHA checksum algorithms
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: checksums.sha1
|
||||
|
||||
HELP: sha1
|
||||
{ $class-description "SHA1 checksum algorithm." } ;
|
||||
|
||||
ARTICLE: "checksums.sha1" "SHA1 checksum"
|
||||
"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")."
|
||||
{ $subsection sha1 } ;
|
||||
|
||||
ABOUT: "checksums.sha1"
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
USING: arrays kernel math namespaces sequences tools.test checksums checksums.sha1 ;
|
||||
|
||||
[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
|
||||
[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
|
||||
! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
|
||||
[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
|
||||
10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
|
||||
|
||||
[
|
||||
";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
|
||||
] [
|
||||
"\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
|
||||
sha1-interleave
|
||||
] unit-test
|
||||
|
|
@ -1,134 +0,0 @@
|
|||
! Copyright (C) 2006, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators kernel io io.encodings.binary io.files
|
||||
io.streams.byte-array math.vectors strings namespaces
|
||||
make math parser sequences assocs grouping vectors io.binary
|
||||
hashtables math.bitwise checksums checksums.common
|
||||
checksums.stream ;
|
||||
IN: checksums.sha1
|
||||
|
||||
! Implemented according to RFC 3174.
|
||||
|
||||
SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
|
||||
|
||||
: get-wth ( n -- wth ) w get nth ; inline
|
||||
: shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline
|
||||
|
||||
: initialize-sha1 ( -- )
|
||||
0 bytes-read set
|
||||
HEX: 67452301 dup h0 set A set
|
||||
HEX: efcdab89 dup h1 set B set
|
||||
HEX: 98badcfe dup h2 set C set
|
||||
HEX: 10325476 dup h3 set D set
|
||||
HEX: c3d2e1f0 dup h4 set E set
|
||||
[
|
||||
20 HEX: 5a827999 <array> %
|
||||
20 HEX: 6ed9eba1 <array> %
|
||||
20 HEX: 8f1bbcdc <array> %
|
||||
20 HEX: ca62c1d6 <array> %
|
||||
] { } make K set ;
|
||||
|
||||
! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
|
||||
: sha1-W ( t -- W_t )
|
||||
dup 3 - get-wth
|
||||
over 8 - get-wth bitxor
|
||||
over 14 - get-wth bitxor
|
||||
swap 16 - get-wth bitxor 1 bitroll-32 ;
|
||||
|
||||
! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D) ( 0 <= t <= 19)
|
||||
! f(t;B,C,D) = B XOR C XOR D (20 <= t <= 39)
|
||||
! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59)
|
||||
! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79)
|
||||
: sha1-f ( B C D t -- f_tbcd )
|
||||
20 /i
|
||||
{
|
||||
{ 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
|
||||
{ 1 [ bitxor bitxor ] }
|
||||
{ 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
|
||||
{ 3 [ bitxor bitxor ] }
|
||||
} case ;
|
||||
|
||||
: nth-int-be ( string n -- int )
|
||||
4 * dup 4 + rot <slice> be> ; inline
|
||||
|
||||
: make-w ( str -- )
|
||||
#! compute w, steps a-b of RFC 3174, section 6.1
|
||||
16 [ nth-int-be w get push ] with each
|
||||
16 80 dup <slice> [ sha1-W w get push ] each ;
|
||||
|
||||
: init-letters ( -- )
|
||||
! step c of RFC 3174, section 6.1
|
||||
h0 get A set
|
||||
h1 get B set
|
||||
h2 get C set
|
||||
h3 get D set
|
||||
h4 get E set ;
|
||||
|
||||
: inner-loop ( n -- temp )
|
||||
! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
|
||||
[
|
||||
[ B get C get D get ] keep sha1-f ,
|
||||
dup get-wth ,
|
||||
K get nth ,
|
||||
A get 5 bitroll-32 ,
|
||||
E get ,
|
||||
] { } make sum 32 bits ; inline
|
||||
|
||||
: set-vars ( temp -- )
|
||||
! E = D; D = C; C = S^30(B); B = A; A = TEMP;
|
||||
D get E set
|
||||
C get D set
|
||||
B get 30 bitroll-32 C set
|
||||
A get B set
|
||||
A set ;
|
||||
|
||||
: calculate-letters ( -- )
|
||||
! step d of RFC 3174, section 6.1
|
||||
80 [ inner-loop set-vars ] each ;
|
||||
|
||||
: update-hs ( -- )
|
||||
! step e of RFC 3174, section 6.1
|
||||
A h0 update-old-new
|
||||
B h1 update-old-new
|
||||
C h2 update-old-new
|
||||
D h3 update-old-new
|
||||
E h4 update-old-new ;
|
||||
|
||||
: (process-sha1-block) ( str -- )
|
||||
80 <vector> w set make-w init-letters calculate-letters update-hs ;
|
||||
|
||||
: process-sha1-block ( str -- )
|
||||
dup length [ bytes-read [ + ] change ] keep 64 = [
|
||||
(process-sha1-block)
|
||||
] [
|
||||
t bytes-read get pad-last-block
|
||||
[ (process-sha1-block) ] each
|
||||
] if ;
|
||||
|
||||
: stream>sha1 ( -- )
|
||||
64 read [ process-sha1-block ] keep
|
||||
length 64 = [ stream>sha1 ] when ;
|
||||
|
||||
: get-sha1 ( -- str )
|
||||
[ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
|
||||
|
||||
SINGLETON: sha1
|
||||
|
||||
INSTANCE: sha1 stream-checksum
|
||||
|
||||
M: sha1 checksum-stream ( stream -- sha1 )
|
||||
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
|
||||
|
||||
: seq>2seq ( seq -- seq1 seq2 )
|
||||
#! { abcdefgh } -> { aceg } { bdfh }
|
||||
2 group flip [ { } { } ] [ first2 ] if-empty ;
|
||||
|
||||
: 2seq>seq ( seq1 seq2 -- seq )
|
||||
#! { aceg } { bdfh } -> { abcdefgh }
|
||||
[ zip concat ] keep like ;
|
||||
|
||||
: sha1-interleave ( string -- seq )
|
||||
[ zero? ] trim-head
|
||||
dup length odd? [ rest ] when
|
||||
seq>2seq [ sha1 checksum-bytes ] bi@
|
||||
2seq>seq ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
SHA1 checksum algorithm
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
USING: help.markup help.syntax ;
|
||||
IN: checksums.sha2
|
||||
|
||||
HELP: sha-256
|
||||
{ $class-description "SHA-256 checksum algorithm." } ;
|
||||
|
||||
ARTICLE: "checksums.sha2" "SHA2 checksum"
|
||||
"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong."
|
||||
{ $subsection sha-256 } ;
|
||||
|
||||
ABOUT: "checksums.sha2"
|
||||
|
|
@ -1 +0,0 @@
|
|||
SHA2 checksum algorithm
|
||||
|
|
@ -75,18 +75,20 @@ CONSTANT: length-table
|
|||
19 23 27 31
|
||||
35 43 51 59
|
||||
67 83 99 115
|
||||
131 163 195 227
|
||||
131 163 195 227 258
|
||||
}
|
||||
|
||||
CONSTANT: dist-table
|
||||
{ 1 2 3 4
|
||||
5 7 9 13
|
||||
17 25 33 49
|
||||
65 97 129 193
|
||||
257 385 513 769
|
||||
1025 1537 2049 3073
|
||||
4097 6145 8193 12289
|
||||
16385 24577 }
|
||||
{
|
||||
1 2 3 4
|
||||
5 7 9 13
|
||||
17 25 33 49
|
||||
65 97 129 193
|
||||
257 385 513 769
|
||||
1025 1537 2049 3073
|
||||
4097 6145 8193 12289
|
||||
16385 24577
|
||||
}
|
||||
|
||||
: nth* ( n seq -- elt )
|
||||
[ length 1- swap - ] [ nth ] bi ;
|
||||
|
|
@ -156,7 +158,7 @@ CONSTANT: dist-table
|
|||
[ 1 bitstream bs:read 0 = ]
|
||||
[
|
||||
bitstream
|
||||
2 bitstream bs:read ! B
|
||||
2 bitstream bs:read
|
||||
{
|
||||
{ 0 [ inflate-raw ] }
|
||||
{ 1 [ inflate-static ] }
|
||||
|
|
@ -200,10 +202,11 @@ PRIVATE>
|
|||
: reverse-png-filter ( lines -- filtered )
|
||||
dup first [ 0 ] replicate prefix
|
||||
[ { 0 0 } prepend ] map
|
||||
2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ;
|
||||
2 clump [
|
||||
first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
|
||||
] map concat ;
|
||||
|
||||
: zlib-inflate ( bytes -- bytes )
|
||||
bs:<lsb0-bit-reader>
|
||||
[ check-zlib-header ]
|
||||
[ inflate-loop ] bi
|
||||
[ check-zlib-header ] [ inflate-loop ] bi
|
||||
inflate-lz77 ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays kernel math namespaces make sequences
|
||||
system layouts alien alien.c-types alien.accessors alien.structs
|
||||
slots splitting assocs combinators make locals cpu.x86.assembler
|
||||
slots splitting assocs combinators locals cpu.x86.assembler
|
||||
cpu.x86 cpu.architecture compiler.constants
|
||||
compiler.codegen compiler.codegen.fixup
|
||||
compiler.cfg.instructions compiler.cfg.builder
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: assocs classes help.markup help.syntax kernel
|
||||
quotations strings words words.symbol furnace.auth.providers.db
|
||||
checksums.sha2 furnace.auth.providers math byte-arrays
|
||||
checksums.sha furnace.auth.providers math byte-arrays
|
||||
http multiline ;
|
||||
IN: furnace.auth
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors assocs namespaces kernel sequences sets
|
||||
destructors combinators fry logging
|
||||
io.encodings.utf8 io.encodings.string io.binary random
|
||||
checksums checksums.sha2 urls
|
||||
checksums checksums.sha urls
|
||||
html.forms
|
||||
http.server
|
||||
http.server.filters
|
||||
|
|
|
|||
|
|
@ -17,9 +17,9 @@ CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp"
|
|||
CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp"
|
||||
CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
|
||||
|
||||
{
|
||||
$ test-bitmap8
|
||||
$ test-bitmap24
|
||||
${
|
||||
test-bitmap8
|
||||
test-bitmap24
|
||||
"vocab:ui/render/test/reference.bmp"
|
||||
} [ [ ] swap [ load-image drop ] curry unit-test ] each
|
||||
|
||||
|
|
@ -34,11 +34,11 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
|
|||
[
|
||||
t
|
||||
] [
|
||||
{
|
||||
$ test-40
|
||||
$ test-41
|
||||
$ test-42
|
||||
$ test-43
|
||||
$ test-bitmap24
|
||||
${
|
||||
test-40
|
||||
test-41
|
||||
test-42
|
||||
test-43
|
||||
test-bitmap24
|
||||
} [ test-bitmap-save ] all?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -65,14 +65,42 @@ ERROR: bad-checksum ;
|
|||
: zlib-data ( png-image -- bytes )
|
||||
chunks>> [ type>> "IDAT" = ] find nip data>> ;
|
||||
|
||||
: decode-png ( image -- image )
|
||||
ERROR: unknown-color-type n ;
|
||||
ERROR: unimplemented-color-type image ;
|
||||
|
||||
: inflate-data ( image -- bytes )
|
||||
zlib-data zlib-inflate ;
|
||||
|
||||
: decode-greyscale ( image -- image )
|
||||
unimplemented-color-type ;
|
||||
|
||||
: decode-truecolor ( image -- image )
|
||||
{
|
||||
[ zlib-data zlib-inflate ]
|
||||
[ inflate-data ]
|
||||
[ dim>> first 3 * 1 + group reverse-png-filter ]
|
||||
[ swap >byte-array >>bitmap drop ]
|
||||
[ RGB >>component-order drop ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
||||
: decode-indexed-color ( image -- image )
|
||||
unimplemented-color-type ;
|
||||
|
||||
: decode-greyscale-alpha ( image -- image )
|
||||
unimplemented-color-type ;
|
||||
|
||||
: decode-truecolor-alpha ( image -- image )
|
||||
unimplemented-color-type ;
|
||||
|
||||
: decode-png ( image -- image )
|
||||
dup color-type>> {
|
||||
{ 0 [ decode-greyscale ] }
|
||||
{ 2 [ decode-truecolor ] }
|
||||
{ 3 [ decode-indexed-color ] }
|
||||
{ 4 [ decode-greyscale-alpha ] }
|
||||
{ 6 [ decode-truecolor-alpha ] }
|
||||
[ unknown-color-type ]
|
||||
} case ;
|
||||
|
||||
: load-png ( path -- image )
|
||||
[ binary <file-reader> ] [ file-info size>> ] bi
|
||||
|
|
|
|||
|
|
@ -2,9 +2,9 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays destructors io io.backend
|
||||
io.buffers io.files io.ports io.binary io.timeouts system
|
||||
windows.errors strings kernel math namespaces sequences
|
||||
windows.errors windows.kernel32 windows.shell32 windows.types
|
||||
windows.winsock splitting continuations math.bitwise accessors ;
|
||||
strings kernel math namespaces sequences windows.errors
|
||||
windows.kernel32 windows.shell32 windows.types windows.winsock
|
||||
splitting continuations math.bitwise accessors ;
|
||||
IN: io.backend.windows
|
||||
|
||||
: set-inherit ( handle ? -- )
|
||||
|
|
|
|||
|
|
@ -2,26 +2,26 @@ USING: help.markup help.syntax debugger ;
|
|||
IN: math.statistics
|
||||
|
||||
HELP: geometric-mean
|
||||
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
|
||||
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
|
||||
{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
|
||||
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
|
||||
{ $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
|
||||
|
||||
HELP: harmonic-mean
|
||||
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
|
||||
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
|
||||
{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
|
||||
{ $notes "Positive reals only." }
|
||||
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } }
|
||||
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
|
||||
|
||||
HELP: mean
|
||||
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
|
||||
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
|
||||
{ $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." }
|
||||
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } }
|
||||
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
|
||||
|
||||
HELP: median
|
||||
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
|
||||
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
|
||||
{ $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." }
|
||||
{ $examples
|
||||
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" }
|
||||
|
|
@ -29,7 +29,7 @@ HELP: median
|
|||
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
|
||||
|
||||
HELP: range
|
||||
{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
|
||||
{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
|
||||
{ $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." }
|
||||
{ $examples
|
||||
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" }
|
||||
|
|
|
|||
|
|
@ -13,6 +13,24 @@ IN: math.statistics.tests
|
|||
[ 2 ] [ { 1 2 3 } median ] unit-test
|
||||
[ 5/2 ] [ { 1 2 3 4 } median ] unit-test
|
||||
|
||||
[ { } median ] must-fail
|
||||
[ { } upper-median ] must-fail
|
||||
[ { } lower-median ] must-fail
|
||||
|
||||
[ 2 ] [ { 1 2 3 4 } lower-median ] unit-test
|
||||
[ 3 ] [ { 1 2 3 4 } upper-median ] unit-test
|
||||
[ 3 ] [ { 1 2 3 4 5 } lower-median ] unit-test
|
||||
[ 3 ] [ { 1 2 3 4 5 } upper-median ] unit-test
|
||||
|
||||
|
||||
[ 1 ] [ { 1 } lower-median ] unit-test
|
||||
[ 1 ] [ { 1 } upper-median ] unit-test
|
||||
[ 1 ] [ { 1 } median ] unit-test
|
||||
|
||||
[ 1 ] [ { 1 2 } lower-median ] unit-test
|
||||
[ 2 ] [ { 1 2 } upper-median ] unit-test
|
||||
[ 3/2 ] [ { 1 2 } median ] unit-test
|
||||
|
||||
[ 1 ] [ { 1 2 3 } var ] unit-test
|
||||
[ 1.0 ] [ { 1 2 3 } std ] unit-test
|
||||
[ t ] [ { 1 2 3 4 } ste 0.6454972243679028 - .0001 < ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,30 +1,66 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Michael Judge.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators kernel math math.analysis
|
||||
math.functions math.order sequences sorting ;
|
||||
math.functions math.order sequences sorting locals
|
||||
sequences.private ;
|
||||
IN: math.statistics
|
||||
|
||||
: mean ( seq -- n )
|
||||
: mean ( seq -- x )
|
||||
[ sum ] [ length ] bi / ;
|
||||
|
||||
: geometric-mean ( seq -- n )
|
||||
: geometric-mean ( seq -- x )
|
||||
[ length ] [ product ] bi nth-root ;
|
||||
|
||||
: harmonic-mean ( seq -- n )
|
||||
: harmonic-mean ( seq -- x )
|
||||
[ recip ] sigma recip ;
|
||||
|
||||
: median ( seq -- n )
|
||||
natural-sort dup length even? [
|
||||
[ midpoint@ dup 1 - 2array ] keep nths mean
|
||||
] [
|
||||
[ midpoint@ ] keep nth
|
||||
] if ;
|
||||
:: kth-smallest ( seq k -- elt )
|
||||
#! Wirth's method, Algorithm's + Data structues = Programs p. 84
|
||||
#! The algorithm modifiers seq, so we clone it
|
||||
seq clone :> seq
|
||||
0 :> i!
|
||||
0 :> j!
|
||||
0 :> l!
|
||||
0 :> x!
|
||||
seq length 1 - :> m!
|
||||
[ l m < ]
|
||||
[
|
||||
k seq nth x!
|
||||
l i!
|
||||
m j!
|
||||
[ i j <= ]
|
||||
[
|
||||
[ i seq nth-unsafe x < ] [ i 1 + i! ] while
|
||||
[ x j seq nth-unsafe < ] [ j 1 - j! ] while
|
||||
i j <= [
|
||||
i j seq exchange
|
||||
i 1 + i!
|
||||
j 1 - j!
|
||||
] when
|
||||
] do while
|
||||
|
||||
j k < [ i l! ] when
|
||||
k i < [ j m! ] when
|
||||
] while
|
||||
k seq nth ; inline
|
||||
|
||||
: lower-median ( seq -- elt )
|
||||
dup dup length odd? [ midpoint@ ] [ midpoint@ 1 - ] if kth-smallest ;
|
||||
|
||||
: upper-median ( seq -- elt )
|
||||
dup midpoint@ kth-smallest ;
|
||||
|
||||
: medians ( seq -- lower upper )
|
||||
[ lower-median ] [ upper-median ] bi ;
|
||||
|
||||
: median ( seq -- x )
|
||||
dup length odd? [ lower-median ] [ medians + 2 / ] if ;
|
||||
|
||||
: minmax ( seq -- min max )
|
||||
#! find the min and max of a seq in one pass
|
||||
[ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ;
|
||||
|
||||
: range ( seq -- n )
|
||||
: range ( seq -- x )
|
||||
minmax swap - ;
|
||||
|
||||
: var ( seq -- x )
|
||||
|
|
@ -32,15 +68,13 @@ IN: math.statistics
|
|||
dup length 1 <= [
|
||||
drop 0
|
||||
] [
|
||||
[ [ mean ] keep [ - sq ] with sigma ] keep
|
||||
length 1 - /
|
||||
[ [ mean ] keep [ - sq ] with sigma ]
|
||||
[ length 1 - ] bi /
|
||||
] if ;
|
||||
|
||||
: std ( seq -- x )
|
||||
var sqrt ;
|
||||
: std ( seq -- x ) var sqrt ;
|
||||
|
||||
: ste ( seq -- x )
|
||||
[ std ] [ length ] bi sqrt / ;
|
||||
: ste ( seq -- x ) [ std ] [ length ] bi sqrt / ;
|
||||
|
||||
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
|
||||
! finds sigma((xi-mean(x))(yi-mean(y))
|
||||
|
|
@ -64,4 +98,3 @@ IN: math.statistics
|
|||
[ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy
|
||||
swap / * ! stack is mean(x) mean(y) beta
|
||||
[ swapd * - ] keep ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.files io.files.temp io words alien kernel math.parser
|
||||
alien.syntax io.launcher system assocs arrays sequences
|
||||
alien.syntax io.launcher assocs arrays sequences
|
||||
namespaces make system math io.encodings.ascii
|
||||
accessors tools.disassembler ;
|
||||
IN: tools.disassembler.gdb
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
! Copyright (C) 2008 John Benediktsson
|
||||
! See http://factorcode.org/license.txt for BSD license
|
||||
|
||||
USING: byte-arrays checksums checksums.md5 checksums.sha1
|
||||
USING: byte-arrays checksums checksums.md5 checksums.sha
|
||||
kernel math math.parser math.ranges random unicode.case
|
||||
sequences strings system io.binary ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays debugger generic hashtables io assocs kernel.private
|
||||
kernel math memory namespaces make parser prettyprint sequences
|
||||
vectors words system splitting init io.files vocabs vocabs.loader
|
||||
debugger continuations ;
|
||||
USING: arrays assocs continuations debugger generic hashtables
|
||||
init io io.files kernel kernel.private make math memory
|
||||
namespaces parser prettyprint sequences splitting system
|
||||
vectors vocabs vocabs.loader words ;
|
||||
QUALIFIED: bootstrap.image.private
|
||||
IN: bootstrap.stage1
|
||||
|
||||
|
|
|
|||
|
|
@ -47,8 +47,7 @@ $nl
|
|||
"Checksum implementations:"
|
||||
{ $subsection "checksums.crc32" }
|
||||
{ $vocab-subsection "MD5 checksum" "checksums.md5" }
|
||||
{ $vocab-subsection "SHA1 checksum" "checksums.sha1" }
|
||||
{ $vocab-subsection "SHA2 checksum" "checksums.sha2" }
|
||||
{ $vocab-subsection "SHA checksums" "checksums.sha" }
|
||||
{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" }
|
||||
{ $vocab-subsection "OpenSSL checksums" "checksums.openssl" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,48 @@
|
|||
! Copyright (c) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences math.parser io io.backend io.files
|
||||
kernel ;
|
||||
USING: accessors io io.backend io.files kernel math math.parser
|
||||
sequences byte-arrays byte-vectors quotations ;
|
||||
IN: checksums
|
||||
|
||||
MIXIN: checksum
|
||||
|
||||
TUPLE: checksum-state
|
||||
{ bytes-read integer } { block-size integer } { bytes byte-vector } ;
|
||||
|
||||
: new-checksum-state ( class -- checksum-state )
|
||||
new
|
||||
BV{ } clone >>bytes ; inline
|
||||
|
||||
M: checksum-state clone
|
||||
call-next-method
|
||||
[ clone ] change-bytes ;
|
||||
|
||||
GENERIC: initialize-checksum-state ( class -- checksum-state )
|
||||
|
||||
GENERIC: checksum-block ( bytes checksum -- )
|
||||
|
||||
GENERIC: get-checksum ( checksum -- value )
|
||||
|
||||
: add-checksum-bytes ( checksum-state data -- checksum-state )
|
||||
over bytes>> [ push-all ] keep
|
||||
[ dup length pick block-size>> >= ]
|
||||
[
|
||||
64 cut-slice [ >byte-array ] dip [
|
||||
over [ checksum-block ]
|
||||
[ [ 64 + ] change-bytes-read drop ] bi
|
||||
] dip
|
||||
] while
|
||||
>byte-vector
|
||||
[ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ;
|
||||
|
||||
: add-checksum-stream ( checksum-state stream -- checksum-state )
|
||||
[
|
||||
[ [ swap add-checksum-bytes drop ] curry each-block ] keep
|
||||
] with-input-stream ;
|
||||
|
||||
: add-checksum-file ( checksum-state path -- checksum-state )
|
||||
normalize-path (file-reader) add-checksum-stream ;
|
||||
|
||||
GENERIC: checksum-bytes ( bytes checksum -- value )
|
||||
|
||||
GENERIC: checksum-stream ( stream checksum -- value )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: generic help.markup help.syntax kernel kernel.private
|
||||
namespaces sequences words arrays layouts help effects math
|
||||
layouts classes.private classes compiler.units ;
|
||||
classes.private classes compiler.units ;
|
||||
IN: classes.predicate
|
||||
|
||||
ARTICLE: "predicates" "Predicate classes"
|
||||
|
|
|
|||
|
|
@ -88,6 +88,9 @@ M: sequence set-nth bounds-check set-nth-unsafe ;
|
|||
M: sequence nth-unsafe nth ;
|
||||
M: sequence set-nth-unsafe set-nth ;
|
||||
|
||||
: change-nth-unsafe ( i seq quot -- )
|
||||
[ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline
|
||||
|
||||
! The f object supports the sequence protocol trivially
|
||||
M: f length drop 0 ;
|
||||
M: f nth-unsafe nip ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: checksums checksums.sha1 sequences byte-arrays kernel ;
|
||||
USING: checksums checksums.sha sequences byte-arrays kernel ;
|
||||
IN: benchmark.sha1
|
||||
|
||||
: sha1-file ( -- )
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -1,38 +0,0 @@
|
|||
USING: kernel io strings byte-arrays sequences namespaces math
|
||||
parser crypto.hmac tools.test ;
|
||||
IN: crypto.hmac.tests
|
||||
|
||||
[
|
||||
"\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
|
||||
] [
|
||||
16 11 <string> "Hi There" sequence>md5-hmac >string ] unit-test
|
||||
|
||||
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
|
||||
[ "Jefe" "what do ya want for nothing?" sequence>md5-hmac >string ] unit-test
|
||||
|
||||
[
|
||||
"V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
|
||||
]
|
||||
[
|
||||
16 HEX: aa <string>
|
||||
50 HEX: dd <repetition> sequence>md5-hmac >string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
|
||||
] [
|
||||
16 11 <string> "Hi There" sequence>sha1-hmac >string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y"
|
||||
] [
|
||||
"Jefe" "what do ya want for nothing?" sequence>sha1-hmac >string
|
||||
] unit-test
|
||||
|
||||
[
|
||||
"\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
|
||||
] [
|
||||
16 HEX: aa <string>
|
||||
50 HEX: dd <repetition> sequence>sha1-hmac >string
|
||||
] unit-test
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators checksums checksums.md5
|
||||
checksums.sha1 checksums.md5.private io io.binary io.files
|
||||
io.streams.byte-array kernel math math.vectors memoize sequences
|
||||
io.encodings.binary ;
|
||||
IN: crypto.hmac
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: sha1-hmac ( Ko Ki -- hmac )
|
||||
initialize-sha1 process-sha1-block
|
||||
stream>sha1 get-sha1
|
||||
initialize-sha1
|
||||
[ process-sha1-block ]
|
||||
[ process-sha1-block ] bi* get-sha1 ;
|
||||
|
||||
: md5-hmac ( Ko Ki -- hmac )
|
||||
initialize-md5 process-md5-block
|
||||
stream>md5 get-md5
|
||||
initialize-md5
|
||||
[ process-md5-block ]
|
||||
[ process-md5-block ] bi* get-md5 ;
|
||||
|
||||
: seq-bitxor ( seq seq -- seq )
|
||||
[ bitxor ] 2map ;
|
||||
|
||||
MEMO: ipad ( -- seq ) 64 HEX: 36 <array> ;
|
||||
|
||||
MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
|
||||
|
||||
: init-hmac ( K -- o i )
|
||||
64 0 pad-tail
|
||||
[ opad seq-bitxor ]
|
||||
[ ipad seq-bitxor ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: stream>sha1-hmac ( K stream -- hmac )
|
||||
[ init-hmac sha1-hmac ] with-input-stream ;
|
||||
|
||||
: file>sha1-hmac ( K path -- hmac )
|
||||
binary <file-reader> stream>sha1-hmac ;
|
||||
|
||||
: sequence>sha1-hmac ( K sequence -- hmac )
|
||||
binary <byte-reader> stream>sha1-hmac ;
|
||||
|
||||
: stream>md5-hmac ( K stream -- hmac )
|
||||
[ init-hmac md5-hmac ] with-input-stream ;
|
||||
|
||||
: file>md5-hmac ( K path -- hmac )
|
||||
binary <file-reader> stream>md5-hmac ;
|
||||
|
||||
: sequence>md5-hmac ( K sequence -- hmac )
|
||||
binary <byte-reader> stream>md5-hmac ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Maxim Savchenko
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: namespaces ecdsa tools.test checksums checksums.sha2 ;
|
||||
USING: namespaces ecdsa tools.test checksums checksums.sha ;
|
||||
IN: ecdsa.tests
|
||||
|
||||
SYMBOLS: priv-key pub-key signature ;
|
||||
|
|
@ -27,4 +27,4 @@ SYMBOLS: priv-key pub-key signature ;
|
|||
message sha-256 checksum-bytes
|
||||
signature get pub-key get
|
||||
"prime256v1" [ set-public-key ecdsa-verify ] with-ec
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -92,7 +92,9 @@ cell frame_executing(stack_frame *frame)
|
|||
else
|
||||
{
|
||||
array *literals = untag<array>(compiled->literals);
|
||||
return array_nth(literals,0);
|
||||
cell executing = array_nth(literals,0);
|
||||
check_data_pointer((object *)executing);
|
||||
return executing;
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -102,6 +104,7 @@ stack_frame *frame_successor(stack_frame *frame)
|
|||
return (stack_frame *)((cell)frame - frame->size);
|
||||
}
|
||||
|
||||
/* Allocates memory */
|
||||
cell frame_scan(stack_frame *frame)
|
||||
{
|
||||
if(frame_type(frame) == QUOTATION_TYPE)
|
||||
|
|
@ -133,12 +136,12 @@ struct stack_frame_counter {
|
|||
|
||||
struct stack_frame_accumulator {
|
||||
cell index;
|
||||
array *frames;
|
||||
stack_frame_accumulator(cell count) : index(0), frames(allot_array_internal<array>(count)) {}
|
||||
gc_root<array> frames;
|
||||
stack_frame_accumulator(cell count) : index(0), frames(allot_array(count,F)) {}
|
||||
void operator()(stack_frame *frame)
|
||||
{
|
||||
set_array_nth(frames,index++,frame_executing(frame));
|
||||
set_array_nth(frames,index++,frame_scan(frame));
|
||||
set_array_nth(frames.untagged(),index++,frame_executing(frame));
|
||||
set_array_nth(frames.untagged(),index++,frame_scan(frame));
|
||||
}
|
||||
};
|
||||
|
||||
|
|
@ -154,7 +157,7 @@ PRIMITIVE(callstack_to_array)
|
|||
stack_frame_accumulator accum(counter.count);
|
||||
iterate_callstack_object(callstack.untagged(),accum);
|
||||
|
||||
dpush(tag<array>(accum.frames));
|
||||
dpush(accum.frames.value());
|
||||
}
|
||||
|
||||
stack_frame *innermost_stack_frame(callstack *stack)
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ DEFPUSHPOP(gc_local_,gc_locals)
|
|||
template <typename T>
|
||||
struct gc_root : public tagged<T>
|
||||
{
|
||||
void push() { gc_local_push((cell)this); }
|
||||
void push() { check_tagged_pointer(tagged<T>::value()); gc_local_push((cell)this); }
|
||||
|
||||
explicit gc_root(cell value_) : tagged<T>(value_) { push(); }
|
||||
explicit gc_root(T *value_) : tagged<T>(value_) { push(); }
|
||||
|
|
|
|||
Loading…
Reference in New Issue