Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-05-18 11:50:19 -05:00
commit 0d5d888474
46 changed files with 648 additions and 484 deletions

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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"

View File

@ -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

View File

@ -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"

View File

@ -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

View File

@ -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 ;

View File

@ -0,0 +1 @@
SHA checksum algorithms

View File

@ -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"

View File

@ -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

View File

@ -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 ;

View File

@ -1 +0,0 @@
SHA1 checksum algorithm

View File

@ -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"

View File

@ -1 +0,0 @@
SHA2 checksum algorithm

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ? -- )

View File

@ -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" }

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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" } ;

View File

@ -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 )

View File

@ -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"

View File

@ -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 ;

View File

@ -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 ( -- )

View File

@ -1 +0,0 @@
Doug Coleman

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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)

View File

@ -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(); }