SHA256.hs (7027B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE MagicHash #-} 4 {-# LANGUAGE PatternSynonyms #-} 5 {-# LANGUAGE UnboxedTuples #-} 6 {-# LANGUAGE UnliftedNewtypes #-} 7 8 -- | 9 -- Module: Crypto.Hash.SHA256 10 -- Copyright: (c) 2024 Jared Tobin 11 -- License: MIT 12 -- Maintainer: Jared Tobin <jared@ppad.tech> 13 -- 14 -- SHA-256 and HMAC-SHA256 implementations for 15 -- strict and lazy ByteStrings, as specified by RFC's 16 -- [6234](https://datatracker.ietf.org/doc/html/rfc6234) and 17 -- [2104](https://datatracker.ietf.org/doc/html/rfc2104). 18 -- 19 -- The 'hash' and 'hmac' functions will use primitive instructions from 20 -- the ARM cryptographic extensions via FFI if they're available, and 21 -- will otherwise use a pure Haskell implementation. 22 23 module Crypto.Hash.SHA256 ( 24 -- * SHA-256 message digest functions 25 hash 26 , Lazy.hash_lazy 27 28 -- * SHA256-based MAC functions 29 , MAC(..) 30 , hmac 31 , Lazy.hmac_lazy 32 33 -- low-level specialized HMAC primitives 34 , _hmac_rr 35 , _hmac_rsb 36 ) where 37 38 import qualified Data.ByteString as BS 39 import qualified Data.ByteString.Internal as BI 40 import qualified Data.ByteString.Unsafe as BU 41 import Data.Word (Word8, Word32, Word64) 42 import Foreign.Ptr (Ptr) 43 import qualified GHC.Exts as Exts 44 import qualified Crypto.Hash.SHA256.Arm as Arm 45 import Crypto.Hash.SHA256.Internal 46 import qualified Crypto.Hash.SHA256.Lazy as Lazy 47 48 -- utilities ------------------------------------------------------------------ 49 50 fi :: (Integral a, Num b) => a -> b 51 fi = fromIntegral 52 {-# INLINE fi #-} 53 54 -- hash ----------------------------------------------------------------------- 55 56 -- | Compute a condensed representation of a strict bytestring via 57 -- SHA-256. 58 -- 59 -- The 256-bit output digest is returned as a strict bytestring. 60 -- 61 -- >>> hash "strict bytestring input" 62 -- "<strict 256-bit message digest>" 63 hash :: BS.ByteString -> BS.ByteString 64 hash m 65 | Arm.sha256_arm_available = Arm.hash m 66 | otherwise = cat (_hash 0 (iv ()) m) 67 {-# INLINABLE hash #-} 68 69 _hash 70 :: Word64 -- ^ extra prefix length for padding calculations 71 -> Registers -- ^ register state 72 -> BS.ByteString -- ^ input 73 -> Registers 74 _hash el rs m@(BI.PS _ _ l) = do 75 let !state = _hash_blocks rs m 76 !fin@(BI.PS _ _ ll) = BU.unsafeDrop (l - l `rem` 64) m 77 !total = el + fi l 78 if ll < 56 79 then 80 let !ult = parse_pad1 fin total 81 in update state ult 82 else 83 let !(# pen, ult #) = parse_pad2 fin total 84 in update (update state pen) ult 85 {-# INLINABLE _hash #-} 86 87 _hash_blocks 88 :: Registers -- ^ state 89 -> BS.ByteString -- ^ input 90 -> Registers 91 _hash_blocks rs m@(BI.PS _ _ l) = loop rs 0 where 92 loop !acc !j 93 | j + 64 > l = acc 94 | otherwise = 95 let !nacc = update acc (parse m j) 96 in loop nacc (j + 64) 97 {-# INLINABLE _hash_blocks #-} 98 99 -- hmac ---------------------------------------------------------------------- 100 101 -- | Compute a condensed representation of a strict bytestring via 102 -- SHA-256. 103 -- 104 -- The 256-bit output digest is returned as a strict bytestring. 105 -- 106 -- >>> hash "strict bytestring input" 107 -- "<strict 256-bit message digest>" 108 hmac :: BS.ByteString -> BS.ByteString -> MAC 109 hmac k m 110 | Arm.sha256_arm_available = MAC (Arm.hmac k m) 111 | otherwise = MAC (cat (_hmac (prep_key k) m)) 112 {-# INLINABLE hmac #-} 113 114 prep_key :: BS.ByteString -> Block 115 prep_key k@(BI.PS _ _ l) 116 | l > 64 = parse_key (hash k) 117 | otherwise = parse_key k 118 {-# INLINABLE prep_key #-} 119 120 _hmac 121 :: Block -- ^ padded key 122 -> BS.ByteString -- ^ message 123 -> Registers 124 _hmac k m = 125 let !rs0 = update (iv ()) (xor k (Exts.wordToWord32# 0x36363636##)) 126 !block = pad_registers_with_length (_hash 64 rs0 m) 127 !rs1 = update (iv ()) (xor k (Exts.wordToWord32# 0x5C5C5C5C##)) 128 in update rs1 block 129 {-# INLINABLE _hmac #-} 130 131 -- the following functions are useful when we want to avoid allocating certain 132 -- components of the HMAC key and message on the heap. 133 134 -- Computes hmac(k, v) when k and v are Registers. 135 -- 136 -- The 32-byte result is written to the destination pointer. 137 _hmac_rr 138 :: Ptr Word32 -- ^ destination (8 Word32s) 139 -> Ptr Word32 -- ^ scratch block buffer (16 Word32s) 140 -> Registers -- ^ key 141 -> Registers -- ^ message 142 -> IO () 143 _hmac_rr rp bp k m 144 | Arm.sha256_arm_available = Arm._hmac_rr rp bp k m 145 | otherwise = do 146 let !key = pad_registers k 147 !block = pad_registers_with_length m 148 !rs = _hmac_bb key block 149 poke_registers rp rs 150 {-# INLINABLE _hmac_rr #-} 151 152 _hmac_bb 153 :: Block -- ^ key 154 -> Block -- ^ message 155 -> Registers 156 _hmac_bb k m = 157 let !rs0 = update (iv ()) (xor k (Exts.wordToWord32# 0x36363636##)) 158 !rs1 = update rs0 m 159 !inner = pad_registers_with_length rs1 160 !rs2 = update (iv ()) (xor k (Exts.wordToWord32# 0x5C5C5C5C##)) 161 in update rs2 inner 162 {-# INLINABLE _hmac_bb #-} 163 164 -- Calculate hmac(k, m) where m is the concatenation of v (registers), a 165 -- separator byte, and a ByteString. This avoids allocating 'v' on the 166 -- heap. 167 -- 168 -- The 32-byte result is written to the destination pointer. 169 _hmac_rsb 170 :: Ptr Word32 -- ^ destination pointer (8 x Word32) 171 -> Ptr Word32 -- ^ scratch block pointer (16 x Word32) 172 -> Registers -- ^ k 173 -> Registers -- ^ v 174 -> Word8 -- ^ separator byte 175 -> BS.ByteString -- ^ data 176 -> IO () 177 _hmac_rsb rp bp k v sep dat 178 | Arm.sha256_arm_available = Arm._hmac_rsb rp bp k v sep dat 179 | otherwise = do 180 let !key = pad_registers k 181 !rs0 = update (iv ()) (xor key (Exts.wordToWord32# 0x36363636##)) 182 !inner = _hash_vsb 64 rs0 v sep dat 183 !block = pad_registers_with_length inner 184 !rs1 = update (iv ()) (xor key (Exts.wordToWord32# 0x5C5C5C5C##)) 185 !rs = update rs1 block 186 poke_registers rp rs 187 {-# INLINABLE _hmac_rsb #-} 188 189 -- hash(v || sep || dat) with a custom initial state and extra 190 -- prefix length. used for producing a more specialized hmac. 191 _hash_vsb 192 :: Word64 -- ^ extra prefix length 193 -> Registers -- ^ initial state 194 -> Registers -- ^ v 195 -> Word8 -- ^ sep 196 -> BS.ByteString -- ^ dat 197 -> Registers 198 _hash_vsb el rs0 v sep dat@(BI.PS _ _ l) 199 | l >= 31 = 200 -- first block is complete 201 let !b0 = parse_vsb v sep dat 202 !rs1 = update rs0 b0 203 !rest = BU.unsafeDrop 31 dat 204 !rlen = l - 31 205 !rs2 = _hash_blocks rs1 rest 206 !flen = rlen `rem` 64 207 !fin = BU.unsafeDrop (rlen - flen) rest 208 !total = el + 33 + fi l 209 in if flen < 56 210 then update rs2 (parse_pad1 fin total) 211 else let !(# pen, ult #) = parse_pad2 fin total 212 in update (update rs2 pen) ult 213 | otherwise = 214 -- message < 64 bytes, goes straight to padding 215 let !total = el + 33 + fi l 216 in if 33 + l < 56 217 then update rs0 (parse_pad1_vsb v sep dat total) 218 else let !(# pen, ult #) = parse_pad2_vsb v sep dat total 219 in update (update rs0 pen) ult 220 {-# INLINABLE _hash_vsb #-} 221