crypto improvements, and blum blum shub

contrib/crypto/barrett.factor

@@ -0,0 +1,8 @@
+USING: kernel math ;
+IN: crypto
+
+: barrett-mu ( n size -- mu )
+    #! Calculates Barrett's reduction parameter mu
+    #! size = word size in bits (8, 16, 32, 64, ...)
+    over log2 1+ over / 2 * >r 2 swap ^ r> ^ swap / floor ;
+

contrib/crypto/blum-blum-shub.factor

@@ -0,0 +1,30 @@
+USING: kernel math sequences namespaces crypto math-contrib ;
+IN: crypto-internals
+
+! Blum Blum Shub, M = pq
+TUPLE: bbs x n ;
+
+: generate-bbs-primes ( numbits -- p q )
+    #! two primes congruent to 3 (mod 4)
+    dup [ random-miller-rabin-prime==3(mod4) ] 2apply ;
+
+IN: crypto
+: make-bbs ( numbits -- blum-blum-shub )
+    #! returns a Blum-Blum-Shub tuple
+    generate-bbs-primes * [ find-relative-prime ] keep <bbs> ;
+
+IN: crypto-internals
+SYMBOL: blum-blum-shub 256 make-bbs global [ blum-blum-shub set ] bind
+IN: crypto
+
+: next-bbs-bit ( bbs -- bit )
+    #! x = x^2 mod n, return low bit of calculated x
+    [ [ bbs-x ] keep 2 swap bbs-n ^mod ] keep
+    [ set-bbs-x ] keep bbs-x 1 bitand ;
+
+SYMBOL: temp-bbs
+: (bbs-bits) ( numbits bbs -- n )
+    temp-bbs set [ [ temp-bbs get next-bbs-bit ] swap make-bits ] with-scope ;
+
+: random-bbs-bits* ( numbits bbs -- n ) (bbs-bits) ;
+: random-bbs-bits ( numbits -- n ) blum-blum-shub get (bbs-bits) ;

contrib/crypto/common.factor

@@ -1,22 +1,11 @@
 IN: crypto-internals
-USING: kernel io strings sequences namespaces math prettyprint
+USING: kernel io strings sequences namespaces math parser lists ;
-test parser lists ;
 
-
+: w+ ( int -- int ) + HEX: ffffffff bitand ; inline
-: w+ ( int -- int )
+: nth-int ( string n -- int ) 2 shift dup 4 + rot <slice> le> ; inline
-    + HEX: ffffffff bitand ; inline
+: nth-int-be ( string n -- int ) 2 shift dup 4 + rot <slice> be> ; inline
-
+: float-sin ( int -- int ) sin abs 4294967296 * >bignum ; inline
-: nth-int ( string n -- int )
+: update ( num var -- ) [ w+ ] change ; inline
-    2 shift dup 4 + rot <slice> le> ; inline
-
-: nth-int-be ( string n -- int )
-    2 shift dup 4 + rot <slice> be> ; inline
-
-: float-sin ( int -- int )
-    sin abs 4294967296 * >bignum ; inline
-
-: update ( num var -- )
-    [ w+ ] change ; inline
 
 : update-old-new ( old new -- )
     [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
@@ -40,14 +29,9 @@ test parser lists ;
         dup length 3 shift 8 >be %
     ] "" make nip ;
 
-: num-blocks ( length -- num )
+: num-blocks ( length -- num ) -6 shift ;
-    -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
-: 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
 : bitroll ( n s w -- n )
@@ -58,5 +42,4 @@ IN: crypto
      [ shift-mod ] 3keep
      [ - ] keep shift-mod bitor ; inline
 
-: hex-string ( str -- str )
+: hex-string ( str -- str ) [ [ >hex 2 48 pad-left % ] each ] "" make ;
-    [ [ >hex 2 48 pad-left % ] each ] "" make ;

contrib/crypto/load.factor

