basis/checksums/sha/sha.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors checksums checksums.common checksums.stream
   4 combinators combinators.smart fry generalizations grouping
   5 io.binary kernel literals locals make math math.bitwise
   6 math.ranges multiline namespaces sbufs sequences
   7 sequences.generalizations sequences.private splitting strings ;
   8 IN: checksums.sha
   9
  10 SINGLETON: sha1
  11 INSTANCE: sha1 stream-checksum
  12
  13 SINGLETON: sha-224
  14 SINGLETON: sha-256
  15
  16 INSTANCE: sha-224 stream-checksum
  17 INSTANCE: sha-256 stream-checksum
  18
  19 TUPLE: sha1-state < checksum-state K H W word-size ;
  20
  21 CONSTANT: initial-H-sha1
  22     {
  23         HEX: 67452301
  24         HEX: efcdab89
  25         HEX: 98badcfe
  26         HEX: 10325476
  27         HEX: c3d2e1f0
  28     }
  29
  30 CONSTANT: K-sha1
  31     $[
  32         20 HEX: 5a827999 <repetition>
  33         20 HEX: 6ed9eba1 <repetition>
  34         20 HEX: 8f1bbcdc <repetition>
  35         20 HEX: ca62c1d6 <repetition>
  36         4 { } nappend-as
  37     ]
  38
  39 TUPLE: sha2-state < checksum-state K H word-size ;
  40
  41 TUPLE: sha2-short < sha2-state ;
  42
  43 TUPLE: sha2-long < sha2-state ;
  44
  45 TUPLE: sha-224-state < sha2-short ;
  46
  47 TUPLE: sha-256-state < sha2-short ;
  48
  49 M: sha2-state clone
  50     call-next-method
  51     [ clone ] change-H
  52     [ clone ] change-K ;
  53
  54 <PRIVATE
  55
  56 CONSTANT: a 0
  57 CONSTANT: b 1
  58 CONSTANT: c 2
  59 CONSTANT: d 3
  60 CONSTANT: e 4
  61 CONSTANT: f 5
  62 CONSTANT: g 6
  63 CONSTANT: h 7
  64
  65 CONSTANT: initial-H-224
  66     {
  67         HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
  68         HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
  69     }
  70
  71 CONSTANT: initial-H-256
  72     {
  73         HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
  74         HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
  75     }
  76
  77 CONSTANT: initial-H-384
  78     {
  79         HEX: cbbb9d5dc1059ed8
  80         HEX: 629a292a367cd507
  81         HEX: 9159015a3070dd17
  82         HEX: 152fecd8f70e5939
  83         HEX: 67332667ffc00b31
  84         HEX: 8eb44a8768581511
  85         HEX: db0c2e0d64f98fa7
  86         HEX: 47b5481dbefa4fa4
  87     }
  88
  89 CONSTANT: initial-H-512
  90     {
  91         HEX: 6a09e667f3bcc908
  92         HEX: bb67ae8584caa73b
  93         HEX: 3c6ef372fe94f82b
  94         HEX: a54ff53a5f1d36f1
  95         HEX: 510e527fade682d1
  96         HEX: 9b05688c2b3e6c1f
  97         HEX: 1f83d9abfb41bd6b
  98         HEX: 5be0cd19137e2179
  99     }
 100
 101 CONSTANT: K-256
 102     {
 103         HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
 104         HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
 105         HEX: d807aa98 HEX: 12835b01 HEX: 243185be HEX: 550c7dc3
 106         HEX: 72be5d74 HEX: 80deb1fe HEX: 9bdc06a7 HEX: c19bf174
 107         HEX: e49b69c1 HEX: efbe4786 HEX: 0fc19dc6 HEX: 240ca1cc
 108         HEX: 2de92c6f HEX: 4a7484aa HEX: 5cb0a9dc HEX: 76f988da
 109         HEX: 983e5152 HEX: a831c66d HEX: b00327c8 HEX: bf597fc7
 110         HEX: c6e00bf3 HEX: d5a79147 HEX: 06ca6351 HEX: 14292967
 111         HEX: 27b70a85 HEX: 2e1b2138 HEX: 4d2c6dfc HEX: 53380d13
 112         HEX: 650a7354 HEX: 766a0abb HEX: 81c2c92e HEX: 92722c85
 113         HEX: a2bfe8a1 HEX: a81a664b HEX: c24b8b70 HEX: c76c51a3
 114         HEX: d192e819 HEX: d6990624 HEX: f40e3585 HEX: 106aa070
 115         HEX: 19a4c116 HEX: 1e376c08 HEX: 2748774c HEX: 34b0bcb5
 116         HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
 117         HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
 118         HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
 119     }
 120
 121 CONSTANT: K-384
 122     {
 123
 124         HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc
 125         HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118
 126         HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
 127         HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694
 128         HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65
 129         HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5
 130         HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4
 131         HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70
 132         HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df
 133         HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b
 134         HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30
 135         HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8
 136         HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8
 137         HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3
 138         HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec
 139         HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b
 140         HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178
 141         HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b
 142         HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c
 143         HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
 144     }
 145
 146 ALIAS: K-512 K-384
 147
 148 : <sha1-state> ( -- sha1-state )
 149     sha1-state new-checksum-state
 150         64 >>block-size
 151         K-sha1 >>K
 152         initial-H-sha1 >>H
 153         4 >>word-size ;
 154
 155 : <sha-224-state> ( -- sha2-state )
 156     sha-224-state new-checksum-state
 157         64 >>block-size
 158         K-256 >>K
 159         initial-H-224 >>H
 160         4 >>word-size ;
 161
 162 : <sha-256-state> ( -- sha2-state )
 163     sha-256-state new-checksum-state
 164         64 >>block-size
 165         K-256 >>K
 166         initial-H-256 >>H
 167         4 >>word-size ;
 168
 169 M: sha1 initialize-checksum-state drop <sha1-state> ;
 170
 171 M: sha-224 initialize-checksum-state drop <sha-224-state> ;
 172
 173 M: sha-256 initialize-checksum-state drop <sha-256-state> ;
 174
 175 : s0-256 ( x -- x' )
 176     [
 177         [ -7 bitroll-32 ]
 178         [ -18 bitroll-32 ]
 179         [ -3 shift ] tri
 180     ] [ bitxor ] reduce-outputs ; inline
 181
 182 : s1-256 ( x -- x' )
 183     [
 184         [ -17 bitroll-32 ]
 185         [ -19 bitroll-32 ]
 186         [ -10 shift ] tri
 187     ] [ bitxor ] reduce-outputs ; inline
 188
 189 : S0-256 ( x -- x' )
 190     [
 191         [ -2 bitroll-32 ]
 192         [ -13 bitroll-32 ]
 193         [ -22 bitroll-32 ] tri
 194     ] [ bitxor ] reduce-outputs ; inline
 195
 196 : S1-256 ( x -- x' )
 197     [
 198         [ -6 bitroll-32 ]
 199         [ -11 bitroll-32 ]
 200         [ -25 bitroll-32 ] tri
 201     ] [ bitxor ] reduce-outputs ; inline
 202
 203 : s0-512 ( x -- x' )
 204     [
 205         [ -1 bitroll-64 ]
 206         [ -8 bitroll-64 ]
 207         [ -7 shift ] tri
 208     ] [ bitxor ] reduce-outputs ; inline
 209
 210 : s1-512 ( x -- x' )
 211     [
 212         [ -19 bitroll-64 ]
 213         [ -61 bitroll-64 ]
 214         [ -6 shift ] tri
 215     ] [ bitxor ] reduce-outputs ; inline
 216
 217 : S0-512 ( x -- x' )
 218     [
 219         [ -28 bitroll-64 ]
 220         [ -34 bitroll-64 ]
 221         [ -39 bitroll-64 ] tri
 222     ] [ bitxor ] reduce-outputs ; inline
 223
 224 : S1-512 ( x -- x' )
 225     [
 226         [ -14 bitroll-64 ]
 227         [ -18 bitroll-64 ]
 228         [ -41 bitroll-64 ] tri
 229     ] [ bitxor ] reduce-outputs ; inline
 230
 231 : prepare-M-256 ( n seq -- )
 232     {
 233         [ [ 16 - ] dip nth-unsafe ]
 234         [ [ 15 - ] dip nth-unsafe s0-256 ]
 235         [ [ 7 - ] dip nth-unsafe ]
 236         [ [ 2 - ] dip nth-unsafe s1-256 w+ w+ w+ ]
 237         [ ]
 238     } 2cleave set-nth-unsafe ; inline
 239
 240 : prepare-M-512 ( n seq -- )
 241     {
 242         [ [ 16 - ] dip nth-unsafe ]
 243         [ [ 15 - ] dip nth-unsafe s0-512 ]
 244         [ [ 7 - ] dip nth-unsafe ]
 245         [ [ 2 - ] dip nth-unsafe s1-512 w+ w+ w+ ]
 246         [ ]
 247     } 2cleave set-nth-unsafe ; inline
 248
 249 : ch ( x y z -- x' )
 250     [ bitxor bitand ] keep bitxor ; inline
 251
 252 : maj ( x y z -- x' )
 253     [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
 254
 255 : slice3 ( n seq -- a b c )
 256     [ dup 3 + ] dip <slice> first3 ; inline
 257
 258 GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
 259
 260 :: T1-256 ( n M H sha2 -- T1 )
 261     n M nth-unsafe
 262     n sha2 K>> nth-unsafe +
 263     e H slice3 ch w+
 264     e H nth-unsafe S1-256 w+
 265     h H nth-unsafe w+ ; inline
 266
 267 : T2-256 ( H -- T2 )
 268     [ a swap nth-unsafe S0-256 ]
 269     [ a swap slice3 maj w+ ] bi ; inline
 270
 271 :: T1-512 ( n M H sha2 -- T1 )
 272     n M nth-unsafe
 273     n sha2 K>> nth-unsafe +
 274     e H slice3 ch w+
 275     e H nth-unsafe S1-512 w+
 276     h H nth-unsafe w+ ; inline
 277
 278 : T2-512 ( H -- T2 )
 279     [ a swap nth-unsafe S0-512 ]
 280     [ a swap slice3 maj w+ ] bi ; inline
 281
 282 : update-H ( T1 T2 H -- )
 283     h g pick exchange-unsafe
 284     g f pick exchange-unsafe
 285     f e pick exchange-unsafe
 286     pick d pick nth-unsafe w+ e pick set-nth-unsafe
 287     d c pick exchange-unsafe
 288     c b pick exchange-unsafe
 289     b a pick exchange-unsafe
 290     [ w+ a ] dip set-nth-unsafe ; inline
 291
 292 : prepare-message-schedule ( seq sha2 -- w-seq )
 293     [ word-size>> <sliced-groups> [ be> ] map ]
 294     [
 295         block-size>> [ 0 pad-tail 16 ] keep [a,b) over
 296         '[ _ prepare-M-256 ] each
 297     ] bi ; inline
 298
 299 :: process-chunk ( M block-size cloned-H sha2 -- )
 300     block-size [
 301         M cloned-H sha2 T1-256
 302         cloned-H T2-256
 303         cloned-H update-H
 304     ] each-integer
 305     sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline
 306
 307 M: sha2-short checksum-block
 308     [ prepare-message-schedule ]
 309     [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
 310
 311 : seq>byte-array ( seq n -- string )
 312     '[ _ >be ] map B{ } concat-as ;
 313
 314 : sha1>checksum ( sha2 -- bytes )
 315     H>> 4 seq>byte-array ;
 316
 317 : sha-224>checksum ( sha2 -- bytes )
 318     H>> 7 head 4 seq>byte-array ;
 319
 320 : sha-256>checksum ( sha2 -- bytes )
 321     H>> 4 seq>byte-array ;
 322
 323 : pad-last-short-block ( state -- )
 324     [ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri
 325     [ checksum-block ] curry each ;
 326
 327 PRIVATE>
 328
 329 M: sha-224-state get-checksum
 330     clone
 331     [ pad-last-short-block ] [ sha-224>checksum ] bi ;
 332
 333 M: sha-256-state get-checksum
 334     clone
 335     [ pad-last-short-block ] [ sha-256>checksum ] bi ;
 336
 337 M: sha-224 checksum-stream ( stream checksum -- byte-array )
 338     drop
 339     [ <sha-224-state> ] dip add-checksum-stream get-checksum ;
 340
 341 M: sha-256 checksum-stream ( stream checksum -- byte-array )
 342     drop
 343     [ <sha-256-state> ] dip add-checksum-stream get-checksum ;
 344
 345 : sha1-W ( t seq -- )
 346     {
 347         [ [ 3 - ] dip nth-unsafe ]
 348         [ [ 8 - ] dip nth-unsafe bitxor ]
 349         [ [ 14 - ] dip nth-unsafe bitxor ]
 350         [ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ]
 351         [ ]
 352     } 2cleave set-nth-unsafe ;
 353
 354 : prepare-sha1-message-schedule ( seq -- w-seq )
 355     4 <sliced-groups> [ be> ] map
 356     80 0 pad-tail 16 80 [a,b) over
 357     '[ _ sha1-W ] each ; inline
 358
 359 : sha1-f ( B C D n -- f_nbcd )
 360     20 /i
 361     {
 362         { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
 363         { 1 [ bitxor bitxor ] }
 364         { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
 365         { 3 [ bitxor bitxor ] }
 366     } case ;
 367
 368 :: inner-loop ( n H W K -- temp )
 369     a H nth-unsafe :> A
 370     b H nth-unsafe :> B
 371     c H nth-unsafe :> C
 372     d H nth-unsafe :> D
 373     e H nth-unsafe :> E
 374     [
 375         A 5 bitroll-32
 376
 377         B C D n sha1-f
 378
 379         E
 380
 381         n K nth-unsafe
 382
 383         n W nth-unsafe
 384     ] sum-outputs 32 bits ;
 385
 386 :: process-sha1-chunk ( bytes H W K state -- )
 387     80 [
 388         H W K inner-loop
 389         d H nth-unsafe e H set-nth-unsafe
 390         c H nth-unsafe d H set-nth-unsafe
 391         b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
 392         a H nth-unsafe b H set-nth-unsafe
 393         a H set-nth-unsafe
 394     ] each-integer
 395     state [ H [ w+ ] 2map ] change-H drop ; inline
 396
 397 M:: sha1-state checksum-block ( bytes state -- )
 398     bytes prepare-sha1-message-schedule state W<<
 399
 400     bytes
 401     state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ;
 402
 403 M: sha1-state get-checksum
 404     clone
 405     [ pad-last-short-block ] [ sha-256>checksum ] bi ;
 406
 407 M: sha1 checksum-stream ( stream checksum -- byte-array )
 408     drop
 409     [ <sha1-state> ] dip add-checksum-stream get-checksum ;