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