contrib/crypto cleanup
erg
parent
ebe493173a
commit
6fd71439d6
|
|
@ -10,7 +10,6 @@ IN: crypto-internals
|
|||
#! count the number of elem at the end of the seq
|
||||
0 swap (count-end) drop nip ;
|
||||
|
||||
|
||||
: ch>base64 ( ch -- ch )
|
||||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
|
||||
|
||||
|
|
@ -27,7 +26,7 @@ IN: crypto-internals
|
|||
be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] map-with ;
|
||||
|
||||
: decode4 ( str -- str )
|
||||
[ base64>ch ] map 0 4 [ pick nth swap 6 shift bitor ] each nip 3 >be ;
|
||||
[ base64>ch ] map 0 [ swap 6 shift bitor ] reduce 3 >be ;
|
||||
|
||||
: >base64-rem ( str -- str )
|
||||
[ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ;
|
||||
|
|
@ -36,9 +35,10 @@ IN: crypto
|
|||
: >base64 ( str -- str )
|
||||
#! cut string into two pieces, convert 3 bytes at a time
|
||||
#! pad string with = when not enough bits
|
||||
dup length dup 3 mod - swap cut swap
|
||||
[ length dup 3 mod - ] keep cut swap
|
||||
[
|
||||
3 group [ encode3 % ] each dup empty? [ drop ] [ >base64-rem % ] if
|
||||
3 group [ encode3 % ] each
|
||||
dup empty? [ drop ] [ >base64-rem % ] if
|
||||
] "" make ;
|
||||
|
||||
: base64> ( str -- str )
|
||||
|
|
|
|||
|
|
@ -15,14 +15,12 @@ USING: kernel io strings sequences namespaces math parser ;
|
|||
|
||||
! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
|
||||
: preprocess-plaintext ( string big-endian? -- padded-string )
|
||||
swap [
|
||||
dup % HEX: 80 ,
|
||||
>r >sbuf r> over [
|
||||
HEX: 80 ,
|
||||
dup length HEX: 3f bitand calculate-pad-length 0 <string> %
|
||||
dup length 3 shift 8 >r rot r> swap [ >be ] [ >le ] if %
|
||||
] "" make nip ;
|
||||
length 3 shift 8 rot [ >be ] [ >le ] if %
|
||||
] "" make dupd nappend ;
|
||||
|
||||
: num-blocks ( length -- num ) -6 shift ;
|
||||
: get-block ( string num -- string ) 6 shift dup 64 + rot <slice> ;
|
||||
: shift-mod ( n s w -- n ) >r shift r> 1 swap shift 1 - bitand ; inline
|
||||
|
||||
IN: crypto
|
||||
|
|
|
|||
|
|
@ -6,16 +6,17 @@ IN: crypto-internals
|
|||
: crc32-init ( -- table )
|
||||
256 [
|
||||
8 [
|
||||
dup 1 bitand 0 >
|
||||
[ -1 shift crc32-polynomial bitxor ] [ -1 shift ] if
|
||||
dup 1 bitand zero? >r -1 shift r> [ crc32-polynomial bitxor ] unless
|
||||
] times
|
||||
] map ;
|
||||
|
||||
SYMBOL: crc32-table crc32-init global [ crc32-table set ] bind
|
||||
SYMBOL: crc32-table
|
||||
crc32-init crc32-table set-global
|
||||
|
||||
: calc-crc32 ( crc ch -- crc )
|
||||
over bitxor HEX: ff bitand crc32-table get nth swap -8 shift bitxor ;
|
||||
: calc-crc32 ( ch crc -- crc )
|
||||
dupd bitxor HEX: ff bitand crc32-table get nth swap -8 shift bitxor ;
|
||||
|
||||
IN: crypto
|
||||
: >crc32 ( seq -- n ) HEX: ffffffff [ swap [ calc-crc32 ] each ] keep bitxor ;
|
||||
: >crc32 ( seq -- n )
|
||||
>r HEX: ffffffff dup r> [ calc-crc32 ] each bitxor ;
|
||||
|
||||
|
|
|
|||
|
|
@ -22,22 +22,12 @@ SYMBOL: old-d
|
|||
old-c c update-old-new
|
||||
old-d d update-old-new ;
|
||||
|
||||
: get-md5-debug ( -- str )
|
||||
[ [ a b c d ] [ get 4 >be % ] each ] "" make ;
|
||||
|
||||
: get-md5 ( -- str )
|
||||
[ [ a b c d ] [ get 4 >le % ] each ] "" make ;
|
||||
|
||||
: get-old-md5-debug ( -- str )
|
||||
[ [ old-a old-b old-c old-d ] [ get 4 >be % ] each ] "" make ;
|
||||
|
||||
|
||||
! Let [abcd k s i] denote the operation
|
||||
! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
|
||||
|
||||
: 2to4 dup second get over third get pick fourth get ;
|
||||
: 1to4 dup second get over third get pick fourth get ;
|
||||
|
||||
: (F) ( vars func -- vars result ) >r 2to4 r> call ; inline
|
||||
: (F) ( vars func -- vars result ) >r 1to4 r> call ; inline
|
||||
|
||||
: (ABCD) ( s i x vars result -- )
|
||||
#! bits to shift, input to float-sin, x, func
|
||||
|
|
@ -148,17 +138,18 @@ SYMBOL: old-d
|
|||
S41 61 pick 4 nth-int [ I ] ABCD
|
||||
S42 62 pick 11 nth-int [ I ] DABC
|
||||
S43 63 pick 2 nth-int [ I ] CDAB
|
||||
S44 64 pick 9 nth-int [ I ] BCDA
|
||||
S44 64 rot 9 nth-int [ I ] BCDA
|
||||
update-md ;
|
||||
|
||||
update-md
|
||||
drop ;
|
||||
: get-md5 ( -- str )
|
||||
[ [ a b c d ] [ get 4 >le % ] each ] "" make ;
|
||||
|
||||
IN: crypto
|
||||
|
||||
: string>md5 ( string -- md5 )
|
||||
[
|
||||
initialize-md5 f preprocess-plaintext
|
||||
dup length num-blocks [ 2dup get-block process-md5-block ] repeat
|
||||
drop get-md5
|
||||
64 group [ process-md5-block ] each get-md5
|
||||
] with-scope ;
|
||||
|
||||
: string>md5str ( string -- str ) string>md5 hex-string ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ SYMBOL: composite
|
|||
SYMBOL: count
|
||||
SYMBOL: trials
|
||||
|
||||
: rand[1..n-1] ( n -- ) 1- random-int 1+ ;
|
||||
: rand[1..n-1] ( m -- n ) 1- random-int 1+ ;
|
||||
|
||||
: (factor-2s) ( s n -- s n )
|
||||
dup 2 mod 0 = [ -1 shift >r 1+ r> (factor-2s) ] when ;
|
||||
|
|
|
|||
|
|
@ -10,25 +10,19 @@ SYMBOL: key
|
|||
SYMBOL: l
|
||||
|
||||
|
||||
: swap-ij ( i j seq -- )
|
||||
[
|
||||
s set j set i set
|
||||
i get s get nth j get s get nth i get s get set-nth j get s get set-nth
|
||||
] with-scope ;
|
||||
|
||||
! key scheduling algorithm, initialize s
|
||||
: ksa ( -- )
|
||||
256 [ ] map s set
|
||||
0 j set
|
||||
256 [
|
||||
dup s get nth j get + over l get mod key get nth + 255 bitand j set
|
||||
dup j get s get swap-ij
|
||||
dup j get s get exchange
|
||||
] repeat ;
|
||||
|
||||
: generate ( -- n )
|
||||
i get 1+ 255 bitand i set
|
||||
j get i get s get nth + 255 bitand j set
|
||||
i get j get s get swap-ij
|
||||
i get j get s get exchange
|
||||
i get s get nth j get s get nth + 255 bitand s get nth ;
|
||||
|
||||
IN: crypto
|
||||
|
|
|
|||
|
|
@ -17,8 +17,9 @@ SYMBOL: E
|
|||
SYMBOL: w
|
||||
SYMBOL: K
|
||||
|
||||
: reset-w ( -- )
|
||||
80 <vector> w set ;
|
||||
: reset-w ( -- ) 80 <vector> w set ; inline
|
||||
: get-wth ( n -- wth ) w get nth ; inline
|
||||
: shift-wth ( n -- x ) get-wth 1 32 bitroll ; inline
|
||||
|
||||
: initialize-sha1 ( -- )
|
||||
HEX: 67452301 dup h0 set A set
|
||||
|
|
@ -26,7 +27,6 @@ SYMBOL: K
|
|||
HEX: 98badcfe dup h2 set C set
|
||||
HEX: 10325476 dup h3 set D set
|
||||
HEX: c3d2e1f0 dup h4 set E set
|
||||
reset-w
|
||||
[
|
||||
20 [ HEX: 5a827999 , ] times
|
||||
20 [ HEX: 6ed9eba1 , ] times
|
||||
|
|
@ -34,12 +34,6 @@ SYMBOL: K
|
|||
20 [ HEX: ca62c1d6 , ] times
|
||||
] { } make K set ;
|
||||
|
||||
: get-wth ( n -- wth )
|
||||
w get nth ;
|
||||
|
||||
: shift-wth ( n -- )
|
||||
get-wth 1 32 bitroll ;
|
||||
|
||||
! 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
|
||||
|
|
@ -51,22 +45,8 @@ SYMBOL: K
|
|||
! 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)
|
||||
|
||||
! use this syntax eventually
|
||||
! JUMP-TABLE: f 4 ( maximum )
|
||||
! H{
|
||||
! { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
|
||||
! { 1 [ bitxor bitxor ] }
|
||||
! { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
|
||||
! { 3 [ bitxor bitxor ] }
|
||||
! } f-table set
|
||||
|
||||
! J: 0 f >r over bitnot r> bitand >r bitand r> bitor ;
|
||||
! J: 1 f bitxor bitxor ;
|
||||
! J: 2 f 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ;
|
||||
! J: 3 f bitxor bitxor ;
|
||||
|
||||
: sha1-f ( B C D t -- f_tbcd )
|
||||
#! Maybe use dispatch
|
||||
20 /i
|
||||
{
|
||||
{ [ dup 0 = ] [ drop >r over bitnot r> bitand >r bitand r> bitor ] }
|
||||
|
|
@ -75,14 +55,10 @@ SYMBOL: K
|
|||
{ [ dup 3 = ] [ drop bitxor bitxor ] }
|
||||
} cond ;
|
||||
|
||||
: make-w ( -- )
|
||||
! compute w, steps a-b of RFC 3174, section 6.1
|
||||
80 [ dup 16 < [
|
||||
[ nth-int-be w get push ] 2keep
|
||||
] [
|
||||
dup sha1-W w get push
|
||||
] if
|
||||
] repeat ;
|
||||
: make-w ( str -- )
|
||||
#! compute w, steps a-b of RFC 3174, section 6.1
|
||||
16 [ nth-int-be w get push ] each-with
|
||||
16 80 dup <slice> [ sha1-W w get push ] each ;
|
||||
|
||||
: init-letters ( -- )
|
||||
! step c of RFC 3174, section 6.1
|
||||
|
|
@ -92,26 +68,27 @@ SYMBOL: K
|
|||
h3 get D set
|
||||
h4 get E set ;
|
||||
|
||||
: inner-loop ( -- )
|
||||
: 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 ,
|
||||
dup K get nth ,
|
||||
K get nth ,
|
||||
A get 5 32 bitroll ,
|
||||
E get ,
|
||||
] { } make sum 4294967295 bitand ; inline
|
||||
|
||||
: set-vars ( -- )
|
||||
: 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 32 bitroll C set
|
||||
A get B set ;
|
||||
A get B set
|
||||
A set ;
|
||||
|
||||
: calculate-letters ( -- )
|
||||
! step d of RFC 3174, section 6.1
|
||||
80 [ inner-loop >r set-vars r> A set ] repeat ;
|
||||
80 [ inner-loop set-vars ] each ;
|
||||
|
||||
: update-hs ( -- )
|
||||
! step e of RFC 3174, section 6.1
|
||||
|
|
@ -121,20 +98,19 @@ SYMBOL: K
|
|||
D h3 update-old-new
|
||||
E h4 update-old-new ;
|
||||
|
||||
: process-sha1-block ( block -- )
|
||||
make-w init-letters calculate-letters update-hs drop ;
|
||||
: process-sha1-block ( str -- )
|
||||
make-w init-letters calculate-letters update-hs ;
|
||||
|
||||
: get-sha1 ( -- str )
|
||||
[ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
|
||||
|
||||
IN: crypto
|
||||
: string>sha1 ( string -- sha1 )
|
||||
: string>sha1 ( str -- sha1 )
|
||||
[
|
||||
initialize-sha1 t preprocess-plaintext
|
||||
dup length num-blocks [ reset-w 2dup get-block process-sha1-block ] repeat
|
||||
drop get-sha1
|
||||
64 group [ reset-w process-sha1-block ] each get-sha1
|
||||
] with-scope ;
|
||||
|
||||
: string>sha1str ( string -- sha1str ) string>sha1 hex-string ;
|
||||
: string>sha1str ( str -- sha1str ) string>sha1 hex-string ;
|
||||
: stream>sha1 ( stream -- sha1 ) contents string>sha1 ;
|
||||
: file>sha1 ( file -- sha1 ) <file-reader> stream>sha1 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue