Native.hs (8534B)
1 {-# OPTIONS_HADDOCK hide #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE MagicHash #-} 4 {-# LANGUAGE PatternSynonyms #-} 5 {-# LANGUAGE UnboxedTuples #-} 6 7 -- | 8 -- Module: Crypto.Hash.SHA256.Native 9 -- Copyright: (c) 2024 Jared Tobin 10 -- License: MIT 11 -- Maintainer: Jared Tobin <jared@ppad.tech> 12 -- 13 -- Hardware-accelerated SHA-256, via the ARM SHA2 or x86 SHA 14 -- extensions. 15 16 module Crypto.Hash.SHA256.Native ( 17 sha256_native_available 18 , hash 19 , hmac 20 , _hmac_rr 21 , _hmac_rsb 22 ) where 23 24 import qualified Data.ByteString as BS 25 import qualified Data.ByteString.Internal as BI 26 import qualified Data.ByteString.Unsafe as BU 27 import Data.Word (Word8, Word32, Word64) 28 import Foreign.C.Types (CInt(..)) 29 import Foreign.Marshal.Alloc (allocaBytes) 30 import Foreign.Ptr (Ptr) 31 import qualified GHC.Exts as Exts 32 import qualified GHC.IO (IO(..)) 33 import qualified GHC.Ptr 34 import Crypto.Hash.SHA256.Internal hiding (update) 35 import System.IO.Unsafe (unsafeDupablePerformIO) 36 37 -- ffi ------------------------------------------------------------------------ 38 39 foreign import ccall unsafe "sha256_block_native" 40 c_sha256_block :: Ptr Word32 -> Ptr Word32 -> IO () 41 42 foreign import ccall unsafe "sha256_native_available" 43 c_sha256_native_available :: IO CInt 44 45 -- utilities ------------------------------------------------------------------ 46 47 fi :: (Integral a, Num b) => a -> b 48 fi = fromIntegral 49 {-# INLINE fi #-} 50 51 peek_registers 52 :: Ptr Word32 53 -> Registers 54 peek_registers (GHC.Ptr.Ptr addr) = R 55 (Exts.indexWord32OffAddr# addr 0#) 56 (Exts.indexWord32OffAddr# addr 1#) 57 (Exts.indexWord32OffAddr# addr 2#) 58 (Exts.indexWord32OffAddr# addr 3#) 59 (Exts.indexWord32OffAddr# addr 4#) 60 (Exts.indexWord32OffAddr# addr 5#) 61 (Exts.indexWord32OffAddr# addr 6#) 62 (Exts.indexWord32OffAddr# addr 7#) 63 {-# INLINE peek_registers #-} 64 65 poke_block :: Ptr Word32 -> Block -> IO () 66 poke_block 67 (GHC.Ptr.Ptr addr) 68 (B w00 w01 w02 w03 w04 w05 w06 w07 w08 w09 w10 w11 w12 w13 w14 w15) 69 = GHC.IO.IO $ \s00 -> 70 case Exts.writeWord32OffAddr# addr 00# w00 s00 of { s01 -> 71 case Exts.writeWord32OffAddr# addr 01# w01 s01 of { s02 -> 72 case Exts.writeWord32OffAddr# addr 02# w02 s02 of { s03 -> 73 case Exts.writeWord32OffAddr# addr 03# w03 s03 of { s04 -> 74 case Exts.writeWord32OffAddr# addr 04# w04 s04 of { s05 -> 75 case Exts.writeWord32OffAddr# addr 05# w05 s05 of { s06 -> 76 case Exts.writeWord32OffAddr# addr 06# w06 s06 of { s07 -> 77 case Exts.writeWord32OffAddr# addr 07# w07 s07 of { s08 -> 78 case Exts.writeWord32OffAddr# addr 08# w08 s08 of { s09 -> 79 case Exts.writeWord32OffAddr# addr 09# w09 s09 of { s10 -> 80 case Exts.writeWord32OffAddr# addr 10# w10 s10 of { s11 -> 81 case Exts.writeWord32OffAddr# addr 11# w11 s11 of { s12 -> 82 case Exts.writeWord32OffAddr# addr 12# w12 s12 of { s13 -> 83 case Exts.writeWord32OffAddr# addr 13# w13 s13 of { s14 -> 84 case Exts.writeWord32OffAddr# addr 14# w14 s14 of { s15 -> 85 case Exts.writeWord32OffAddr# addr 15# w15 s15 of { s16 -> 86 (# s16, () #) }}}}}}}}}}}}}}}} 87 {-# INLINE poke_block #-} 88 89 -- update --------------------------------------------------------------------- 90 91 update :: Ptr Word32 -> Ptr Word32 -> Block -> IO () 92 update rp bp block = do 93 poke_block bp block 94 c_sha256_block rp bp 95 {-# INLINE update #-} 96 97 -- api ----------------------------------------------------------------------- 98 99 -- | Are hardware SHA-256 instructions available? 100 sha256_native_available :: Bool 101 sha256_native_available = unsafeDupablePerformIO c_sha256_native_available /= 0 102 {-# NOINLINE sha256_native_available #-} 103 104 hash 105 :: BS.ByteString 106 -> BS.ByteString 107 hash m = unsafeDupablePerformIO $ 108 allocaBytes 32 $ \rp -> 109 allocaBytes 64 $ \bp -> do 110 poke_registers rp (iv ()) 111 _hash rp bp 0 m 112 let !rs = peek_registers rp 113 pure (cat rs) 114 115 _hash 116 :: Ptr Word32 -- ^ register state 117 -> Ptr Word32 -- ^ block state 118 -> Word64 -- ^ extra prefix length, for padding calculation 119 -> BS.ByteString -- ^ input 120 -> IO () 121 _hash rp bp el m@(BI.PS _ _ l) = do 122 hash_blocks rp bp m 123 let !fin@(BI.PS _ _ ll) = BU.unsafeDrop (l - l `rem` 64) m 124 !total = el + fi l 125 if ll < 56 126 then do 127 let !ult = parse_pad1 fin total 128 update rp bp ult 129 else do 130 let !(# pen, ult #) = parse_pad2 fin total 131 update rp bp pen 132 update rp bp ult 133 {-# INLINABLE _hash #-} 134 135 hash_blocks 136 :: Ptr Word32 -- ^ register state 137 -> Ptr Word32 -- ^ block state 138 -> BS.ByteString -- ^ input 139 -> IO () 140 hash_blocks rp bp m@(BI.PS _ _ l) = loop 0 where 141 loop !j 142 | j + 64 > l = pure () 143 | otherwise = do 144 let !block = parse m j 145 update rp bp block 146 loop (j + 64) 147 {-# INLINE hash_blocks #-} 148 149 -- hmac ------------------------------------------------------------------------ 150 151 hmac :: BS.ByteString -> BS.ByteString -> BS.ByteString 152 hmac k m = unsafeDupablePerformIO $ 153 allocaBytes 32 $ \rp -> 154 allocaBytes 64 $ \bp -> do 155 _hmac rp bp (prep_key k) m 156 pure (cat (peek_registers rp)) 157 158 prep_key :: BS.ByteString -> Block 159 prep_key k@(BI.PS _ _ l) 160 | l > 64 = parse_key (hash k) 161 | otherwise = parse_key k 162 {-# INLINABLE prep_key #-} 163 164 -- assume padded key as block. 165 _hmac 166 :: Ptr Word32 -- ^ register state 167 -> Ptr Word32 -- ^ block state 168 -> Block -- ^ padded key 169 -> BS.ByteString -- ^ message 170 -> IO () 171 _hmac rp bp k m = do 172 poke_registers rp (iv ()) 173 update rp bp (xor k (Exts.wordToWord32# 0x36363636##)) 174 _hash rp bp 64 m 175 let !block = pad_registers_with_length (peek_registers rp) 176 poke_registers rp (iv ()) 177 update rp bp (xor k (Exts.wordToWord32# 0x5C5C5C5C##)) 178 update rp bp block 179 {-# NOINLINE _hmac #-} 180 181 _hmac_rr 182 :: Ptr Word32 -- ^ register state 183 -> Ptr Word32 -- ^ block state 184 -> Registers -- ^ key 185 -> Registers -- ^ message 186 -> IO () 187 _hmac_rr rp bp k m = do 188 let !key = pad_registers k 189 !block = pad_registers_with_length m 190 _hmac_bb rp bp key block 191 {-# INLINABLE _hmac_rr #-} 192 193 _hmac_bb 194 :: Ptr Word32 -- ^ register state 195 -> Ptr Word32 -- ^ block state 196 -> Block -- ^ padded key 197 -> Block -- ^ padded message 198 -> IO () 199 _hmac_bb rp bp k m = do 200 poke_registers rp (iv ()) 201 update rp bp (xor k (Exts.wordToWord32# 0x36363636##)) 202 update rp bp m 203 let !inner = pad_registers_with_length (peek_registers rp) 204 poke_registers rp (iv ()) 205 update rp bp (xor k (Exts.wordToWord32# 0x5C5C5C5C##)) 206 update rp bp inner 207 {-# INLINABLE _hmac_bb #-} 208 209 -- | HMAC(key, v || sep || data) using hardware SHA-256 instructions. 210 -- Writes result to destination pointer. 211 _hmac_rsb 212 :: Ptr Word32 -- ^ destination (8 Word32s) 213 -> Ptr Word32 -- ^ scratch block buffer (16 Word32s) 214 -> Registers -- ^ key 215 -> Registers -- ^ v 216 -> Word8 -- ^ separator byte 217 -> BS.ByteString -- ^ data 218 -> IO () 219 _hmac_rsb rp bp k v sep dat = do 220 poke_registers rp (iv ()) 221 let !key = pad_registers k 222 update rp bp (xor key (Exts.wordToWord32# 0x36363636##)) 223 _hash_vsb rp bp 64 v sep dat 224 let !inner = pad_registers_with_length (peek_registers rp) 225 poke_registers rp (iv ()) 226 update rp bp (xor key (Exts.wordToWord32# 0x5C5C5C5C##)) 227 update rp bp inner 228 {-# INLINABLE _hmac_rsb #-} 229 230 -- | Hash (v || sep || dat) with hardware SHA-256 instructions. 231 -- Assumes register state already initialized at rp. 232 _hash_vsb 233 :: Ptr Word32 -- ^ register state 234 -> Ptr Word32 -- ^ block buffer 235 -> Word64 -- ^ extra prefix length 236 -> Registers -- ^ v 237 -> Word8 -- ^ sep 238 -> BS.ByteString -- ^ dat 239 -> IO () 240 _hash_vsb rp bp el v sep dat@(BI.PS _ _ l) 241 | l >= 31 = do 242 -- first block is complete: v || sep || dat[0:31] 243 let !b0 = parse_vsb v sep dat 244 update rp bp b0 245 -- hash remaining complete blocks from dat[31:] 246 let !rest = BU.unsafeDrop 31 dat 247 !restLen = l - 31 248 hash_blocks rp bp rest 249 -- handle final padding 250 let !finLen = restLen `rem` 64 251 !fin = BU.unsafeDrop (restLen - finLen) rest 252 !total = el + 33 + fi l 253 if finLen < 56 254 then update rp bp (parse_pad1 fin total) 255 else do 256 let !(# pen, ult #) = parse_pad2 fin total 257 update rp bp pen 258 update rp bp ult 259 | otherwise = do 260 -- message < 64 bytes total, straight to padding 261 let !total = el + 33 + fi l 262 if 33 + l < 56 263 then update rp bp (parse_pad1_vsb v sep dat total) 264 else do 265 let !(# pen, ult #) = parse_pad2_vsb v sep dat total 266 update rp bp pen 267 update rp bp ult 268 {-# INLINABLE _hash_vsb #-}