sha256

A pure Haskell implementation of SHA-256 as specified by RFC 6234.
git clone git://git.ppad.tech/sha256.git
Log | Files | Refs | LICENSE

commit 6b2999fc20f0fdb4170d7e2ac104ef6a21d6a371
parent 1bf11246a565bc04822d00b33550c26ebe495319
Author: Jared Tobin <jared@jtobin.io>
Date:   Tue, 10 Sep 2024 00:40:31 +0400

lib: initial working version

Diffstat:
Mlib/Crypto/Hash/SHA256.hs | 305+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--------------------
1 file changed, 227 insertions(+), 78 deletions(-)

diff --git a/lib/Crypto/Hash/SHA256.hs b/lib/Crypto/Hash/SHA256.hs @@ -1,7 +1,8 @@ {-# OPTIONS_GHC -funbox-small-strict-fields #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module Crypto.Hash.SHA256 where @@ -9,16 +10,25 @@ import qualified Data.Bits as B import Data.Bits ((.&.), (.|.)) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BSB -import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Unsafe as BU +import qualified Data.List as L import Data.Word (Word32, Word64) --- utilities +-- preliminary utils +-- keystroke saver fi :: (Integral a, Num b) => a -> b fi = fromIntegral --- from Data.Binary +-- break a bytestring into chunks of the specified size. +chunks :: Int -> BS.ByteString -> [BS.ByteString] +chunks s = loop where + loop bs + | BS.null bs = [] + | otherwise = case BS.splitAt s bs of + (c, r) -> c : loop r + +-- verbatim from Data.Binary word32be :: BS.ByteString -> Word32 word32be s = (fromIntegral (s `BU.unsafeIndex` 0) `B.unsafeShiftL` 24) .|. @@ -30,42 +40,27 @@ word32be s = -- message padding and parsing -- https://datatracker.ietf.org/doc/html/rfc6234#section-4.1 -pad :: BL.ByteString -> BL.ByteString -pad (BL.toChunks -> m) = con 0 mempty m where - -- consume input, calculating bytelength and accumulating result - con !l acc = \case - (c:cs) -> - let nl = l + fi (BS.length c) - nacc = acc <> BSB.byteString c - in con nl nacc cs - - [] -> - let k = sol l - don = fin l k (acc <> BSB.word8 0x80) - in BSB.toLazyByteString don - - -- K, where (L + 1 + K) ≅ 56 (mod 64) - sol :: Word64 -> Word64 - sol l = - let r :: Integer - r = 56 - fi l - 1 -- fi prevents potential underflow - in fi $ if r < 0 then r + 64 else r - - -- finalize padding, given bytelength - fin l k acc - | k == 0 = acc <> BSB.word64BE (l * 8) - | otherwise = - let nacc = acc <> BSB.word8 0x00 - in fin l (pred k) nacc +pad :: BS.ByteString -> BS.ByteString +pad m = BS.toStrict . BSB.toLazyByteString $ + loop (BSB.byteString m <> BSB.word8 0x80) k + where + l = fi (BS.length m) + + -- k such that (l + 1 + k) mod 64 = 56 + k :: Word64 + k = let r = 56 - fi l `mod` 64 - 1 :: Integer -- fi prevents underflow + in fi (if r < 0 then r + 64 else r) + + loop acc j + | j == 0 = acc <> BSB.word64BE (l * 8) + | otherwise = loop (acc <> BSB.word8 0x00) (pred j) -- functions and constants used -- https://datatracker.ietf.org/doc/html/rfc6234#section-5.1 --- choice, a ? b : c ch :: Word32 -> Word32 -> Word32 -> Word32 ch x y z = (x .&. y) `B.xor` (B.complement x .&. z) --- majority, (x & y) ^ (x & z) ^ (y & z) maj :: Word32 -> Word32 -> Word32 -> Word32 maj x y z = (x .&. y) `B.xor` (x .&. z) `B.xor` (y .&. z) @@ -81,64 +76,218 @@ ssig0 x = B.rotateR x 7 `B.xor` B.rotateR x 18 `B.xor` B.unsafeShiftR x 3 ssig1 :: Word32 -> Word32 ssig1 x = B.rotateR x 17 `B.xor` B.rotateR x 19 `B.xor` B.unsafeShiftR x 10 -data Schedule = Schedule - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - deriving (Eq, Show) - --- first 32 bits of the fractional parts of the cube roots of the first --- sixty-four primes -sha256_constants :: Schedule -sha256_constants = Schedule - 0x428a2f98 0x3956c25b 0xd807aa98 0x72be5d74 - 0xe49b69c1 0x2de92c6f 0x983e5152 0xc6e00bf3 - 0x27b70a85 0x650a7354 0xa2bfe8a1 0xd192e819 - 0x19a4c116 0x391c0cb3 0x748f82ee 0x90befffa - 0x71374491 0x59f111f1 0x12835b01 0x80deb1fe - 0xefbe4786 0x4a7484aa 0xa831c66d 0xd5a79147 - 0x2e1b2138 0x766a0abb 0xa81a664b 0xd6990624 - 0x1e376c08 0x4ed8aa4a 0x78a5636f 0xa4506ceb - 0xb5c0fbcf 0x923f82a4 0x243185be 0x9bdc06a7 - 0x0fc19dc6 0x5cb0a9dc 0xb00327c8 0x06ca6351 - 0x4d2c6dfc 0x81c2c92e 0xc24b8b70 0xf40e3585 - 0x2748774c 0x5b9cca4f 0x84c87814 0xbef9a3f7 - 0xe9b5dba5 0xab1c5ed5 0x550c7dc3 0xc19bf174 - 0x240ca1cc 0x76f988da 0xbf597fc7 0x14292967 - 0x53380d13 0x92722c85 0xc76c51a3 0x106aa070 - 0x34b0bcb5 0x682e6ff3 0x8cc70208 0xc67178f2 +data Schedule = Schedule { + w00 :: !Word32, w01 :: !Word32, w02 :: !Word32, w03 :: !Word32 + , w04 :: !Word32, w05 :: !Word32, w06 :: !Word32, w07 :: !Word32 + , w08 :: !Word32, w09 :: !Word32, w10 :: !Word32, w11 :: !Word32 + , w12 :: !Word32, w13 :: !Word32, w14 :: !Word32, w15 :: !Word32 + , w16 :: !Word32, w17 :: !Word32, w18 :: !Word32, w19 :: !Word32 + , w20 :: !Word32, w21 :: !Word32, w22 :: !Word32, w23 :: !Word32 + , w24 :: !Word32, w25 :: !Word32, w26 :: !Word32, w27 :: !Word32 + , w28 :: !Word32, w29 :: !Word32, w30 :: !Word32, w31 :: !Word32 + , w32 :: !Word32, w33 :: !Word32, w34 :: !Word32, w35 :: !Word32 + , w36 :: !Word32, w37 :: !Word32, w38 :: !Word32, w39 :: !Word32 + , w40 :: !Word32, w41 :: !Word32, w42 :: !Word32, w43 :: !Word32 + , w44 :: !Word32, w45 :: !Word32, w46 :: !Word32, w47 :: !Word32 + , w48 :: !Word32, w49 :: !Word32, w50 :: !Word32, w51 :: !Word32 + , w52 :: !Word32, w53 :: !Word32, w54 :: !Word32, w55 :: !Word32 + , w56 :: !Word32, w57 :: !Word32, w58 :: !Word32, w59 :: !Word32 + , w60 :: !Word32, w61 :: !Word32, w62 :: !Word32, w63 :: !Word32 + } deriving (Eq, Show) + +choose_w :: Schedule -> Int -> Word32 +choose_w s = \case + 0 -> w00 s; 1 -> w01 s; 2 -> w02 s; 3 -> w03 s + 4 -> w04 s; 5 -> w05 s; 6 -> w06 s; 7 -> w07 s + 8 -> w08 s; 9 -> w09 s; 10 -> w10 s; 11 -> w11 s + 12 -> w12 s; 13 -> w13 s; 14 -> w14 s; 15 -> w15 s + 16 -> w16 s; 17 -> w17 s; 18 -> w18 s; 19 -> w19 s + 20 -> w20 s; 21 -> w21 s; 22 -> w22 s; 23 -> w23 s + 24 -> w24 s; 25 -> w25 s; 26 -> w26 s; 27 -> w27 s + 28 -> w28 s; 29 -> w29 s; 30 -> w30 s; 31 -> w31 s + 32 -> w32 s; 33 -> w33 s; 34 -> w34 s; 35 -> w35 s + 36 -> w36 s; 37 -> w37 s; 38 -> w38 s; 39 -> w39 s + 40 -> w40 s; 41 -> w41 s; 42 -> w42 s; 43 -> w43 s + 44 -> w44 s; 45 -> w45 s; 46 -> w46 s; 47 -> w47 s + 48 -> w48 s; 49 -> w49 s; 50 -> w50 s; 51 -> w51 s + 52 -> w52 s; 53 -> w53 s; 54 -> w54 s; 55 -> w55 s + 56 -> w56 s; 57 -> w57 s; 58 -> w58 s; 59 -> w59 s + 60 -> w60 s; 61 -> w61 s; 62 -> w62 s; 63 -> w63 s + _ -> error "ppad-sha256: internal error (invalid schedule index)" + +-- k0-k63 are the first 32 bits of the fractional parts of the cube +-- roots of the first sixty-four prime numbers +choose_k :: Int -> Word32 +choose_k = \case + 0 -> 0x428a2f98; 1 -> 0x71374491; 2 -> 0xb5c0fbcf; 3 -> 0xe9b5dba5 + 4 -> 0x3956c25b; 5 -> 0x59f111f1; 6 -> 0x923f82a4; 7 -> 0xab1c5ed5 + 8 -> 0xd807aa98; 9 -> 0x12835b01; 10 -> 0x243185be; 11 -> 0x550c7dc3 + 12 -> 0x72be5d74; 13 -> 0x80deb1fe; 14 -> 0x9bdc06a7; 15 -> 0xc19bf174 + 16 -> 0xe49b69c1; 17 -> 0xefbe4786; 18 -> 0x0fc19dc6; 19 -> 0x240ca1cc + 20 -> 0x2de92c6f; 21 -> 0x4a7484aa; 22 -> 0x5cb0a9dc; 23 -> 0x76f988da + 24 -> 0x983e5152; 25 -> 0xa831c66d; 26 -> 0xb00327c8; 27 -> 0xbf597fc7 + 28 -> 0xc6e00bf3; 29 -> 0xd5a79147; 30 -> 0x06ca6351; 31 -> 0x14292967 + 32 -> 0x27b70a85; 33 -> 0x2e1b2138; 34 -> 0x4d2c6dfc; 35 -> 0x53380d13 + 36 -> 0x650a7354; 37 -> 0x766a0abb; 38 -> 0x81c2c92e; 39 -> 0x92722c85 + 40 -> 0xa2bfe8a1; 41 -> 0xa81a664b; 42 -> 0xc24b8b70; 43 -> 0xc76c51a3 + 44 -> 0xd192e819; 45 -> 0xd6990624; 46 -> 0xf40e3585; 47 -> 0x106aa070 + 48 -> 0x19a4c116; 49 -> 0x1e376c08; 50 -> 0x2748774c; 51 -> 0x34b0bcb5 + 52 -> 0x391c0cb3; 53 -> 0x4ed8aa4a; 54 -> 0x5b9cca4f; 55 -> 0x682e6ff3 + 56 -> 0x748f82ee; 57 -> 0x78a5636f; 58 -> 0x84c87814; 59 -> 0x8cc70208 + 60 -> 0x90befffa; 61 -> 0xa4506ceb; 62 -> 0xbef9a3f7; 63 -> 0xc67178f2 + _ -> error "ppad-sha256: internal error (invalid constant index)" -- initialization -- https://datatracker.ietf.org/doc/html/rfc6234#section-6.1 -data Registers = Registers - !Word32 !Word32 !Word32 !Word32 - !Word32 !Word32 !Word32 !Word32 - deriving (Eq, Show) +data Registers = Registers { + h0 :: !Word32, h1 :: !Word32, h2 :: !Word32, h3 :: !Word32 + , h4 :: !Word32, h5 :: !Word32, h6 :: !Word32, h7 :: !Word32 + } deriving (Eq, Show) -- first 32 bits of the fractional parts of the square roots of the -- first eight primes -sha256_iv :: Registers -sha256_iv = Registers +iv :: Registers +iv = Registers 0x6a09e667 0xbb67ae85 0x3c6ef372 0xa54ff53a 0x510e527f 0x9b05688c 0x1f83d9ab 0x5be0cd19 -- processing -- https://datatracker.ietf.org/doc/html/rfc6234#section-6.2 +data Block = Block { + m00 :: !Word32, m01 :: !Word32, m02 :: !Word32, m03 :: !Word32 + , m04 :: !Word32, m05 :: !Word32, m06 :: !Word32, m07 :: !Word32 + , m08 :: !Word32, m09 :: !Word32, m10 :: !Word32, m11 :: !Word32 + , m12 :: !Word32, m13 :: !Word32, m14 :: !Word32, m15 :: !Word32 + } deriving (Eq, Show) + +parse :: BS.ByteString -> Block +parse bs = + let (word32be -> m00, t00) = BS.splitAt 4 bs + (word32be -> m01, t01) = BS.splitAt 4 t00 + (word32be -> m02, t02) = BS.splitAt 4 t01 + (word32be -> m03, t03) = BS.splitAt 4 t02 + (word32be -> m04, t04) = BS.splitAt 4 t03 + (word32be -> m05, t05) = BS.splitAt 4 t04 + (word32be -> m06, t06) = BS.splitAt 4 t05 + (word32be -> m07, t07) = BS.splitAt 4 t06 + (word32be -> m08, t08) = BS.splitAt 4 t07 + (word32be -> m09, t09) = BS.splitAt 4 t08 + (word32be -> m10, t10) = BS.splitAt 4 t09 + (word32be -> m11, t11) = BS.splitAt 4 t10 + (word32be -> m12, t12) = BS.splitAt 4 t11 + (word32be -> m13, t13) = BS.splitAt 4 t12 + (word32be -> m14, t14) = BS.splitAt 4 t13 + (word32be -> m15, t15) = BS.splitAt 4 t14 + in if BS.null t15 + then Block {..} + else error "ppad-sha256: internal error (bytes remaining)" + +-- 6.2 step 1 +prepare_schedule :: Block -> Schedule +prepare_schedule Block {..} = Schedule {..} where + w00 = m00 + w01 = m01 + w02 = m02 + w03 = m03 + w04 = m04 + w05 = m05 + w06 = m06 + w07 = m07 + w08 = m08 + w09 = m09 + w10 = m10 + w11 = m11 + w12 = m12 + w13 = m13 + w14 = m14 + w15 = m15 + w16 = ssig1 w14 + w09 + ssig0 w01 + w00 + w17 = ssig1 w15 + w10 + ssig0 w02 + w01 + w18 = ssig1 w16 + w11 + ssig0 w03 + w02 + w19 = ssig1 w17 + w12 + ssig0 w04 + w03 + w20 = ssig1 w18 + w13 + ssig0 w05 + w04 + w21 = ssig1 w19 + w14 + ssig0 w06 + w05 + w22 = ssig1 w20 + w15 + ssig0 w07 + w06 + w23 = ssig1 w21 + w16 + ssig0 w08 + w07 + w24 = ssig1 w22 + w17 + ssig0 w09 + w08 + w25 = ssig1 w23 + w18 + ssig0 w10 + w09 + w26 = ssig1 w24 + w19 + ssig0 w11 + w10 + w27 = ssig1 w25 + w20 + ssig0 w12 + w11 + w28 = ssig1 w26 + w21 + ssig0 w13 + w12 + w29 = ssig1 w27 + w22 + ssig0 w14 + w13 + w30 = ssig1 w28 + w23 + ssig0 w15 + w14 + w31 = ssig1 w29 + w24 + ssig0 w16 + w15 + w32 = ssig1 w30 + w25 + ssig0 w17 + w16 + w33 = ssig1 w31 + w26 + ssig0 w18 + w17 + w34 = ssig1 w32 + w27 + ssig0 w19 + w18 + w35 = ssig1 w33 + w28 + ssig0 w20 + w19 + w36 = ssig1 w34 + w29 + ssig0 w21 + w20 + w37 = ssig1 w35 + w30 + ssig0 w22 + w21 + w38 = ssig1 w36 + w31 + ssig0 w23 + w22 + w39 = ssig1 w37 + w32 + ssig0 w24 + w23 + w40 = ssig1 w38 + w33 + ssig0 w25 + w24 + w41 = ssig1 w39 + w34 + ssig0 w26 + w25 + w42 = ssig1 w40 + w35 + ssig0 w27 + w26 + w43 = ssig1 w41 + w36 + ssig0 w28 + w27 + w44 = ssig1 w42 + w37 + ssig0 w29 + w28 + w45 = ssig1 w43 + w38 + ssig0 w30 + w29 + w46 = ssig1 w44 + w39 + ssig0 w31 + w30 + w47 = ssig1 w45 + w40 + ssig0 w32 + w31 + w48 = ssig1 w46 + w41 + ssig0 w33 + w32 + w49 = ssig1 w47 + w42 + ssig0 w34 + w33 + w50 = ssig1 w48 + w43 + ssig0 w35 + w34 + w51 = ssig1 w49 + w44 + ssig0 w36 + w35 + w52 = ssig1 w50 + w45 + ssig0 w37 + w36 + w53 = ssig1 w51 + w46 + ssig0 w38 + w37 + w54 = ssig1 w52 + w47 + ssig0 w39 + w38 + w55 = ssig1 w53 + w48 + ssig0 w40 + w39 + w56 = ssig1 w54 + w49 + ssig0 w41 + w40 + w57 = ssig1 w55 + w50 + ssig0 w42 + w41 + w58 = ssig1 w56 + w51 + ssig0 w43 + w42 + w59 = ssig1 w57 + w52 + ssig0 w44 + w43 + w60 = ssig1 w58 + w53 + ssig0 w45 + w44 + w61 = ssig1 w59 + w54 + ssig0 w46 + w45 + w62 = ssig1 w60 + w55 + ssig0 w47 + w46 + w63 = ssig1 w61 + w56 + ssig0 w48 + w47 + +-- 6.2 steps 2, 3 +block_hash :: Registers -> Schedule -> Registers +block_hash r@Registers {..} s = loop 0 r where + loop t (Registers a b c d e f g h) + | t == 64 = Registers { + h0 = a + h0, h1 = b + h1, h2 = c + h2, h3 = d + h3 + , h4 = e + h4, h5 = f + h5, h6 = g + h6, h7 = h + h7 + } + | otherwise = + let t1 = h + bsig1 e + ch e f g + choose_k t + choose_w s t + t2 = bsig0 a + maj a b c + nacc = Registers (t1 + t2) a b c (d + t1) e f g + in loop (succ t) nacc +-- 6.2 step 4 +cat :: Registers -> BS.ByteString +cat Registers {..} = BS.toStrict . BSB.toLazyByteString $ mconcat [ + BSB.word32BE h0 + , BSB.word32BE h1 + , BSB.word32BE h2 + , BSB.word32BE h3 + , BSB.word32BE h4 + , BSB.word32BE h5 + , BSB.word32BE h6 + , BSB.word32BE h7 + ] +-- | Compute a condensed representation of a strict bytestring via +-- SHA-256. +hash :: BS.ByteString -> BS.ByteString +hash (pad -> m) = + cat + . L.foldl' alg iv + . fmap parse + . chunks 64 + $ m + where + alg acc = block_hash acc . prepare_schedule