steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

contrib/crypto cleanup

erg 2006-09-07 20:15:41 +00:00
parent ebe493173a
commit 6fd71439d6
7 changed files with 45 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
contrib/crypto/base64.factor
View File

@ -10,7 +10,6 @@ IN: crypto-internals
#! count the number of elem at the end of the seq #! count the number of elem at the end of the seq
0 swap (count-end) drop nip ; 0 swap (count-end) drop nip ;
: ch>base64 ( ch -- ch ) : ch>base64 ( ch -- ch )
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ; "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
@ -27,7 +26,7 @@ IN: crypto-internals
be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] map-with ; be> 4 [ 3 swap - -6 * shift HEX: 3f bitand ch>base64 ] map-with ;
: decode4 ( str -- str ) : 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 ) : >base64-rem ( str -- str )
[ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ; [ 3 0 pad-right encode3 ] keep length 1+ head 4 CHAR: = pad-right ;
@ -36,9 +35,10 @@ IN: crypto
: >base64 ( str -- str ) : >base64 ( str -- str )
#! cut string into two pieces, convert 3 bytes at a time #! cut string into two pieces, convert 3 bytes at a time
#! pad string with = when not enough bits #! 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 ; ] "" make ;
: base64> ( str -- str ) : base64> ( str -- str )

10
contrib/crypto/common.factor
View File

@ -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 ! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
: preprocess-plaintext ( string big-endian? -- padded-string ) : preprocess-plaintext ( string big-endian? -- padded-string )
swap [ >r >sbuf r> over [
dup % HEX: 80 , HEX: 80 ,
dup length HEX: 3f bitand calculate-pad-length 0 <string> % dup length HEX: 3f bitand calculate-pad-length 0 <string> %
dup length 3 shift 8 >r rot r> swap [ >be ] [ >le ] if % length 3 shift 8 rot [ >be ] [ >le ] if %
] "" make nip ; ] "" 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 : shift-mod ( n s w -- n ) >r shift r> 1 swap shift 1 - bitand ; inline
IN: crypto IN: crypto

13
contrib/crypto/crc32.factor
View File

@ -6,16 +6,17 @@ IN: crypto-internals
: crc32-init ( -- table ) : crc32-init ( -- table )
256 [ 256 [
8 [ 8 [
dup 1 bitand 0 > dup 1 bitand zero? >r -1 shift r> [ crc32-polynomial bitxor ] unless
[ -1 shift crc32-polynomial bitxor ] [ -1 shift ] if
] times ] times
] map ; ] 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 ) : calc-crc32 ( ch crc -- crc )
over bitxor HEX: ff bitand crc32-table get nth swap -8 shift bitxor ; dupd bitxor HEX: ff bitand crc32-table get nth swap -8 shift bitxor ;
IN: crypto 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 ;

25
contrib/crypto/md5.factor
View File

@ -22,22 +22,12 @@ SYMBOL: old-d
old-c c update-old-new old-c c update-old-new
old-d d 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 ! Let [abcd k s i] denote the operation
! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s) ! 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 -- ) : (ABCD) ( s i x vars result -- )
#! bits to shift, input to float-sin, x, func #! bits to shift, input to float-sin, x, func
@ -148,17 +138,18 @@ SYMBOL: old-d
S41 61 pick 4 nth-int [ I ] ABCD S41 61 pick 4 nth-int [ I ] ABCD
S42 62 pick 11 nth-int [ I ] DABC S42 62 pick 11 nth-int [ I ] DABC
S43 63 pick 2 nth-int [ I ] CDAB 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 : get-md5 ( -- str )
drop ; [ [ a b c d ] [ get 4 >le % ] each ] "" make ;
IN: crypto IN: crypto
: string>md5 ( string -- md5 ) : string>md5 ( string -- md5 )
[ [
initialize-md5 f preprocess-plaintext initialize-md5 f preprocess-plaintext
dup length num-blocks [ 2dup get-block process-md5-block ] repeat 64 group [ process-md5-block ] each get-md5
drop get-md5
] with-scope ; ] with-scope ;
: string>md5str ( string -- str ) string>md5 hex-string ; : string>md5str ( string -- str ) string>md5 hex-string ;

2
contrib/crypto/miller-rabin.factor
View File

@ -9,7 +9,7 @@ SYMBOL: composite
SYMBOL: count SYMBOL: count
SYMBOL: trials 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 ) : (factor-2s) ( s n -- s n )
dup 2 mod 0 = [ -1 shift >r 1+ r> (factor-2s) ] when ; dup 2 mod 0 = [ -1 shift >r 1+ r> (factor-2s) ] when ;

10
contrib/crypto/rc4.factor
View File

