{-# LANGUAGE Safe #-}
-- | Pure SHA-256 (FIPS 180-4), used to bind validator responses to the
--   exact artifact bytes they were computed from. Self-contained so rwc
--   carries no cryptography dependency for the sake of one digest.
module ReWire.Sha256 (hashHex) where

import Data.Bits (complement, rotateR, shiftL, shiftR, xor, (.&.))
import Data.Text (Text)
import Data.Word (Word32, Word64)
import Numeric (showHex)

import qualified Data.ByteString as BS
import qualified Data.Sequence   as Seq
import qualified Data.Text       as T

-- | The lowercase hex SHA-256 digest of a byte string.
hashHex :: BS.ByteString -> Text
hashHex :: ByteString -> Text
hashHex ByteString
bs = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Word32 -> Text) -> [Word32] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> Text
wordHex [Word32
a, Word32
b, Word32
c, Word32
d, Word32
e, Word32
f, Word32
g, Word32
h]
      where (Word32
a, Word32
b, Word32
c, Word32
d, Word32
e, Word32
f, Word32
g, Word32
h) = ((Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
 -> ByteString
 -> (Word32, Word32, Word32, Word32, Word32, Word32, Word32,
     Word32))
-> (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
-> [ByteString]
-> (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
-> ByteString
-> (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
block (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
h0 ([ByteString]
 -> (Word32, Word32, Word32, Word32, Word32, Word32, Word32,
     Word32))
-> [ByteString]
-> (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
chunks (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
padded ByteString
bs

            wordHex :: Word32 -> Text
            wordHex :: Word32 -> Text
wordHex Word32
w = Int -> Char -> Text -> Text
T.justifyRight Int
8 Char
'0' (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Word32 -> ShowS
forall a. Integral a => a -> ShowS
showHex Word32
w String
""

type St = (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)

h0 :: St
h0 :: (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
h0 = (Word32
0x6a09e667, Word32
0xbb67ae85, Word32
0x3c6ef372, Word32
0xa54ff53a, Word32
0x510e527f, Word32
0x9b05688c, Word32
0x1f83d9ab, Word32
0x5be0cd19)

ks :: Seq.Seq Word32
ks :: Seq Word32
ks = [Word32] -> Seq Word32
forall a. [a] -> Seq a
Seq.fromList
      [ Word32
0x428a2f98, Word32
0x71374491, Word32
0xb5c0fbcf, Word32
0xe9b5dba5, Word32
0x3956c25b, Word32
0x59f111f1, Word32
0x923f82a4, Word32
0xab1c5ed5
      , Word32
0xd807aa98, Word32
0x12835b01, Word32
0x243185be, Word32
0x550c7dc3, Word32
0x72be5d74, Word32
0x80deb1fe, Word32
0x9bdc06a7, Word32
0xc19bf174
      , Word32
0xe49b69c1, Word32
0xefbe4786, Word32
0x0fc19dc6, Word32
0x240ca1cc, Word32
0x2de92c6f, Word32
0x4a7484aa, Word32
0x5cb0a9dc, Word32
0x76f988da
      , Word32
0x983e5152, Word32
0xa831c66d, Word32
0xb00327c8, Word32
0xbf597fc7, Word32
0xc6e00bf3, Word32
0xd5a79147, Word32
0x06ca6351, Word32
0x14292967
      , Word32
0x27b70a85, Word32
0x2e1b2138, Word32
0x4d2c6dfc, Word32
0x53380d13, Word32
0x650a7354, Word32
0x766a0abb, Word32
0x81c2c92e, Word32
0x92722c85
      , Word32
0xa2bfe8a1, Word32
0xa81a664b, Word32
0xc24b8b70, Word32
0xc76c51a3, Word32
0xd192e819, Word32
0xd6990624, Word32
0xf40e3585, Word32
0x106aa070
      , Word32
0x19a4c116, Word32
0x1e376c08, Word32
0x2748774c, Word32
0x34b0bcb5, Word32
0x391c0cb3, Word32
0x4ed8aa4a, Word32
0x5b9cca4f, Word32
0x682e6ff3
      , Word32
0x748f82ee, Word32
0x78a5636f, Word32
0x84c87814, Word32
0x8cc70208, Word32
0x90befffa, Word32
0xa4506ceb, Word32
0xbef9a3f7, Word32
0xc67178f2
      ]

padded :: BS.ByteString -> BS.ByteString
padded :: ByteString -> ByteString
padded ByteString
bs = ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
BS.singleton Word8
0x80 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Int -> Word8 -> ByteString
BS.replicate Int
nzero Word8
0 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
lenBytes
      where nzero :: Int
nzero    = (Int
55 Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
bs) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
64
            bitLen :: Word64
bitLen   = Word64
8 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bs) :: Word64
            lenBytes :: ByteString
lenBytes = [Word8] -> ByteString
BS.pack [Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> Word64 -> Word8
forall a b. (a -> b) -> a -> b
$ Word64
bitLen Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
s | Int
s <- [Int
56, Int
48 .. Int
0]]

chunks :: BS.ByteString -> [BS.ByteString]
chunks :: ByteString -> [ByteString]
chunks ByteString
bs | ByteString -> Bool
BS.null ByteString
bs = []
          | Bool
otherwise  = Int -> ByteString -> ByteString
BS.take Int
64 ByteString
bs ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString -> [ByteString]
chunks (Int -> ByteString -> ByteString
BS.drop Int
64 ByteString
bs)

block :: St -> BS.ByteString -> St
block :: (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
-> ByteString
-> (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
block (Word32
a0, Word32
b0, Word32
c0, Word32
d0, Word32
e0, Word32
f0, Word32
g0, Word32
h') ByteString
blk =
      case ((Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
 -> Int
 -> (Word32, Word32, Word32, Word32, Word32, Word32, Word32,
     Word32))
-> (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
-> [Int]
-> (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
-> Int
-> (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
round' (Word32
a0, Word32
b0, Word32
c0, Word32
d0, Word32
e0, Word32
f0, Word32
g0, Word32
h') [Int
0 .. Int
63] of
            (Word32
a, Word32
b, Word32
c, Word32
d, Word32
e, Word32
f, Word32
g, Word32
h) ->
                  (Word32
a0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
a, Word32
b0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
b, Word32
c0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
c, Word32
d0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
d, Word32
e0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
e, Word32
f0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
f, Word32
g0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
g, Word32
h' Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
h)
      where ws :: Seq.Seq Word32
            ws :: Seq Word32
ws = Seq Word32 -> Seq Word32
extend (Seq Word32 -> Seq Word32) -> Seq Word32 -> Seq Word32
forall a b. (a -> b) -> a -> b
$ [Word32] -> Seq Word32
forall a. [a] -> Seq a
Seq.fromList [ Int -> Word32
word32At (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i) | Int
i <- [Int
0 .. Int
15] ]

            extend :: Seq.Seq Word32 -> Seq.Seq Word32
            extend :: Seq Word32 -> Seq Word32
extend Seq Word32
s | Seq Word32 -> Int
forall a. Seq a -> Int
Seq.length Seq Word32
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
64 = Seq Word32
s
                     | Bool
otherwise          = Seq Word32 -> Seq Word32
extend (Seq Word32 -> Seq Word32) -> Seq Word32 -> Seq Word32
forall a b. (a -> b) -> a -> b
$ Seq Word32
s Seq Word32 -> Word32 -> Seq Word32
forall a. Seq a -> a -> Seq a
Seq.|> Word32
w
                  where i :: Int
i  = Seq Word32 -> Int
forall a. Seq a -> Int
Seq.length Seq Word32
s
                        w :: Word32
w  = Seq Word32 -> Int -> Word32
forall a. Seq a -> Int -> a
Seq.index Seq Word32
s (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
16) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
s0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Seq Word32 -> Int -> Word32
forall a. Seq a -> Int -> a
Seq.index Seq Word32
s (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
7) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
s1
                        s0 :: Word32
s0 = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateR (Seq Word32 -> Int -> Word32
forall a. Seq a -> Int -> a
Seq.index Seq Word32
s (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
15)) Int
7  Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateR (Seq Word32 -> Int -> Word32
forall a. Seq a -> Int -> a
Seq.index Seq Word32
s (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
15)) Int
18 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR (Seq Word32 -> Int -> Word32
forall a. Seq a -> Int -> a
Seq.index Seq Word32
s (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
15)) Int
3
                        s1 :: Word32
s1 = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateR (Seq Word32 -> Int -> Word32
forall a. Seq a -> Int -> a
Seq.index Seq Word32
s (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)) Int
17  Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateR (Seq Word32 -> Int -> Word32
forall a. Seq a -> Int -> a
Seq.index Seq Word32
s (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)) Int
19  Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR (Seq Word32 -> Int -> Word32
forall a. Seq a -> Int -> a
Seq.index Seq Word32
s (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2)) Int
10

            word32At :: Int -> Word32
            word32At :: Int -> Word32
word32At Int
i = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL (Int -> Word32
byte Int
i) Int
24 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL (Int -> Word32
byte (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
16 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL (Int -> Word32
byte (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int
8 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Int -> Word32
byte (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
                  where byte :: Int -> Word32
                        byte :: Int -> Word32
byte = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word32) -> (Int -> Word8) -> Int -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
BS.index ByteString
blk

            round' :: St -> Int -> St
            round' :: (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
-> Int
-> (Word32, Word32, Word32, Word32, Word32, Word32, Word32, Word32)
round' (Word32
a, Word32
b, Word32
c, Word32
d, Word32
e, Word32
f, Word32
g, Word32
h) Int
i = (Word32
t1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
t2, Word32
a, Word32
b, Word32
c, Word32
d Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
t1, Word32
e, Word32
f, Word32
g)
                  where s1 :: Word32
s1  = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateR Word32
e Int
6 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateR Word32
e Int
11 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateR Word32
e Int
25
                        ch :: Word32
ch  = (Word32
e Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
f) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` (Word32 -> Word32
forall a. Bits a => a -> a
complement Word32
e Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
g)
                        t1 :: Word32
t1  = Word32
h Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
s1 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
ch Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Seq Word32 -> Int -> Word32
forall a. Seq a -> Int -> a
Seq.index Seq Word32
ks Int
i Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Seq Word32 -> Int -> Word32
forall a. Seq a -> Int -> a
Seq.index Seq Word32
ws Int
i
                        s0 :: Word32
s0  = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateR Word32
a Int
2 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateR Word32
a Int
13 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
rotateR Word32
a Int
22
                        mj :: Word32
mj  = (Word32
a Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
b) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` (Word32
a Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
c) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
`xor` (Word32
b Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
c)
                        t2 :: Word32
t2  = Word32
s0 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
mj