! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-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 ;
+USING: alien.c-types alien.data 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 specialized-arrays literals hints ;
+FROM: sequences.private => change-nth-unsafe ;
+SPECIALIZED-ARRAY: uint
IN: checksums.md5
-! See http://www.faqs.org/rfcs/rfc1321.html
+SINGLETON: md5
-<PRIVATE
+INSTANCE: md5 stream-checksum
-SYMBOLS: a b c d old-a old-b old-c old-d ;
+TUPLE: md5-state < checksum-state state old-state ;
-: T ( N -- Y )
- sin abs 32 2^ * >integer ; foldable
+: <md5-state> ( -- md5 )
+ md5-state new-checksum-state
+ 64 >>block-size
+ uint-array{ 0x67452301 0xefcdab89 0x98badcfe 0x10325476 }
+ [ clone >>state ] [ >>old-state ] bi ;
-: 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 ;
+M: md5 initialize-checksum-state drop <md5-state> ;
-: 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 ;
+<PRIVATE
-:: (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
+: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
+
+: update-md5 ( md5 -- )
+ [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
+ [ old-state<< ] [ state<< ] bi ;
-: F ( X Y Z -- FXYZ )
+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
- pick bitnot bitand [ bitand ] [ bitor ] bi* ;
+ X Y bitand X bitnot Z bitand bitor ; inline
-: G ( X Y Z -- GXYZ )
+:: G ( X Y Z -- GXYZ )
#! G(X,Y,Z) = XZ v Y not(Z)
- dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
+ X Z bitand Y Z bitnot bitand bitor ; inline
: H ( X Y Z -- HXYZ )
#! H(X,Y,Z) = X xor Y xor Z
- bitxor bitxor ;
+ bitxor bitxor ; inline
-: I ( X Y Z -- IXYZ )
+:: I ( X Y Z -- IXYZ )
#! I(X,Y,Z) = Y xor (X v not(Z))
- rot swap bitnot bitor bitxor ;
+ Z bitnot X bitor Y bitxor ; inline
CONSTANT: S11 7
CONSTANT: S12 12
CONSTANT: S43 15
CONSTANT: S44 21
-MACRO: with-md5-round ( ops func -- )
- '[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ;
+CONSTANT: a 0
+CONSTANT: b 1
+CONSTANT: c 2
+CONSTANT: d 3
+
+:: (ABCD) ( x state a b c d k s i quot -- )
+ #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
+ a state [
+ b state nth-unsafe
+ c state nth-unsafe
+ d state nth-unsafe quot call w+
+ k x nth-unsafe w+
+ i T nth-unsafe w+
+ s bitroll-32
+ b state nth-unsafe w+ 32 bits
+ ] change-nth-unsafe ; inline
-: (process-md5-block-F) ( block -- )
+MACRO: with-md5-round ( ops quot -- )
+ '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
+
+: (process-md5-block-F) ( block state -- )
{
[ a b c d 0 S11 1 ]
[ d a b c 1 S12 2 ]
[ b c d a 15 S14 16 ]
} [ F ] with-md5-round ;
-: (process-md5-block-G) ( block -- )
+: (process-md5-block-G) ( block state -- )
{
[ a b c d 1 S21 17 ]
[ d a b c 6 S22 18 ]
[ b c d a 12 S24 32 ]
} [ G ] with-md5-round ;
-: (process-md5-block-H) ( block -- )
+: (process-md5-block-H) ( block state -- )
{
[ a b c d 5 S31 33 ]
[ d a b c 8 S32 34 ]
[ b c d a 2 S34 48 ]
} [ H ] with-md5-round ;
-: (process-md5-block-I) ( block -- )
+: (process-md5-block-I) ( block state -- )
{
[ a b c d 0 S41 49 ]
[ d a b c 7 S42 50 ]
[ b c d a 9 S44 64 ]
} [ I ] with-md5-round ;
-: (process-md5-block) ( block -- )
- 4 <groups> [ le> ] map {
- [ (process-md5-block-F) ]
- [ (process-md5-block-G) ]
- [ (process-md5-block-H) ]
- [ (process-md5-block-I) ]
- } cleave
-
- update-md ;
-
-: process-md5-block ( str -- )
- dup length [ bytes-read [ + ] change ] keep 64 = [
- (process-md5-block)
+HINTS: (process-md5-block-F) { uint-array md5-state } ;
+HINTS: (process-md5-block-G) { uint-array md5-state } ;
+HINTS: (process-md5-block-H) { uint-array md5-state } ;
+HINTS: (process-md5-block-I) { uint-array md5-state } ;
+
+: byte-array>le ( byte-array -- byte-array )
+ little-endian? [
+ dup 4 <sliced-groups> [
+ [ [ 1 2 ] dip exchange-unsafe ]
+ [ [ 0 3 ] dip exchange-unsafe ] bi
+ ] each
+ ] unless ;
+
+: uint-array-cast-le ( byte-array -- uint-array )
+ byte-array>le uint cast-array ;
+
+HINTS: uint-array-cast-le byte-array ;
+
+: uint-array>byte-array-le ( uint-array -- byte-array )
+ underlying>> byte-array>le ;
+
+HINTS: uint-array>byte-array-le uint-array ;
+
+M: md5-state checksum-block ( block state -- )
+ [
+ [ uint-array-cast-le ] [ state>> ] bi* {
+ [ (process-md5-block-F) ]
+ [ (process-md5-block-G) ]
+ [ (process-md5-block-H) ]
+ [ (process-md5-block-I) ]
+ } 2cleave
] [
- f bytes-read get pad-last-block
- [ (process-md5-block) ] each
- ] if ;
-
-: stream>md5 ( -- )
- 64 read [ process-md5-block ] keep
- length 64 = [ stream>md5 ] when ;
+ nip update-md5
+ ] 2bi ;
-: get-md5 ( -- str )
- [ a b c d ] [ get 4 >le ] map concat >byte-array ;
+: md5>checksum ( md5 -- bytes ) state>> uint-array>byte-array-le ;
-PRIVATE>
+M: md5-state clone ( md5 -- new-md5 )
+ call-next-method
+ [ clone ] change-state
+ [ clone ] change-old-state ;
-SINGLETON: md5
+M: md5-state get-checksum ( md5 -- bytes )
+ clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri
+ [ [ checksum-block ] curry each ] [ md5>checksum ] bi ;
-INSTANCE: md5 stream-checksum
+M: md5 checksum-stream ( stream checksum -- byte-array )
+ drop
+ [ <md5-state> ] dip add-checksum-stream get-checksum ;
-M: md5 checksum-stream ( stream -- byte-array )
- drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;
+PRIVATE>
projects / factor.git / blobdiff