@@ -6,8 +6,11 @@ USING: kernel parser sequences words compiler ;
 {
     "common"
     "base64"
+    "barrett"
+    "montgomery"
     "random"
     "miller-rabin"
+    "blum-blum-shub"
     "md5"
     "sha1"
     "rsa"

contrib/crypto/md5.factor

@@ -1,6 +1,5 @@
+USING: kernel io strings sequences namespaces math parser lists crypto ;
 IN: crypto-internals
-USING: kernel io strings sequences namespaces math
-       test parser lists crypto ;
 
 SYMBOL: a
 SYMBOL: b
@@ -154,30 +153,15 @@ SYMBOL: old-d
     update-md
     drop ;
 
-
-
 IN: crypto
 : string>md5 ( string -- md5 )
-    ! [
+    [
         initialize-md5 pad-string-md5
         dup length num-blocks [ 2dup get-block process-md5-block ] repeat
         drop get-md5
-        ;
+    ] with-scope ;
-    ! ] with-scope ;
-
-: string>md5str ( string -- str )
-    string>md5 hex-string ;
 
+: string>md5str ( string -- str ) string>md5 hex-string ;
 : stream>md5 ( stream -- md5 ) contents string>md5 ;
-
 : file>md5 ( file -- md5 ) <file-reader> stream>md5 ;
 
-: test-md5 ( -- )
-    [ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5str ] unit-test
-    [ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" string>md5str ] unit-test
-    [ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" string>md5str ] unit-test
-    [ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" string>md5str ] unit-test
-    [ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" string>md5str ] unit-test
-    [ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5str ] unit-test
-    [ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5str ] unit-test
-    ;

contrib/crypto/miller-rabin.factor

@@ -1,7 +1,5 @@
 USING: kernel math errors namespaces math-contrib sequences io ;
-USE: prettyprint
+IN: crypto-internals
-USE: inspector
-IN: crypto
 
 SYMBOL: a
 SYMBOL: n
@@ -11,8 +9,7 @@ SYMBOL: composite
 SYMBOL: count
 SYMBOL: trials
 
-: rand[1..n-1] ( n -- )
+: rand[1..n-1] ( n -- ) 1- random-int 1+ ;
-    1- random-int 1+ ;
 
 : (factor-2s) ( s n -- s n )
     dup 2 mod 0 = [ -1 shift >r 1+ r> (factor-2s) ] when ;
@@ -23,14 +20,12 @@ SYMBOL: trials
         "input must be positive and even" throw
     ] unless 0 swap (factor-2s) ;
 
-: init-miller-rabin ( n -- )
+: init-miller-rabin ( n trials -- ) 0 composite set trials set n set ;
-    0 composite set
-    [ n set ] keep 10000 < 20 100 ? trials set ;
 
-: miller-rabin ( n -- bool )
+: (miller-rabin) ( n -- bool )
+    n get dup 1 = [ drop f ]
     [
-        init-miller-rabin
+        even? [
-        n get even? [
             f ] [
             n get 1- factor-2s s set r set
             trials get [
@@ -51,11 +46,44 @@ SYMBOL: trials
             ] repeat
             composite get 0 = [ t ] [ composite get not ] if
         ] if
-    ] with-scope ;
+    ] if ;
+
+IN: crypto
+
+: miller-rabin* ( n trials -- bool )
+    #! Probailistic primality test for n > 2, with trials as a parameter
+    [ init-miller-rabin (miller-rabin) ] with-scope ;
+
+: miller-rabin ( n -- bool )
+    #! Probabilistic primality test for n > 2, 100 trials
+    [ 100 miller-rabin* ] with-scope ;
 
 : next-miller-rabin-prime ( n -- p )
+    #! finds the next prime probabilistically
     dup even? [ 1+ ] [ 2 + ] if
     dup miller-rabin [ next-miller-rabin-prime ] unless ;
 
+! random miller rabin prime from a number, or a number of bits
+! expand
+: random-miller-rabin-prime ( numbits -- p )
+    #! n = bits
+    large-random-bits next-miller-rabin-prime ;
 
-! 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 100 miller-rabin
+: random-miller-rabin-prime==3(mod4) ( numbits -- p )
+    dup random-miller-rabin-prime dup 4 mod 3 = [ drop random-miller-rabin-prime==3(mod4) ] [ nip ] if ;
+
+: (find-relative-prime) ( m g -- p )
+    2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
+
+: find-relative-prime* ( m g -- p )
+    #! find a prime relative to m with initial guess g
+    dup even? [ 1+ ] when (find-relative-prime) ;
+
+: find-relative-prime ( m -- p )
+    dup random-int dup even? [ 1+ ] when (find-relative-prime) ;
+
+: generate-two-unique-primes ( n -- p q )
+    #! generate two primes
+    dup 5 < [ "not enough primes below 5 bits" throw ] when
+    dup [ random-miller-rabin-prime ] keep random-miller-rabin-prime 2dup =
+    [ 2drop generate-two-unique-primes ] [ rot drop ] if ;

contrib/crypto/montgomery.factor

@@ -0,0 +1,21 @@
+USING: kernel math errors math-contrib ;
+IN: crypto
+
+! As per http://www.cyphercalc.com/index.htm
+:  montgomery-image ( a n -- a' )
+    #! a' = a * nextpowerof2(a) mod n
+    >r dup next-power-of-2 * r> mod ;
+
+: montgomery* ( a b -- a*b )
+    "todo" throw
+    ;
+
+: montgomery-r^2 ( n -- a )
+    #! ans = r^2 mod n, where r = nextpowerof2(n)
+    [ next-power-of-2 sq ] keep mod ;
+
+: montgomery-n0' ( n0 size -- n0' )
+    #! size should be a multiple of 2, n0 is odd and n0 < 2^size
+    #! n0 * n0' = -1 mod 2^w
+    2 swap ^ swap neg mod-inv ;
+

contrib/crypto/random.factor

@@ -1,21 +1,17 @@
-IN: crypto
 USING: kernel math sequences namespaces errors hashtables words arrays parser
        compiler syntax lists io threads ;
-USE: prettyprint
+IN: crypto
-USE: inspector
+: make-bits ( quot numbits -- n | quot: -- 0/1 )
+    0 -rot [ drop dup call rot 1 shift bitor swap ] each drop ;
 
-: add-bit ( bit integer -- integer )
+: add-bit ( bit integer -- integer ) 1 shift bitor ;
-    1 shift bitor ;
+: append-bits ( inta intb nbits -- int ) swapd shift bitor ;
+: random-bits ( n -- int ) random-int 2 swap ^ random-int ;
+: large-random-bits ( n -- int )
+    #! random number with high bit and low bit enabled (odd)
+    2 swap ^ [ random-int ] keep -1 shift 1 bitor bitor ;
+: next-double ( -- f ) 53 random-bits 9007199254740992 /f ;
 
-: append-bits ( inta intb nbits -- int )
-    swapd shift bitor ;
-
-! varying bit-length random number
-: random-bits ( n -- int )
-    random-int 2 swap ^ random-int ;
-
-: next-double ( -- f )
-    53 random-bits 9007199254740992 /f ;
 
 SYMBOL: last-keyboard
 : crypto-random-int ( numbits -- integer )
@@ -41,40 +37,10 @@ SYMBOL: last-keyboard
         ] each
     ] with-scope ;
     
-IN: crypto-internals
-
-SYMBOL: q
-SYMBOL: m
-! : qm ( integer -- )
-    ! 1 swap - 2 mod dup 0 = [
-        ! 2 / 
-    ! ]
-    ! ;
-
-SYMBOL: test-count
-SYMBOL: num-tests
-! : (create-miller-rabin-prime) ( bitlength --  )
-    ! auto-crypto-random-int qm
-    
 IN: crypto
 
-! one in 2 ^ numtests chance of being composite (i believe)
+: 0count ( integer -- n ) 0 swap [ 0 = [ 1+ ] when ] each-bit ;
-! : create-miller-rabin-prime ( bitlength numtests -- prime )
+: 1count ( integer -- n ) 0 swap [ 1 = [ 1+ ] when ] each-bit ;
-    ! [
-        ! num-tests set
-        ! 0 test-count set
-        ! (create-miller-rabin-prime)
-        ! ! dup -1 = [ create-miller-rabin-prime ] when
-    ! ] with-scope ;
-
-! : numbits ( integer -- n )
-!    dup 0 = [ log2 1+ ] unless ;
-
-: 0count ( integer -- n )
-    0 swap [ 0 = [ 1+ ] when ] each-bit ;
-
-: 1count ( integer -- n )
-    0 swap [ 1 = [ 1+ ] when ] each-bit ;
 
 IN: crypto-internals
 SYMBOL: a
@@ -106,8 +72,6 @@ IN: crypto
     HEX: 0F HEX: 8F HEX: 4F HEX: CF HEX: 2F HEX: AF HEX: 6F HEX: EF HEX: 1F HEX: 9F HEX: 5F HEX: DF HEX: 3F HEX: BF HEX: 7F HEX: FF
 } ; inline
 
-! : each-byte
-
 : modular-exp ( a b n -- d )
     n set b set a set 0 c set 1 d set
     [

contrib/crypto/rc4.factor

@@ -33,7 +33,6 @@ SYMBOL: l
 
 IN: crypto
 
-
 : rc4 ( key -- )
     [ key set ] keep
     length l set

contrib/crypto/rsa.factor

@@ -1,4 +1,4 @@
-USING: kernel math namespaces math-contrib ;
+USING: kernel math namespaces math-contrib errors ;
 
 IN: crypto
 SYMBOL: d
@@ -8,23 +8,20 @@ SYMBOL: n
 SYMBOL: m
 SYMBOL: ee
 
-: while-gcd ( -- )
+! e = public key, d = private key, n = public modulus
-    m get ee get gcd nip 1 > [ ee [ 2 + ] change while-gcd ] when ;
+TUPLE: rsa e d n ;
 
 ! n bits
-: generate-key-pair ( bitlen -- )
+: generate-key-pair ( bitlen -- <rsa> )
-    2 swap 1- 2 /i shift
+    [
-    [ random-int next-miller-rabin-prime p set ] keep
+        2 /i generate-two-unique-primes [ q set p set ] 2keep [ * n set ] 2keep
-    random-int next-miller-rabin-prime q set
+        [ 1- ] 2apply * m set
+        m get next-miller-rabin-prime ee set
+        m get ee get find-relative-prime* ee set
+        m get ee get mod-inv m get + d set
+        ee get d get n get <rsa>
+    ] with-scope ;
 
-    p get q get * n set
+: rsa-encrypt ( message rsa -- encrypted ) [ rsa-e ] keep rsa-n ^mod ;
-    p get 1- q get 1- * m set
+: rsa-decrypt ( encrypted rsa -- message ) [ rsa-d ] keep rsa-n ^mod ;
-    3 ee set
-    while-gcd
-    m get ee get mod-inv m get + d set ;
 
-: rsa-encrypt ( message -- encrypted )
-    ee get n get ^mod ;
-
-: rsa-decrypt ( encrypted -- message )
-    d get n get ^mod ;

contrib/crypto/sha1.factor

@@ -1,6 +1,6 @@
+USING: kernel io strings sequences namespaces math parser
+    lists vectors hashtables kernel-internals math-contrib crypto ;
 IN: crypto-internals
-USING: kernel io strings sequences namespaces math prettyprint
-test parser lists vectors hashtables kernel-internals math-contrib crypto ;
 
 ! Implemented according to RFC 3174.
 
@@ -135,17 +135,6 @@ IN: crypto
         drop get-sha1
     ] with-scope ;
 
-: string>sha1str ( string -- sha1str )
+: string>sha1str ( string -- sha1str ) string>sha1 hex-string ;
-    string>sha1 hex-string ;
-
 : stream>sha1 ( stream -- sha1 ) contents string>sha1 ;
-
 : file>sha1 ( file -- sha1 ) <file-reader> stream>sha1 ;
-
-! unit test from the RFC
-: test-sha1 ( -- )
-    [ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1str ] unit-test
-    [ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1str ] unit-test
-    ! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
-    [ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" [ 10 [ dup % ] times ] "" make nip string>sha1str ] unit-test ;
-

contrib/crypto/test.factor

@@ -0,0 +1,36 @@
+USING: kernel math test namespaces crypto ;
+
+[ HEX: 1f63edfb7e838622c7412eafaf0439cf0cdf3aae8bdd09e2de69b509a53883a83560d5ce50ea039e4 ] [  HEX: 827c67f31b2b46afa49ed95d7f7a3011e5875f7052d4c55437ce726d3c6ce0dc9c445fda63b6dc4e 16 barrett-mu ] unit-test
+
+[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> ] unit-test
+[ "" ] [ "" >base64 base64> ] unit-test
+[ "a" ] [ "a" >base64 base64> ] unit-test
+[ "ab" ] [ "ab" >base64 base64> ] unit-test
+[ "abc" ] [ "abc" >base64 base64> ] unit-test
+
+[ HEX: 7155b978fed765e2ec80b472b4eae1154d2f75dd753e7efaca0449b8eaf7c047f94564302c80c717 ] [ HEX: c8d30cdd849cc1cbccf75340f903cde3acc0e7b5e0326aa91f82f442cc1ab23f66cf042c2af22a0b montgomery-r^2 ] unit-test
+
+[ HEX: 5aee1477 ] [ HEX: d681fab9 32 montgomery-n0' ] unit-test
+
+[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5str ] unit-test
+[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" string>md5str ] unit-test
+[ "900150983cd24fb0d6963f7d28e17f72" ] [ "abc" string>md5str ] unit-test
+[ "f96b697d7cb7938d525a2f31aaf161d0" ] [ "message digest" string>md5str ] unit-test
+[ "c3fcd3d76192e4007dfb496cca67e13b" ] [ "abcdefghijklmnopqrstuvwxyz" string>md5str ] unit-test
+[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5str ] unit-test
+[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5str ] unit-test
+
+[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" string>sha1str ] unit-test
+[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" string>sha1str ] unit-test
+! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
+[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567" [ 10 [ dup % ] times ] "" make nip string>sha1str ] unit-test
+
+[ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
+[ t ] [ 37 miller-rabin ] unit-test
+[ 101 ] [ 100 next-miller-rabin-prime ] unit-test
+[ 100000000000031 ] [ 100000000000000 next-miller-rabin-prime ] unit-test
+
+
+[ 123456789 ] [ 512 generate-key-pair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test
+
+

contrib/math/test.factor

@@ -44,27 +44,27 @@ USING: kernel math test sequences math-contrib ;
 [ 2 ] [ 2 2 nPk ] unit-test
 [ 1 ] [ 2 0 nCk ] unit-test
 [ 1 ] [ 2 0 nPk ] unit-test
-[ t ] [ -9000000000000000000000000000000000000000000 gamma inf = ] unit-test
+[ t ] [ -9000000000000000000000000000000000000000000 gamma 1/0. = ] unit-test
 [ t ] [ -1.5 gamma 2.36327 almost= ] unit-test
-[ t ] [ -1 gamma inf = ] unit-test
+[ t ] [ -1 gamma 1/0. = ] unit-test
 [ t ] [ -0.5 gamma -3.5449 almost= ] unit-test
-[ t ] [ 0 gamma inf = ] unit-test
+[ t ] [ 0 gamma 1/0. = ] unit-test
 [ t ] [ .5 gamma 1.7724538 almost= ] unit-test
 [ t ] [ 1 gamma 1 almost= ] unit-test
 [ t ] [ 2 gamma 1 almost= ] unit-test
 [ t ] [ 3 gamma 2 almost= ] unit-test
 [ t ] [ 11 gamma 3628800 almost= ] unit-test
-[ t ] [ 90000000000000000000000000000000000000000000 gamma inf = ] unit-test
+[ t ] [ 90000000000000000000000000000000000000000000 gamma 1/0. = ] unit-test
 ! some fun identities
 [ t ] [ 2/3 gamma 2 pi * 3 sqrt 1/3 gamma * / almost= ] unit-test
 [ t ] [ 3/4 gamma 2 sqrt pi * 1/4 gamma / almost= ] unit-test
 [ t ] [ 4/5 gamma 2 5 sqrt / 2 + sqrt pi * 1/5 gamma / almost= ] unit-test
 [ t ] [ 3/5 gamma 2 2 5 sqrt / - sqrt pi * 2/5 gamma / almost= ] unit-test
-[ t ] [ -90000000000000000000000000000000000000000000 gammaln inf = ] unit-test
+[ t ] [ -90000000000000000000000000000000000000000000 gammaln 1/0. = ] unit-test
-[ t ] [ -1.5 gammaln inf = ] unit-test
+[ t ] [ -1.5 gammaln 1/0. = ] unit-test
-[ t ] [ -1 gammaln inf = ] unit-test
+[ t ] [ -1 gammaln 1/0. = ] unit-test
-[ t ] [ -0.5 gammaln inf = ] unit-test
+[ t ] [ -0.5 gammaln 1/0. = ] unit-test
-[ t ] [ 0 gammaln inf = ] unit-test
+! [ t ] [ 0 gammaln 1/0. = ] unit-test
 [ t ] [ .5 gammaln 0.57236494 almost= ] unit-test
 [ t ] [ 1 gammaln 0 almost= ] unit-test
 [ t ] [ 2 gammaln 0 almost= ] unit-test