libs/crypto/common.factor

   1 IN: crypto-internals
   2 USING: kernel io strings sequences namespaces math parser ;
   3
   4 IN: crypto
   5 : >32-bit ( n -- n ) HEX: ffffffff bitand ; inline
   6 : >64-bit ( n -- n ) HEX: ffffffffffffffff bitand ; inline
   7
   8 IN: crypto-internals
   9 : w+ ( int int -- int ) + >32-bit ; inline
  10 : nth-int ( string n -- int ) 2 shift dup 4 + rot <slice> le> ; inline
  11 : nth-int-be ( string n -- int ) 2 shift dup 4 + rot <slice> be> ; inline
  12 : update ( num var -- ) [ w+ ] change ; inline
  13
  14 : update-old-new ( old new -- )
  15     [ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
  16
  17 : calculate-pad-length ( length -- pad-length )
  18     dup 56 < 55 119 ? swap - ;
  19
  20 : preprocess-plaintext ( string big-endian? -- padded-string )
  21     #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
  22     >r >sbuf r> over [
  23         HEX: 80 ,
  24         dup length HEX: 3f bitand calculate-pad-length 0 <string> %
  25         length 3 shift 8 rot [ >be ] [ >le ] if %
  26     ] "" make dupd nappend ;
  27
  28 SYMBOL: bytes-read
  29 SYMBOL: big-endian?
  30
  31 : pad-last-block ( str big-endian? length -- str )
  32     [
  33         rot %
  34         HEX: 80 ,
  35         dup HEX: 3f bitand calculate-pad-length 0 <string> %
  36         3 shift 8 rot [ >be ] [ >le ] if %
  37     ] "" make 64 group ;
  38
  39 : shift-mod ( n s w -- n ) >r shift r> 1 swap shift 1 - bitand ; inline
  40
  41
  42 IN: crypto
  43
  44 : bitroll ( n s w -- n' )
  45      #! Roll n by s bits to the left, wrapping around after
  46      #! w bits.
  47      [ 1 - bitand ] keep
  48      over 0 < [ [ + ] keep ] when
  49      [ shift-mod ] 3keep
  50      [ - ] keep shift-mod bitor ; inline
  51
  52 : bitroll-32 ( n s -- n' ) 32 bitroll ;
  53 : bitroll-64 ( n s -- n' ) 64 bitroll ;
  54 : hex-string ( str -- str ) [ [ >hex 2 48 pad-left % ] each ] "" make ;
  55 : slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ;
  56
  57 : 4dup ( a b c d -- a b c d a b c d )
  58     >r >r 2dup r> r> 2swap >r >r 2dup r> r> 2swap ;
  59
  60 : 4keep ( w x y z quot -- w x y z )
  61     >r 4dup r> swap >r swap >r swap >r swap >r call r> r> r> r> ; inline