From 83814f2ce4ec0bb5d4e21c0d77b5da678daa7187 Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Sun, 10 May 2009 20:42:20 -0500 Subject: [PATCH 01/23] moving md5 state to a tuple, redoing hmac --- .../checksums}/hmac/authors.txt | 0 .../checksums}/hmac/hmac-tests.factor | 20 ++-- basis/checksums/hmac/hmac.factor | 49 +++++++++ basis/checksums/md5/md5.factor | 102 +++++++++++------- extra/crypto/hmac/hmac.factor | 55 ---------- 5 files changed, 125 insertions(+), 101 deletions(-) rename {extra/crypto => basis/checksums}/hmac/authors.txt (100%) rename {extra/crypto => basis/checksums}/hmac/hmac-tests.factor (56%) create mode 100755 basis/checksums/hmac/hmac.factor delete mode 100755 extra/crypto/hmac/hmac.factor diff --git a/extra/crypto/hmac/authors.txt b/basis/checksums/hmac/authors.txt similarity index 100% rename from extra/crypto/hmac/authors.txt rename to basis/checksums/hmac/authors.txt diff --git a/extra/crypto/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor similarity index 56% rename from extra/crypto/hmac/hmac-tests.factor rename to basis/checksums/hmac/hmac-tests.factor index 274e99d2f6..9541ca2f26 100755 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/basis/checksums/hmac/hmac-tests.factor @@ -1,38 +1,42 @@ USING: kernel io strings byte-arrays sequences namespaces math -parser crypto.hmac tools.test ; -IN: crypto.hmac.tests +parser checksums.hmac tools.test checksums.md5 checksums.sha1 +checksums.sha2 ; +IN: checksums.hmac.tests [ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ - 16 11 "Hi There" sequence>md5-hmac >string ] unit-test + 16 11 "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?" sequence>md5-hmac >string ] unit-test +[ "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 - 50 HEX: dd sequence>md5-hmac >string + 50 HEX: dd md5 hmac-bytes >string ] unit-test [ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ - 16 11 "Hi There" sequence>sha1-hmac >string + 16 11 "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?" sequence>sha1-hmac >string + "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 - 50 HEX: dd sequence>sha1-hmac >string + 50 HEX: dd sha1 hmac-bytes >string ] unit-test + +[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ] +[ HEX: b 20 sha-256 hmac-bytes >string ] unit-test diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor new file mode 100755 index 0000000000..7350a02573 --- /dev/null +++ b/basis/checksums/hmac/hmac.factor @@ -0,0 +1,49 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays checksums checksums.md5 checksums.md5.private +checksums.sha1 combinators fry io io.binary io.encodings.binary +io.files io.streams.byte-array kernel math math.vectors memoize +sequences ; +IN: checksums.hmac + +sha1 get-sha1 + initialize-sha1 + [ process-sha1-block ] + [ process-sha1-block ] bi* get-sha1 ; + +: md5-hmac ( Ko Ki stream -- 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: opad ( -- seq ) 64 HEX: 5c ; + +MEMO: ipad ( -- seq ) 64 HEX: 36 ; + +: init-K ( K -- o i ) + 64 0 pad-tail + [ opad seq-bitxor ] + [ ipad seq-bitxor ] bi ; + +PRIVATE> + +: hmac ( K stream checksum -- value ) + ; + +:: hmac-stream ( K stream checksum -- value ) + K init-K :> i :> o + stream checksum checksum-stream ; + +: hmac-file ( K path checksum -- value ) + [ binary ] dip hmac-stream ; + +: hmac-bytes ( K path checksum -- value ) + [ binary ] dip hmac-stream ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 29620b089d..eda977203a 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -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 ; IN: checksums.md5 -! See http://www.faqs.org/rfcs/rfc1321.html +TUPLE: md5-state bytes-read a b c d old-a old-b old-c old-d ; + +: ( -- md5-state ) + md5-state new + 0 >>bytes-read + HEX: 67452301 [ >>a ] [ >>old-a ] bi + HEX: efcdab89 [ >>b ] [ >>old-b ] bi + HEX: 98badcfe [ >>c ] [ >>old-c ] bi + HEX: 10325476 [ >>d ] [ >>old-d ] bi ; > ] [ ] [ old-a>> ] tri [ w+ ] change-a (>>old-a) ] + [ [ b>> ] [ ] [ old-b>> ] tri [ w+ ] change-b (>>old-b) ] + [ [ c>> ] [ ] [ old-c>> ] tri [ w+ ] change-c (>>old-c) ] + [ [ d>> ] [ ] [ old-d>> ] tri [ w+ ] change-d (>>old-d) ] + [ ] + } cleave ; + +: md5-state>bytes ( md5-state -- str ) + [ { [ a>> ] [ b>> ] [ c>> ] [ d>> ] } cleave ] output>array + [ 4 >le ] map B{ } concat-as ; : T ( N -- Y ) sin abs 32 2^ * >integer ; foldable -: 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 ; - -: 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 ; -: 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 ; : H ( X Y Z -- HXYZ ) #! H(X,Y,Z) = X xor Y xor Z bitxor bitxor ; -: 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 ; CONSTANT: S11 7 CONSTANT: S12 12 @@ -72,6 +68,35 @@ CONSTANT: S42 10 CONSTANT: S43 15 CONSTANT: S44 21 + + + +SYMBOLS: a b c d old-a old-b old-c old-d ; + +: 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 ; + +: 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 + MACRO: with-md5-round ( ops func -- ) '[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ; @@ -173,9 +198,10 @@ MACRO: with-md5-round ( ops func -- ) [ (process-md5-block) ] each ] if ; -: stream>md5 ( -- ) - 64 read [ process-md5-block ] keep - length 64 = [ stream>md5 ] when ; +: stream>md5 ( stream -- ) + 64 over stream-read + [ process-md5-block ] [ length 64 = ] bi + [ stream>md5 ] [ drop ] if ; : get-md5 ( -- str ) [ a b c d ] [ get 4 >le ] map concat >byte-array ; @@ -186,5 +212,5 @@ SINGLETON: md5 INSTANCE: md5 stream-checksum -M: md5 checksum-stream ( stream -- byte-array ) - drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ; +M: md5 checksum-stream + drop initialize-md5 stream>md5 get-md5 ; diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor deleted file mode 100755 index 9a668aa23a..0000000000 --- a/extra/crypto/hmac/hmac.factor +++ /dev/null @@ -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 - -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 ; - -MEMO: opad ( -- seq ) 64 HEX: 5c ; - -: 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 stream>sha1-hmac ; - -: sequence>sha1-hmac ( K sequence -- hmac ) - binary stream>sha1-hmac ; - -: stream>md5-hmac ( K stream -- hmac ) - [ init-hmac md5-hmac ] with-input-stream ; - -: file>md5-hmac ( K path -- hmac ) - binary stream>md5-hmac ; - -: sequence>md5-hmac ( K sequence -- hmac ) - binary stream>md5-hmac ; From 90a00dac80e0e29d99fb4879e0789b09288423be Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 10 May 2009 23:06:33 -0500 Subject: [PATCH 02/23] md5 stores state in a tuple now --- basis/checksums/md5/md5.factor | 132 ++++++++++++++------------------- 1 file changed, 57 insertions(+), 75 deletions(-) diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index eda977203a..bf43805df2 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -7,49 +7,40 @@ io.encodings.binary math.bitwise checksums accessors checksums.common checksums.stream combinators combinators.smart ; IN: checksums.md5 -TUPLE: md5-state bytes-read a b c d old-a old-b old-c old-d ; +TUPLE: md5-state bytes-read state old-state ; : ( -- md5-state ) md5-state new 0 >>bytes-read - HEX: 67452301 [ >>a ] [ >>old-a ] bi - HEX: efcdab89 [ >>b ] [ >>old-b ] bi - HEX: 98badcfe [ >>c ] [ >>old-c ] bi - HEX: 10325476 [ >>d ] [ >>old-d ] bi ; + { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } + [ clone >>state ] [ clone >>old-state ] bi ; > ] [ ] [ old-a>> ] tri [ w+ ] change-a (>>old-a) ] - [ [ b>> ] [ ] [ old-b>> ] tri [ w+ ] change-b (>>old-b) ] - [ [ c>> ] [ ] [ old-c>> ] tri [ w+ ] change-c (>>old-c) ] - [ [ d>> ] [ ] [ old-d>> ] tri [ w+ ] change-d (>>old-d) ] - [ ] - } cleave ; +: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ; -: md5-state>bytes ( md5-state -- str ) - [ { [ a>> ] [ b>> ] [ c>> ] [ d>> ] } cleave ] output>array - [ 4 >le ] map B{ } concat-as ; +: update-md5-state ( md5-state -- ) + [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri + [ (>>old-state) ] [ (>>state) ] bi ; : T ( N -- Y ) sin abs 32 2^ * >integer ; foldable :: F ( X Y Z -- FXYZ ) #! F(X,Y,Z) = XY v not(X) Z - X Y bitand X bitnot Z bitand bitor ; + X Y bitand X bitnot Z bitand bitor ; inline :: G ( X Y Z -- GXYZ ) #! G(X,Y,Z) = XZ v Y not(Z) - X Z bitand Y Z bitnot bitand bitor ; + 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) = Y xor (X v not(Z)) - Z bitnot X bitor Y bitxor ; + Z bitnot X bitor Y bitxor ; inline CONSTANT: S11 7 CONSTANT: S12 12 @@ -68,39 +59,27 @@ CONSTANT: S42 10 CONSTANT: S43 15 CONSTANT: S44 21 +CONSTANT: a 0 +CONSTANT: b 1 +CONSTANT: c 2 +CONSTANT: d 3 - - -SYMBOLS: a b c d old-a old-b old-c old-d ; - -: 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 ; - -: 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 -- ) +:: (ABCD) ( x V a b c d k s i quot -- ) #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) - a [ - b get c get d get func call w+ + a V [ + b V nth-unsafe + c V nth-unsafe + d V nth-unsafe quot call w+ k x nth-unsafe w+ i T w+ s bitroll-32 - b get w+ - ] change ; inline + b V nth-unsafe w+ + ] change-nth ; inline -MACRO: with-md5-round ( ops func -- ) - '[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ; +MACRO: with-md5-round ( ops quot -- ) + '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ; -: (process-md5-block-F) ( block -- ) +: (process-md5-block-F) ( block v -- ) { [ a b c d 0 S11 1 ] [ d a b c 1 S12 2 ] @@ -118,9 +97,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 v -- ) { [ a b c d 1 S21 17 ] [ d a b c 6 S22 18 ] @@ -138,9 +117,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 v -- ) { [ a b c d 5 S31 33 ] [ d a b c 8 S32 34 ] @@ -158,9 +137,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 v -- ) { [ a b c d 0 S41 49 ] [ d a b c 7 S42 50 ] @@ -178,33 +157,36 @@ 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 [ 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) +: (process-md5-block) ( block state -- ) + [ + [ 4 [ le> ] map ] [ 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 + nip update-md5-state + ] 2bi ; + +:: process-md5-block ( block state -- ) + block length + [ state [ + ] change-bytes-read drop ] [ 64 = ] bi [ + block state (process-md5-block) + ] [ + block f state bytes-read>> pad-last-block + [ state (process-md5-block) ] each ] if ; -: stream>md5 ( stream -- ) - 64 over stream-read - [ process-md5-block ] [ length 64 = ] bi - [ stream>md5 ] [ drop ] if ; +:: stream>md5 ( stream state -- ) + 64 stream stream-read + [ state process-md5-block ] [ length 64 = ] bi + [ stream state stream>md5 ] when ; -: get-md5 ( -- str ) - [ a b c d ] [ get 4 >le ] map concat >byte-array ; +: get-md5 ( md5-state -- bytes ) + state>> [ 4 >le ] map B{ } concat-as ; PRIVATE> @@ -213,4 +195,4 @@ SINGLETON: md5 INSTANCE: md5 stream-checksum M: md5 checksum-stream - drop initialize-md5 stream>md5 get-md5 ; + drop [ stream>md5 ] [ get-md5 ] bi ; From 449259630ff8eea81cd0ae4a242e7fb64cd25215 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 May 2009 11:37:21 -0500 Subject: [PATCH 03/23] working on checksums --- basis/checksums/hmac/hmac.factor | 16 ++++++++++------ basis/checksums/md5/md5.factor | 31 ++++++++++++++++++++++--------- 2 files changed, 32 insertions(+), 15 deletions(-) diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index 7350a02573..fd7f6ef3a1 100755 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -8,6 +8,7 @@ IN: checksums.hmac sha1 get-sha1 @@ -15,12 +16,13 @@ IN: checksums.hmac [ process-sha1-block ] [ process-sha1-block ] bi* get-sha1 ; -: md5-hmac ( Ko Ki stream -- hmac ) + : md5-hmac ( Ko Ki stream -- 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 ; @@ -35,12 +37,14 @@ MEMO: ipad ( -- seq ) 64 HEX: 36 ; PRIVATE> -: hmac ( K stream checksum -- value ) - ; - :: hmac-stream ( K stream checksum -- value ) - K init-K :> i :> o - stream checksum checksum-stream ; + K init-K :> Ki :> Ko + checksum initialize-checksum + Ki add-bytes + stream add-stream finish-checksum + checksum initialize-checksum + Ko add-bytes swap add-bytes + finish-checksum ; : hmac-file ( K path checksum -- value ) [ binary ] dip hmac-stream ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index bf43805df2..abdc3504cc 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -13,7 +13,7 @@ TUPLE: md5-state bytes-read state old-state ; md5-state new 0 >>bytes-read { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } - [ clone >>state ] [ clone >>old-state ] bi ; + [ clone >>state ] [ >>old-state ] bi ; > ] [ old-state>> v-w+ dup clone ] [ ] tri - [ (>>old-state) ] [ (>>state) ] bi ; + [ (>>old-state) ] [ (>>state) ] bi ; inline : T ( N -- Y ) - sin abs 32 2^ * >integer ; foldable + sin abs 32 2^ * >integer ; inline :: F ( X Y Z -- FXYZ ) #! F(X,Y,Z) = XY v not(X) Z @@ -179,15 +179,15 @@ MACRO: with-md5-round ( ops quot -- ) block f state bytes-read>> pad-last-block [ state (process-md5-block) ] each ] if ; - -:: stream>md5 ( stream state -- ) - 64 stream stream-read - [ state process-md5-block ] [ length 64 = ] bi - [ stream state stream>md5 ] when ; : get-md5 ( md5-state -- bytes ) state>> [ 4 >le ] map B{ } concat-as ; +:: stream>md5 ( state stream -- ) + 64 stream stream-read + [ state process-md5-block ] [ length 64 = ] bi + [ state stream stream>md5 ] when ; + PRIVATE> SINGLETON: md5 @@ -195,4 +195,17 @@ SINGLETON: md5 INSTANCE: md5 stream-checksum M: md5 checksum-stream - drop [ stream>md5 ] [ get-md5 ] bi ; + drop [ ] dip [ stream>md5 ] [ drop get-md5 ] 2bi ; + +GENERIC: initialize-checksum ( checksum -- state ) +GENERIC# add-bytes 1 ( state bytes -- state ) +GENERIC# add-stream 1 ( state stream -- state ) +GENERIC: finish-checksum ( state -- bytes ) + +M: md5 initialize-checksum drop ; + +M: md5-state finish-checksum get-md5 ; + +M: md5-state add-bytes over [ binary stream>md5 ] dip ; + +M: md5-state add-stream over [ stream>md5 ] dip ; From 223a47c8d95b79deeab39a228745a1fea9867c4d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 16 May 2009 08:46:41 -0500 Subject: [PATCH 04/23] throw exceptions on png types we dont support --- basis/compression/inflate/inflate.factor | 4 ++- basis/images/png/png.factor | 32 ++++++++++++++++++++++-- 2 files changed, 33 insertions(+), 3 deletions(-) diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 3e67b11cc7..3fe07b5994 100755 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -200,7 +200,9 @@ 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: diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index bf13c43546..c5b84de221 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -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-info size>> ] bi From 78ba8616b326448f727440e9fc83317766725cb2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 16 May 2009 13:03:09 -0500 Subject: [PATCH 05/23] working on checksums --- basis/checksums/hmac/hmac.factor | 2 +- basis/checksums/md5/md5.factor | 48 +++++++------------------------- core/checksums/checksums.factor | 34 ++++++++++++++++++++-- 3 files changed, 43 insertions(+), 41 deletions(-) diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index fd7f6ef3a1..17b391f215 100755 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -49,5 +49,5 @@ PRIVATE> : hmac-file ( K path checksum -- value ) [ binary ] dip hmac-stream ; -: hmac-bytes ( K path checksum -- value ) +: hmac-bytes ( K seq checksum -- value ) [ binary ] dip hmac-stream ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index abdc3504cc..ee00817ea5 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -7,11 +7,13 @@ io.encodings.binary math.bitwise checksums accessors checksums.common checksums.stream combinators combinators.smart ; IN: checksums.md5 -TUPLE: md5-state bytes-read state old-state ; +SINGLETON: md5 +INSTANCE: md5 stream-checksum + +TUPLE: md5-state < checksum-state state old-state ; : ( -- md5-state ) - md5-state new - 0 >>bytes-read + 64 md5-state new-checksum-state { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } [ clone >>state ] [ >>old-state ] bi ; @@ -159,7 +161,7 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 9 S44 64 ] } [ I ] with-md5-round ; inline -: (process-md5-block) ( block state -- ) +M: md5-state checksum-block ( block state -- ) [ [ 4 [ le> ] map ] [ state>> ] bi* { [ (process-md5-block-F) ] @@ -171,41 +173,11 @@ MACRO: with-md5-round ( ops quot -- ) nip update-md5-state ] 2bi ; -:: process-md5-block ( block state -- ) - block length - [ state [ + ] change-bytes-read drop ] [ 64 = ] bi [ - block state (process-md5-block) - ] [ - block f state bytes-read>> pad-last-block - [ state (process-md5-block) ] each - ] if ; - -: get-md5 ( md5-state -- bytes ) +: md5-state>checksum ( md5-state -- bytes ) state>> [ 4 >le ] map B{ } concat-as ; -:: stream>md5 ( state stream -- ) - 64 stream stream-read - [ state process-md5-block ] [ length 64 = ] bi - [ state stream stream>md5 ] when ; +M: md5-state get-checksum ( md5-state -- bytes ) + clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri + [ [ checksum-block ] curry each ] [ md5-state>checksum ] bi ; PRIVATE> - -SINGLETON: md5 - -INSTANCE: md5 stream-checksum - -M: md5 checksum-stream - drop [ ] dip [ stream>md5 ] [ drop get-md5 ] 2bi ; - -GENERIC: initialize-checksum ( checksum -- state ) -GENERIC# add-bytes 1 ( state bytes -- state ) -GENERIC# add-stream 1 ( state stream -- state ) -GENERIC: finish-checksum ( state -- bytes ) - -M: md5 initialize-checksum drop ; - -M: md5-state finish-checksum get-md5 ; - -M: md5-state add-bytes over [ binary stream>md5 ] dip ; - -M: md5-state add-stream over [ stream>md5 ] dip ; diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 82918b6f81..4f12f5b45d 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -1,11 +1,41 @@ ! 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 vectors io.encodings.binary ; IN: checksums MIXIN: checksum +TUPLE: checksum-state bytes-read block-size bytes ; + +: new-checksum-state ( block-size class -- checksum-state ) + new + swap >>block-size + 0 >>bytes-read + V{ } clone >>bytes ; inline + +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 [ + over [ checksum-block ] + [ [ 64 + ] change-bytes-read drop ] bi + ] dip + ] while >vector >>bytes ; + +: add-checksum-stream ( checksum-state stream -- checksum-state ) + [ + [ '[ [ _ ] dip add-checksum-bytes drop ] each-block ] keep + ] with-input-stream ; + +: add-checksum-file ( checksum-state path -- checksum-state ) + binary add-checksum-stream ; + GENERIC: checksum-bytes ( bytes checksum -- value ) GENERIC: checksum-stream ( stream checksum -- value ) From 2185e487419fa56021db6ad0a5cbaa5821886460 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 16 May 2009 15:17:20 -0500 Subject: [PATCH 06/23] dont use fry in core --- core/checksums/checksums.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 4f12f5b45d..27ee6a3435 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors io io.backend io.files kernel math math.parser -sequences vectors io.encodings.binary ; +sequences vectors io.encodings.binary quotations ; IN: checksums MIXIN: checksum @@ -30,7 +30,7 @@ GENERIC: get-checksum ( checksum -- value ) : add-checksum-stream ( checksum-state stream -- checksum-state ) [ - [ '[ [ _ ] dip add-checksum-bytes drop ] each-block ] keep + [ [ swap add-checksum-bytes drop ] curry each-block ] keep ] with-input-stream ; : add-checksum-file ( checksum-state path -- checksum-state ) From cab57f5547a569bc51a7c6f1d0c83c7d859b0442 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 16 May 2009 18:00:56 -0500 Subject: [PATCH 07/23] checksums work now --- basis/checksums/md5/md5-tests.factor | 21 ++++++++++++++++++ basis/checksums/md5/md5.factor | 32 ++++++++++++++++++---------- core/checksums/checksums.factor | 6 +++++- 3 files changed, 47 insertions(+), 12 deletions(-) diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor index 8e314f7c28..db15540f43 100644 --- a/basis/checksums/md5/md5-tests.factor +++ b/basis/checksums/md5/md5-tests.factor @@ -8,3 +8,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 +] [ + "asdf" add-checksum-bytes + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "" add-checksum-bytes + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index ee00817ea5..97a263bab5 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -8,11 +8,12 @@ checksums.common checksums.stream combinators combinators.smart ; IN: checksums.md5 SINGLETON: md5 + INSTANCE: md5 stream-checksum TUPLE: md5-state < checksum-state state old-state ; -: ( -- md5-state ) +: ( -- md5 ) 64 md5-state new-checksum-state { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } [ clone >>state ] [ >>old-state ] bi ; @@ -21,7 +22,7 @@ TUPLE: md5-state < checksum-state state old-state ; : v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ; -: update-md5-state ( md5-state -- ) +: update-md5 ( md5 -- ) [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri [ (>>old-state) ] [ (>>state) ] bi ; inline @@ -69,13 +70,13 @@ CONSTANT: d 3 :: (ABCD) ( x V a b c d k s i quot -- ) #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) a V [ - b V nth-unsafe - c V nth-unsafe - d V nth-unsafe quot call w+ - k x nth-unsafe w+ + b V nth + c V nth + d V nth quot call w+ + k x nth w+ i T w+ s bitroll-32 - b V nth-unsafe w+ + b V nth w+ ] change-nth ; inline MACRO: with-md5-round ( ops quot -- ) @@ -170,14 +171,23 @@ M: md5-state checksum-block ( block state -- ) [ (process-md5-block-I) ] } 2cleave ] [ - nip update-md5-state + nip update-md5 ] 2bi ; -: md5-state>checksum ( md5-state -- bytes ) +: md5>checksum ( md5 -- bytes ) state>> [ 4 >le ] map B{ } concat-as ; -M: md5-state get-checksum ( md5-state -- bytes ) +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-state>checksum ] bi ; + [ [ checksum-block ] curry each ] [ md5>checksum ] bi ; + +M: md5 checksum-stream ( stream checksum -- byte-array ) + drop + [ ] dip add-checksum-stream get-checksum ; PRIVATE> diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 27ee6a3435..0910a3efac 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -14,6 +14,10 @@ TUPLE: checksum-state bytes-read block-size bytes ; 0 >>bytes-read V{ } clone >>bytes ; inline +M: checksum-state clone + call-next-method + [ clone ] change-bytes ; + GENERIC: checksum-block ( bytes checksum -- ) GENERIC: get-checksum ( checksum -- value ) @@ -26,7 +30,7 @@ GENERIC: get-checksum ( checksum -- value ) over [ checksum-block ] [ [ 64 + ] change-bytes-read drop ] bi ] dip - ] while >vector >>bytes ; + ] while >vector [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ; : add-checksum-stream ( checksum-state stream -- checksum-state ) [ From 6ac69d74c415a32171e4459bcd81531e020b7e80 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 10:10:14 -0500 Subject: [PATCH 08/23] fix a bug in inflate -- length table was one entry too short --- basis/compression/inflate/inflate.factor | 25 ++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 3fe07b5994..7cb43ac68f 100755 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -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 ] } @@ -206,6 +208,5 @@ PRIVATE> : zlib-inflate ( bytes -- bytes ) bs: - [ check-zlib-header ] - [ inflate-loop ] bi + [ check-zlib-header ] [ inflate-loop ] bi inflate-lz77 ; From 5ec95fcef21b29dee207611c6658ec4a317ecf40 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 11:03:04 -0500 Subject: [PATCH 09/23] sha2 now uses the incremental checksum protocol --- basis/checksums/md5/md5-tests.factor | 4 +- basis/checksums/sha2/sha2.factor | 101 +++++++++++++-------------- 2 files changed, 51 insertions(+), 54 deletions(-) diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor index db15540f43..b7f388c002 100644 --- a/basis/checksums/md5/md5-tests.factor +++ b/basis/checksums/md5/md5-tests.factor @@ -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 diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 12e32f6c69..509b047d2e 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -3,16 +3,16 @@ 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 ; +accessors locals checksums.stream multiline ; IN: checksums.sha2 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: sha2-state < checksum-state K H word-size ; TUPLE: sha2-short < sha2-state ; @@ -22,6 +22,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 ; + ( -- sha2-state ) + 64 sha-224-state new-checksum-state + K-256 >>K + initial-H-224 >>H + 4 >>word-size ; + +: ( -- sha2-state ) + 64 sha-256-state new-checksum-state + K-256 >>K + initial-H-256 >>H + 4 >>word-size ; + : s0-256 ( x -- x' ) [ [ -7 bitroll-32 ] @@ -172,7 +189,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 +198,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,23 +218,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 % ] - [ 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 % ] - [ 3 shift 8 >be % ] bi - ] "" make append ; - : seq>byte-array ( seq n -- string ) '[ _ >be ] map B{ } join ; @@ -257,7 +257,7 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) [ word-size>> [ 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 -- ) @@ -268,39 +268,34 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string ) ] each cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; 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 ] - [ sha2-steps ] bi ; +: sha-224>checksum ( sha2 -- bytes ) + H>> 7 head 4 seq>byte-array ; -: ( -- sha2-state ) - sha-224-state new - K-256 >>K - initial-H-224 >>H - 4 >>word-size - 64 >>block-size ; +: sha-256>checksum ( sha2 -- bytes ) + H>> 4 seq>byte-array ; -: ( -- sha2-state ) - sha-256-state new - K-256 >>K - initial-H-256 >>H - 4 >>word-size - 64 >>block-size ; +: pad-last-short-block ( state -- ) + [ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri + [ checksum-block ] curry each ; PRIVATE> -M: sha-224 checksum-bytes - drop - [ 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 - [ 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 + [ ] dip add-checksum-stream get-checksum ; + +M: sha-256 checksum-stream ( stream checksum -- byte-array ) + drop + [ ] dip add-checksum-stream get-checksum ; From b5e315d2cdf11b517e2722850eaa431e641524dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 12:45:20 -0500 Subject: [PATCH 10/23] working on hmac --- basis/checksums/hmac/hmac-tests.factor | 11 ++++-- basis/checksums/hmac/hmac.factor | 47 ++++++++++---------------- basis/checksums/md5/md5.factor | 5 ++- basis/checksums/sha2/sha2-tests.factor | 2 -- basis/checksums/sha2/sha2.factor | 10 ++++-- core/checksums/checksums.factor | 5 +-- 6 files changed, 41 insertions(+), 39 deletions(-) diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor index 9541ca2f26..8835bed981 100755 --- a/basis/checksums/hmac/hmac-tests.factor +++ b/basis/checksums/hmac/hmac-tests.factor @@ -1,6 +1,6 @@ USING: kernel io strings byte-arrays sequences namespaces math parser checksums.hmac tools.test checksums.md5 checksums.sha1 -checksums.sha2 ; +checksums.sha2 checksums ; IN: checksums.hmac.tests [ @@ -39,4 +39,11 @@ IN: checksums.hmac.tests ] unit-test [ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ] -[ HEX: b 20 sha-256 hmac-bytes >string ] unit-test +[ 20 HEX: b "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 + diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index 17b391f215..538dfc92c8 100755 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -3,48 +3,35 @@ USING: arrays checksums checksums.md5 checksums.md5.private checksums.sha1 combinators fry io io.binary io.encodings.binary io.files io.streams.byte-array kernel math math.vectors memoize -sequences ; +sequences locals accessors ; IN: checksums.hmac sha1 get-sha1 - initialize-sha1 - [ process-sha1-block ] - [ process-sha1-block ] bi* get-sha1 ; - - : md5-hmac ( Ko Ki stream -- 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: opad ( -- seq ) 64 HEX: 5c ; +: opad ( checksum-state -- seq ) block-size>> HEX: 5c ; -MEMO: ipad ( -- seq ) 64 HEX: 36 ; +: ipad ( checksum-state -- seq ) block-size>> HEX: 36 ; -: init-K ( K -- o i ) - 64 0 pad-tail - [ opad seq-bitxor ] - [ ipad seq-bitxor ] bi ; +:: 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 init-K :> Ki :> Ko - checksum initialize-checksum - Ki add-bytes - stream add-stream finish-checksum - checksum initialize-checksum - Ko add-bytes swap add-bytes - finish-checksum ; + 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 ] dip hmac-stream ; diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 97a263bab5..026df34012 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -14,10 +14,13 @@ INSTANCE: md5 stream-checksum TUPLE: md5-state < checksum-state state old-state ; : ( -- md5 ) - 64 md5-state new-checksum-state + md5-state new-checksum-state + 64 >>block-size { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } [ clone >>state ] [ >>old-state ] bi ; +M: md5 initialize-checksum-state drop ; + ( -- sha2-state ) - 64 sha-224-state new-checksum-state + sha-224-state new-checksum-state + 64 >>block-size K-256 >>K initial-H-224 >>H 4 >>word-size ; : ( -- sha2-state ) - 64 sha-256-state new-checksum-state + sha-256-state new-checksum-state + 64 >>block-size K-256 >>K initial-H-256 >>H 4 >>word-size ; +M: sha-224 initialize-checksum-state drop ; + +M: sha-256 initialize-checksum-state drop ; + : s0-256 ( x -- x' ) [ [ -7 bitroll-32 ] diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 0910a3efac..1d57823e18 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -8,9 +8,8 @@ MIXIN: checksum TUPLE: checksum-state bytes-read block-size bytes ; -: new-checksum-state ( block-size class -- checksum-state ) +: new-checksum-state ( class -- checksum-state ) new - swap >>block-size 0 >>bytes-read V{ } clone >>bytes ; inline @@ -18,6 +17,8 @@ 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 ) From 68ceb338914caf8474b48282f6e3d6a6c9899fde Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 13:36:53 -0500 Subject: [PATCH 11/23] use literal-arrays --- basis/images/bitmap/bitmap-tests.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor index 29ba3b9b80..ea8b0d4c0c 100644 --- a/basis/images/bitmap/bitmap-tests.factor +++ b/basis/images/bitmap/bitmap-tests.factor @@ -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 From 7a3f15a586b6260266ed3bd89fa9b1441f3d96f9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 13:49:56 -0500 Subject: [PATCH 12/23] generalize sha1-interleave and move it to its own vocabulary --- basis/checksums/interleave/authors.txt | 1 + .../interleave/interleave-tests.factor | 19 +++++++++++++++++++ basis/checksums/interleave/interleave.factor | 17 +++++++++++++++++ 3 files changed, 37 insertions(+) create mode 100644 basis/checksums/interleave/authors.txt create mode 100644 basis/checksums/interleave/interleave-tests.factor create mode 100644 basis/checksums/interleave/interleave.factor diff --git a/basis/checksums/interleave/authors.txt b/basis/checksums/interleave/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/checksums/interleave/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/checksums/interleave/interleave-tests.factor b/basis/checksums/interleave/interleave-tests.factor new file mode 100644 index 0000000000..060d35936f --- /dev/null +++ b/basis/checksums/interleave/interleave-tests.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test checksums.interleave checksums.sha1 ; +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 + diff --git a/basis/checksums/interleave/interleave.factor b/basis/checksums/interleave/interleave.factor new file mode 100644 index 0000000000..caef033ec6 --- /dev/null +++ b/basis/checksums/interleave/interleave.factor @@ -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 ; From 5325675f9d33584cbc19472f29a89121ac76312d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 17:50:31 -0500 Subject: [PATCH 13/23] fix sha1 --- basis/checksums/adler-32/adler-32.factor | 2 +- basis/checksums/hmac/hmac-tests.factor | 4 +- .../interleave/interleave-tests.factor | 2 +- basis/checksums/sha1/authors.txt | 1 - basis/checksums/sha1/sha1-docs.factor | 11 -- basis/checksums/sha1/sha1-tests.factor | 14 -- basis/checksums/sha1/sha1.factor | 134 ------------------ basis/checksums/sha1/summary.txt | 1 - basis/checksums/sha2/sha2-tests.factor | 7 + basis/checksums/sha2/sha2.factor | 114 ++++++++++++++- 10 files changed, 120 insertions(+), 170 deletions(-) delete mode 100755 basis/checksums/sha1/authors.txt delete mode 100644 basis/checksums/sha1/sha1-docs.factor delete mode 100644 basis/checksums/sha1/sha1-tests.factor delete mode 100644 basis/checksums/sha1/sha1.factor delete mode 100644 basis/checksums/sha1/summary.txt diff --git a/basis/checksums/adler-32/adler-32.factor b/basis/checksums/adler-32/adler-32.factor index d5e153ba99..f66860dc63 100644 --- a/basis/checksums/adler-32/adler-32.factor +++ b/basis/checksums/adler-32/adler-32.factor @@ -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] v. ] [ length ] bi + ] bi [ adler-32-modulus mod ] bi@ 16 shift bitor ; diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor index 8835bed981..02dfc271a4 100755 --- a/basis/checksums/hmac/hmac-tests.factor +++ b/basis/checksums/hmac/hmac-tests.factor @@ -1,6 +1,6 @@ USING: kernel io strings byte-arrays sequences namespaces math -parser checksums.hmac tools.test checksums.md5 checksums.sha1 -checksums.sha2 checksums ; +parser checksums.hmac tools.test checksums.md5 checksums.sha2 +checksums ; IN: checksums.hmac.tests [ diff --git a/basis/checksums/interleave/interleave-tests.factor b/basis/checksums/interleave/interleave-tests.factor index 060d35936f..14dddaafab 100644 --- a/basis/checksums/interleave/interleave-tests.factor +++ b/basis/checksums/interleave/interleave-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test checksums.interleave checksums.sha1 ; +USING: tools.test checksums.interleave checksums.sha2 ; IN: checksums.interleave.tests [ diff --git a/basis/checksums/sha1/authors.txt b/basis/checksums/sha1/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/checksums/sha1/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/checksums/sha1/sha1-docs.factor b/basis/checksums/sha1/sha1-docs.factor deleted file mode 100644 index 2c9093865f..0000000000 --- a/basis/checksums/sha1/sha1-docs.factor +++ /dev/null @@ -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" diff --git a/basis/checksums/sha1/sha1-tests.factor b/basis/checksums/sha1/sha1-tests.factor deleted file mode 100644 index 808d37d1e4..0000000000 --- a/basis/checksums/sha1/sha1-tests.factor +++ /dev/null @@ -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 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 diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor deleted file mode 100644 index 707aa66ba6..0000000000 --- a/basis/checksums/sha1/sha1.factor +++ /dev/null @@ -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 % - 20 HEX: 6ed9eba1 % - 20 HEX: 8f1bbcdc % - 20 HEX: ca62c1d6 % - ] { } 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 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 [ 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 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 ; diff --git a/basis/checksums/sha1/summary.txt b/basis/checksums/sha1/summary.txt deleted file mode 100644 index d8da1df0aa..0000000000 --- a/basis/checksums/sha1/summary.txt +++ /dev/null @@ -1 +0,0 @@ -SHA1 checksum algorithm diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor index 010ca96d4f..fa01796ae9 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha2/sha2-tests.factor @@ -5,6 +5,13 @@ IN: checksums.sha2.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 concat sha1 checksum-bytes hex-string ] unit-test + + [ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor index 8992299db0..6c799d7e6e 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha2/sha2.factor @@ -3,15 +3,39 @@ 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 checksums.stream multiline ; +accessors locals checksums.stream multiline literals +generalizations ; IN: checksums.sha2 +SINGLETON: sha1 +INSTANCE: sha1 stream-checksum + SINGLETON: sha-224 SINGLETON: sha-256 INSTANCE: sha-224 stream-checksum INSTANCE: sha-256 stream-checksum +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 + 20 HEX: 6ed9eba1 + 20 HEX: 8f1bbcdc + 20 HEX: ca62c1d6 + 4 { } nappend-as + ] + TUPLE: sha2-state < checksum-state K H word-size ; TUPLE: sha2-short < sha2-state ; @@ -121,6 +145,13 @@ CONSTANT: K-384 ALIAS: K-512 K-384 +: ( -- sha1-state ) + sha1-state new-checksum-state + 64 >>block-size + K-sha1 >>K + initial-H-sha1 >>H + 4 >>word-size ; + : ( -- sha2-state ) sha-224-state new-checksum-state 64 >>block-size @@ -135,6 +166,8 @@ ALIAS: K-512 K-384 initial-H-256 >>H 4 >>word-size ; +M: sha1 initialize-checksum-state drop ; + M: sha-224 initialize-checksum-state drop ; M: sha-256 initialize-checksum-state drop ; @@ -224,9 +257,6 @@ M: sha-256 initialize-checksum-state drop ; GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) -: seq>byte-array ( seq n -- string ) - '[ _ >be ] map B{ } join ; - :: T1-256 ( n M H sha2 -- T1 ) n M nth n sha2 K>> nth + @@ -272,12 +302,18 @@ GENERIC: 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 M: sha2-short checksum-block [ prepare-message-schedule ] [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ; +: seq>byte-array ( seq n -- string ) + '[ _ >be ] map B{ } join ; + +: sha1>checksum ( sha2 -- bytes ) + H>> 4 seq>byte-array ; + : sha-224>checksum ( sha2 -- bytes ) H>> 7 head 4 seq>byte-array ; @@ -305,3 +341,71 @@ M: sha-224 checksum-stream ( stream checksum -- byte-array ) M: sha-256 checksum-stream ( stream checksum -- byte-array ) drop [ ] 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 [ 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 + [ ] dip add-checksum-stream get-checksum ; From acf52363a783da5198cf3891a9d4f45f45e8e7f9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 17:58:36 -0500 Subject: [PATCH 14/23] move sha1 and sha2 to checksums.sha, update usages --- basis/checksums/hmac/hmac-tests.factor | 3 +-- basis/checksums/hmac/hmac.factor | 7 +++---- .../interleave/interleave-tests.factor | 2 +- basis/checksums/openssl/openssl-docs.factor | 2 +- basis/checksums/{sha2 => sha}/authors.txt | 0 basis/checksums/sha/sha-docs.factor | 18 ++++++++++++++++++ .../sha2-tests.factor => sha/sha-tests.factor} | 4 ++-- .../{sha2/sha2.factor => sha/sha.factor} | 2 +- basis/checksums/sha/summary.txt | 1 + basis/checksums/sha2/sha2-docs.factor | 11 ----------- basis/checksums/sha2/summary.txt | 1 - basis/furnace/auth/auth-docs.factor | 2 +- basis/furnace/auth/auth.factor | 2 +- basis/uuid/uuid.factor | 3 +-- core/checksums/checksums-docs.factor | 3 +-- extra/benchmark/sha1/sha1.factor | 2 +- extra/ecdsa/ecdsa-tests.factor | 4 ++-- 17 files changed, 35 insertions(+), 32 deletions(-) rename basis/checksums/{sha2 => sha}/authors.txt (100%) create mode 100644 basis/checksums/sha/sha-docs.factor rename basis/checksums/{sha2/sha2-tests.factor => sha/sha-tests.factor} (97%) rename basis/checksums/{sha2/sha2.factor => sha/sha.factor} (99%) create mode 100644 basis/checksums/sha/summary.txt delete mode 100644 basis/checksums/sha2/sha2-docs.factor delete mode 100644 basis/checksums/sha2/summary.txt diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor index 02dfc271a4..ffae146614 100755 --- a/basis/checksums/hmac/hmac-tests.factor +++ b/basis/checksums/hmac/hmac-tests.factor @@ -1,5 +1,5 @@ USING: kernel io strings byte-arrays sequences namespaces math -parser checksums.hmac tools.test checksums.md5 checksums.sha2 +parser checksums.hmac tools.test checksums.md5 checksums.sha checksums ; IN: checksums.hmac.tests @@ -46,4 +46,3 @@ IN: checksums.hmac.tests "JefeJefeJefeJefeJefeJefeJefeJefe" "what do ya want for nothing?" sha-256 hmac-bytes hex-string ] unit-test - diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor index 538dfc92c8..b163766016 100755 --- a/basis/checksums/hmac/hmac.factor +++ b/basis/checksums/hmac/hmac.factor @@ -1,9 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays checksums checksums.md5 checksums.md5.private -checksums.sha1 combinators fry io io.binary io.encodings.binary -io.files io.streams.byte-array kernel math math.vectors memoize -sequences locals accessors ; +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 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" diff --git a/basis/checksums/sha2/authors.txt b/basis/checksums/sha/authors.txt similarity index 100% rename from basis/checksums/sha2/authors.txt rename to basis/checksums/sha/authors.txt diff --git a/basis/checksums/sha/sha-docs.factor b/basis/checksums/sha/sha-docs.factor new file mode 100644 index 0000000000..780c2b39d8 --- /dev/null +++ b/basis/checksums/sha/sha-docs.factor @@ -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" diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha/sha-tests.factor similarity index 97% rename from basis/checksums/sha2/sha2-tests.factor rename to basis/checksums/sha/sha-tests.factor index fa01796ae9..b70b5e7ba2 100644 --- a/basis/checksums/sha2/sha2-tests.factor +++ b/basis/checksums/sha/sha-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel math namespaces sequences tools.test -checksums.sha2 checksums ; -IN: checksums.sha2.tests +checksums.sha checksums ; +IN: checksums.sha.tests : test-checksum ( text identifier -- checksum ) checksum-bytes hex-string ; diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha/sha.factor similarity index 99% rename from basis/checksums/sha2/sha2.factor rename to basis/checksums/sha/sha.factor index 6c799d7e6e..287c39b2a1 100644 --- a/basis/checksums/sha2/sha2.factor +++ b/basis/checksums/sha/sha.factor @@ -5,7 +5,7 @@ io.binary math.bitwise checksums checksums.common sbufs strings combinators.smart math.ranges fry combinators accessors locals checksums.stream multiline literals generalizations ; -IN: checksums.sha2 +IN: checksums.sha SINGLETON: sha1 INSTANCE: sha1 stream-checksum diff --git a/basis/checksums/sha/summary.txt b/basis/checksums/sha/summary.txt new file mode 100644 index 0000000000..2dd351af0b --- /dev/null +++ b/basis/checksums/sha/summary.txt @@ -0,0 +1 @@ +SHA checksum algorithms diff --git a/basis/checksums/sha2/sha2-docs.factor b/basis/checksums/sha2/sha2-docs.factor deleted file mode 100644 index 6a128552fd..0000000000 --- a/basis/checksums/sha2/sha2-docs.factor +++ /dev/null @@ -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" diff --git a/basis/checksums/sha2/summary.txt b/basis/checksums/sha2/summary.txt deleted file mode 100644 index 04365d439f..0000000000 --- a/basis/checksums/sha2/summary.txt +++ /dev/null @@ -1 +0,0 @@ -SHA2 checksum algorithm diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor index 3f1bcb6085..efd6a52ef0 100644 --- a/basis/furnace/auth/auth-docs.factor +++ b/basis/furnace/auth/auth-docs.factor @@ -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 diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor index b9c961941c..831ec7f8fc 100644 --- a/basis/furnace/auth/auth.factor +++ b/basis/furnace/auth/auth.factor @@ -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 diff --git a/basis/uuid/uuid.factor b/basis/uuid/uuid.factor index 2fd6ffdaec..4d284a1a40 100644 --- a/basis/uuid/uuid.factor +++ b/basis/uuid/uuid.factor @@ -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 ; diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor index 6ef0e85025..a05bf3a685 100644 --- a/core/checksums/checksums-docs.factor +++ b/core/checksums/checksums-docs.factor @@ -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" } ; diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor index c1a7af2966..481bc31eb2 100644 --- a/extra/benchmark/sha1/sha1.factor +++ b/extra/benchmark/sha1/sha1.factor @@ -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 ( -- ) diff --git a/extra/ecdsa/ecdsa-tests.factor b/extra/ecdsa/ecdsa-tests.factor index b319fa297b..2d9cda1460 100644 --- a/extra/ecdsa/ecdsa-tests.factor +++ b/extra/ecdsa/ecdsa-tests.factor @@ -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 \ No newline at end of file +] unit-test From 31e5090892a6eb3e507268d8b5a0973bb11f9167 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 18:05:46 -0500 Subject: [PATCH 15/23] fix multiple using warning in stage1, core can't use io.encodings.binary --- core/bootstrap/stage1.factor | 8 ++++---- core/checksums/checksums.factor | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 088a8a6320..c7be17e38d 100644 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -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 diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 1d57823e18..9d40521fc8 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors io io.backend io.files kernel math math.parser -sequences vectors io.encodings.binary quotations ; +sequences vectors quotations ; IN: checksums MIXIN: checksum @@ -39,7 +39,7 @@ GENERIC: get-checksum ( checksum -- value ) ] with-input-stream ; : add-checksum-file ( checksum-state path -- checksum-state ) - binary add-checksum-stream ; + normalize-path (file-reader) add-checksum-stream ; GENERIC: checksum-bytes ( bytes checksum -- value ) From c4162971e00060d5d2f7be90bd066f5099d18029 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 17 May 2009 18:18:07 -0500 Subject: [PATCH 16/23] callstack>array was keeping an uninitialized array around across potential GCs; add more assertions --- vm/callstack.cpp | 15 +++++++++------ vm/local_roots.hpp | 2 +- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/vm/callstack.cpp b/vm/callstack.cpp index 4ef6db10bd..608a5c39e5 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -92,7 +92,9 @@ cell frame_executing(stack_frame *frame) else { array *literals = untag(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(count)) {} + gc_root 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(accum.frames)); + dpush(accum.frames.value()); } stack_frame *innermost_stack_frame(callstack *stack) diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp index e074d999e7..4cee1c8e09 100644 --- a/vm/local_roots.hpp +++ b/vm/local_roots.hpp @@ -12,7 +12,7 @@ DEFPUSHPOP(gc_local_,gc_locals) template struct gc_root : public tagged { - void push() { gc_local_push((cell)this); } + void push() { check_tagged_pointer(tagged::value()); gc_local_push((cell)this); } explicit gc_root(cell value_) : tagged(value_) { push(); } explicit gc_root(T *value_) : tagged(value_) { push(); } From a469f78fa7ff76089036de8518e3b20e60617007 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 18:41:15 -0500 Subject: [PATCH 17/23] add some unit tests testing get-checksum --- basis/checksums/sha/sha-tests.factor | 27 +++++++++++++++++++++++++-- 1 file changed, 25 insertions(+), 2 deletions(-) diff --git a/basis/checksums/sha/sha-tests.factor b/basis/checksums/sha/sha-tests.factor index b70b5e7ba2..be431af311 100644 --- a/basis/checksums/sha/sha-tests.factor +++ b/basis/checksums/sha/sha-tests.factor @@ -1,5 +1,6 @@ -USING: arrays kernel math namespaces sequences tools.test -checksums.sha checksums ; +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 ) @@ -45,3 +46,25 @@ IN: checksums.sha.tests ! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ] ! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test + +[ + t +] [ + "asdf" binary add-checksum-stream + [ get-checksum ] [ get-checksum ] bi = +] unit-test + From 9c85bc8ce33309345a8e095cd5254c1697ad8cf8 Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Sun, 17 May 2009 20:29:32 -0500 Subject: [PATCH 18/23] fix duplicate using lines --- basis/cpu/x86/64/64.factor | 2 +- basis/io/backend/windows/windows.factor | 6 +++--- core/classes/predicate/predicate-docs.factor | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index ad1b487e44..b77539b7e7 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -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 diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 9f5c00cc5f..2e9aac2ac9 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -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 ? -- ) diff --git a/core/classes/predicate/predicate-docs.factor b/core/classes/predicate/predicate-docs.factor index 3ea0a24674..552ff209b8 100644 --- a/core/classes/predicate/predicate-docs.factor +++ b/core/classes/predicate/predicate-docs.factor @@ -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" From 1505da918f201095d30faff7e38274cee7586e49 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 17 May 2009 20:32:43 -0500 Subject: [PATCH 19/23] fix checksum test -- short circuit so correct error is reported --- basis/checksums/openssl/openssl-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/checksums/openssl/openssl-tests.factor b/basis/checksums/openssl/openssl-tests.factor index 253069c952..2a160e1486 100644 --- a/basis/checksums/openssl/openssl-tests.factor +++ b/basis/checksums/openssl/openssl-tests.factor @@ -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" 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 From 13a4c5b25a9bd5449e920569e1ada566dc6a961c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 17 May 2009 23:39:05 -0500 Subject: [PATCH 20/23] tools.disassembler.gdb: remove redundant using --- basis/tools/disassembler/gdb/gdb.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/disassembler/gdb/gdb.factor b/basis/tools/disassembler/gdb/gdb.factor index 9076b67606..c4c724b696 100755 --- a/basis/tools/disassembler/gdb/gdb.factor +++ b/basis/tools/disassembler/gdb/gdb.factor @@ -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 From 46eae05d1088b40de5aa4043f2f3eea705608011 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 00:24:24 -0500 Subject: [PATCH 21/23] add nth-unsafe to sequences.private, making md5 faster --- basis/checksums/md5/md5.factor | 42 +++++++++++++++++---------------- core/checksums/checksums.factor | 14 ++++++----- core/sequences/sequences.factor | 3 +++ 3 files changed, 33 insertions(+), 26 deletions(-) diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 026df34012..89ff5d46a2 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -4,7 +4,8 @@ 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 accessors -checksums.common checksums.stream combinators combinators.smart ; +checksums.common checksums.stream combinators combinators.smart +specialized-arrays.uint literals ; IN: checksums.md5 SINGLETON: md5 @@ -16,7 +17,7 @@ TUPLE: md5-state < checksum-state state old-state ; : ( -- md5 ) md5-state new-checksum-state 64 >>block-size - { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } + uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 } [ clone >>state ] [ >>old-state ] bi ; M: md5 initialize-checksum-state drop ; @@ -29,8 +30,10 @@ M: md5 initialize-checksum-state drop ; [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri [ (>>old-state) ] [ (>>state) ] bi ; inline -: T ( N -- Y ) - sin abs 32 2^ * >integer ; inline +CONSTANT: T + $[ + 80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as + ] :: F ( X Y Z -- FXYZ ) #! F(X,Y,Z) = XY v not(X) Z @@ -70,22 +73,22 @@ CONSTANT: b 1 CONSTANT: c 2 CONSTANT: d 3 -:: (ABCD) ( x V a b c d k s i quot -- ) +:: (ABCD) ( x state a b c d k s i quot -- ) #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) - a V [ - b V nth - c V nth - d V nth quot call w+ - k x nth w+ - i T w+ + 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 V nth w+ - ] change-nth ; inline + 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 v -- ) +: (process-md5-block-F) ( block state -- ) { [ a b c d 0 S11 1 ] [ d a b c 1 S12 2 ] @@ -105,7 +108,7 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 15 S14 16 ] } [ F ] with-md5-round ; inline -: (process-md5-block-G) ( block v -- ) +: (process-md5-block-G) ( block state -- ) { [ a b c d 1 S21 17 ] [ d a b c 6 S22 18 ] @@ -125,7 +128,7 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 12 S24 32 ] } [ G ] with-md5-round ; inline -: (process-md5-block-H) ( block v -- ) +: (process-md5-block-H) ( block state -- ) { [ a b c d 5 S31 33 ] [ d a b c 8 S32 34 ] @@ -145,7 +148,7 @@ MACRO: with-md5-round ( ops quot -- ) [ b c d a 2 S34 48 ] } [ H ] with-md5-round ; inline -: (process-md5-block-I) ( block v -- ) +: (process-md5-block-I) ( block state -- ) { [ a b c d 0 S41 49 ] [ d a b c 7 S42 50 ] @@ -167,7 +170,7 @@ MACRO: with-md5-round ( ops quot -- ) M: md5-state checksum-block ( block state -- ) [ - [ 4 [ le> ] map ] [ state>> ] bi* { + [ byte-array>uint-array ] [ state>> ] bi* { [ (process-md5-block-F) ] [ (process-md5-block-G) ] [ (process-md5-block-H) ] @@ -177,8 +180,7 @@ M: md5-state checksum-block ( block state -- ) nip update-md5 ] 2bi ; -: md5>checksum ( md5 -- bytes ) - state>> [ 4 >le ] map B{ } concat-as ; +: md5>checksum ( md5 -- bytes ) state>> underlying>> ; M: md5-state clone ( md5 -- new-md5 ) call-next-method diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor index 9d40521fc8..0dd808c722 100644 --- a/core/checksums/checksums.factor +++ b/core/checksums/checksums.factor @@ -1,17 +1,17 @@ ! Copyright (c) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: accessors io io.backend io.files kernel math math.parser -sequences vectors quotations ; +sequences byte-arrays byte-vectors quotations ; IN: checksums MIXIN: checksum -TUPLE: checksum-state bytes-read block-size bytes ; +TUPLE: checksum-state + { bytes-read integer } { block-size integer } { bytes byte-vector } ; : new-checksum-state ( class -- checksum-state ) new - 0 >>bytes-read - V{ } clone >>bytes ; inline + BV{ } clone >>bytes ; inline M: checksum-state clone call-next-method @@ -27,11 +27,13 @@ GENERIC: get-checksum ( checksum -- value ) over bytes>> [ push-all ] keep [ dup length pick block-size>> >= ] [ - 64 cut-slice [ + 64 cut-slice [ >byte-array ] dip [ over [ checksum-block ] [ [ 64 + ] change-bytes-read drop ] bi ] dip - ] while >vector [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ; + ] while + >byte-vector + [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ; : add-checksum-stream ( checksum-state stream -- checksum-state ) [ diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 99dddb8aed..9b0f4c1530 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -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 ; From 96ade23963c6f7dcda4984ad28069943deca0e98 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 02:16:03 -0500 Subject: [PATCH 22/23] median used the wrong algorithm. now it runs in O(n) time. add kth-smallest word, used to implement median --- basis/math/statistics/statistics-tests.factor | 18 ++++++ basis/math/statistics/statistics.factor | 58 ++++++++++++++++--- 2 files changed, 67 insertions(+), 9 deletions(-) diff --git a/basis/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor index b6ff421956..c160d57db7 100644 --- a/basis/math/statistics/statistics-tests.factor +++ b/basis/math/statistics/statistics-tests.factor @@ -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 diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 4cd8c5b888..5b0439906c 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -1,7 +1,8 @@ ! 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 ) @@ -13,13 +14,55 @@ IN: math.statistics : harmonic-mean ( seq -- n ) [ recip ] sigma recip ; -: median ( seq -- n ) +: slow-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 ; @@ -32,15 +75,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 +105,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 ; - From 82fa71a03a5c4faf5324d90fcbdf21b693b9609c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 18 May 2009 02:41:58 -0500 Subject: [PATCH 23/23] remove old median, fix docs --- basis/math/statistics/statistics-docs.factor | 10 +++++----- basis/math/statistics/statistics.factor | 15 ++++----------- 2 files changed, 9 insertions(+), 16 deletions(-) diff --git a/basis/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor index 7a7eb70dd2..1a29d611f9 100644 --- a/basis/math/statistics/statistics-docs.factor +++ b/basis/math/statistics/statistics-docs.factor @@ -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" } diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 5b0439906c..3812e79ec5 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -5,22 +5,15 @@ 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 ; -: slow-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 @@ -67,7 +60,7 @@ IN: math.statistics #! 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 )