@ -10,25 +10,19 @@ SYMBOL: key
SYMBOL: l 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 ! key scheduling algorithm, initialize s
: ksa ( -- ) : ksa ( -- )
256 [ ] map s set 256 [ ] map s set
0 j set 0 j set
256 [ 256 [
dup s get nth j get + over l get mod key get nth + 255 bitand j set 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 ; ] repeat ;
: generate ( -- n ) : generate ( -- n )
i get 1+ 255 bitand i set i get 1+ 255 bitand i set
j get i get s get nth + 255 bitand j 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 ; i get s get nth j get s get nth + 255 bitand s get nth ;
IN: crypto IN: crypto

62
contrib/crypto/sha1.factor
View File

@ -17,8 +17,9 @@ SYMBOL: E
SYMBOL: w SYMBOL: w
SYMBOL: K SYMBOL: K
: reset-w ( -- ) : reset-w ( -- ) 80 <vector> w set ; inline
80 <vector> w set ; : get-wth ( n -- wth ) w get nth ; inline
: shift-wth ( n -- x ) get-wth 1 32 bitroll ; inline
: initialize-sha1 ( -- ) : initialize-sha1 ( -- )
HEX: 67452301 dup h0 set A set HEX: 67452301 dup h0 set A set
@ -26,7 +27,6 @@ SYMBOL: K
HEX: 98badcfe dup h2 set C set HEX: 98badcfe dup h2 set C set
HEX: 10325476 dup h3 set D set HEX: 10325476 dup h3 set D set
HEX: c3d2e1f0 dup h4 set E set HEX: c3d2e1f0 dup h4 set E set
reset-w
[ [
20 [ HEX: 5a827999 , ] times 20 [ HEX: 5a827999 , ] times
20 [ HEX: 6ed9eba1 , ] times 20 [ HEX: 6ed9eba1 , ] times
@ -34,12 +34,6 @@ SYMBOL: K
20 [ HEX: ca62c1d6 , ] times 20 [ HEX: ca62c1d6 , ] times
] { } make K set ; ] { } 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)) ! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
: sha1-W ( t -- W_t ) : sha1-W ( t -- W_t )
dup 3 - get-wth 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 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 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) ! 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 ) : sha1-f ( B C D t -- f_tbcd )
#! Maybe use dispatch
20 /i 20 /i
{ {
{ [ dup 0 = ] [ drop >r over bitnot r> bitand >r bitand r> bitor ] } { [ dup 0 = ] [ drop >r over bitnot r> bitand >r bitand r> bitor ] }
@ -75,14 +55,10 @@ SYMBOL: K
{ [ dup 3 = ] [ drop bitxor bitxor ] } { [ dup 3 = ] [ drop bitxor bitxor ] }
} cond ; } cond ;
: make-w ( -- ) : make-w ( str -- )
! compute w, steps a-b of RFC 3174, section 6.1 #! compute w, steps a-b of RFC 3174, section 6.1
80 [ dup 16 < [ 16 [ nth-int-be w get push ] each-with
[ nth-int-be w get push ] 2keep 16 80 dup <slice> [ sha1-W w get push ] each ;
] [
dup sha1-W w get push
] if
] repeat ;
: init-letters ( -- ) : init-letters ( -- )
! step c of RFC 3174, section 6.1 ! step c of RFC 3174, section 6.1
@ -92,26 +68,27 @@ SYMBOL: K
h3 get D set h3 get D set
h4 get E 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); ! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
[ [
[ B get C get D get ] keep sha1-f , [ B get C get D get ] keep sha1-f ,
dup get-wth , dup get-wth ,
dup K get nth , K get nth ,
A get 5 32 bitroll , A get 5 32 bitroll ,
E get , E get ,
] { } make sum 4294967295 bitand ; inline ] { } make sum 4294967295 bitand ; inline
: set-vars ( -- ) : set-vars ( temp -- )
! E = D; D = C; C = S^30(B); B = A; A = TEMP; ! E = D; D = C; C = S^30(B); B = A; A = TEMP;
D get E set D get E set
C get D set C get D set
B get 30 32 bitroll C set B get 30 32 bitroll C set
A get B set ; A get B set
A set ;
: calculate-letters ( -- ) : calculate-letters ( -- )
! step d of RFC 3174, section 6.1 ! 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 ( -- ) : update-hs ( -- )
! step e of RFC 3174, section 6.1 ! step e of RFC 3174, section 6.1
@ -121,20 +98,19 @@ SYMBOL: K
D h3 update-old-new D h3 update-old-new
E h4 update-old-new ; E h4 update-old-new ;
: process-sha1-block ( block -- ) : process-sha1-block ( str -- )
make-w init-letters calculate-letters update-hs drop ; make-w init-letters calculate-letters update-hs ;
: get-sha1 ( -- str ) : get-sha1 ( -- str )
[ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ; [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
IN: crypto IN: crypto
: string>sha1 ( string -- sha1 ) : string>sha1 ( str -- sha1 )
[ [
initialize-sha1 t preprocess-plaintext initialize-sha1 t preprocess-plaintext
dup length num-blocks [ reset-w 2dup get-block process-sha1-block ] repeat 64 group [ reset-w process-sha1-block ] each get-sha1
drop get-sha1
] with-scope ; ] 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 ; : stream>sha1 ( stream -- sha1 ) contents string>sha1 ;
: file>sha1 ( file -- sha1 ) <file-reader> stream>sha1 ; : file>sha1 ( file -- sha1 ) <file-reader> stream>sha1 ;