Pure.hs (6034B)
1 {-# OPTIONS_HADDOCK hide #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE MagicHash #-} 4 {-# LANGUAGE UnboxedTuples #-} 5 6 -- | 7 -- Module: Crypto.Hash.SHA512.Pure 8 -- Copyright: (c) 2024 Jared Tobin 9 -- License: MIT 10 -- Maintainer: Jared Tobin <jared@ppad.tech> 11 -- 12 -- Pure Haskell SHA-512 and HMAC-SHA512 implementations for strict 13 -- ByteStrings, used when hardware SHA-512 instructions are 14 -- unavailable. 15 16 module Crypto.Hash.SHA512.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, Word64) 27 import Foreign.Ptr (Ptr) 28 import qualified GHC.Exts as Exts 29 import Crypto.Hash.SHA512.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-512, 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` 128) m 53 !total = el + fi l 54 if ll < 112 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 + 128 > l = acc 70 | otherwise = 71 let !nacc = update acc (parse m j) 72 in loop nacc (j + 128) 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-SHA512, 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 > 128 = 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.wordToWord64# 0x3636363636363636##)) 96 !block = pad_registers_with_length (_hash 128 rs0 m) 97 !rs1 = update (iv ()) (xor k (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##)) 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 64-byte result is written to the destination pointer. 107 _hmac_rr 108 :: Ptr Word64 -- ^ destination (8 Word64s) 109 -> Ptr Word64 -- ^ 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.wordToWord64# 0x3636363636363636##)) 126 !rs1 = update rs0 m 127 !inner = pad_registers_with_length rs1 128 !rs2 = update (iv ()) (xor k (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##)) 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 64-byte result is written to the destination pointer. 137 _hmac_rsb 138 :: Ptr Word64 -- ^ destination pointer (8 x Word64) 139 -> Ptr Word64 -- ^ 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 ()) 148 (xor key (Exts.wordToWord64# 0x3636363636363636##)) 149 !inner = _hash_vsb 128 rs0 v sep dat 150 !block = pad_registers_with_length inner 151 !rs1 = update (iv ()) 152 (xor key (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##)) 153 !rs = update rs1 block 154 poke_registers rp rs 155 {-# INLINABLE _hmac_rsb #-} 156 157 -- hash(v || sep || dat) with a custom initial state and extra 158 -- prefix length. used for producing a more specialized hmac. 159 _hash_vsb 160 :: Word64 -- ^ extra prefix length 161 -> Registers -- ^ initial state 162 -> Registers -- ^ v 163 -> Word8 -- ^ sep 164 -> BS.ByteString -- ^ dat 165 -> Registers 166 _hash_vsb el rs0 v sep dat@(BI.PS _ _ l) 167 | l >= 63 = 168 -- first block is complete 169 let !b0 = parse_vsb v sep dat 170 !rs1 = update rs0 b0 171 !rest = BU.unsafeDrop 63 dat 172 !rlen = l - 63 173 !rs2 = _hash_blocks rs1 rest 174 !flen = rlen `rem` 128 175 !fin = BU.unsafeDrop (rlen - flen) rest 176 !total = el + 65 + fi l 177 in if flen < 112 178 then update rs2 (parse_pad1 fin total) 179 else let !(# pen, ult #) = parse_pad2 fin total 180 in update (update rs2 pen) ult 181 | otherwise = 182 -- message < 128 bytes, goes straight to padding 183 let !total = el + 65 + fi l 184 in if 65 + l < 112 185 then update rs0 (parse_pad1_vsb v sep dat total) 186 else let !(# pen, ult #) = parse_pad2_vsb v sep dat total 187 in update (update rs0 pen) ult 188 {-# INLINABLE _hash_vsb #-} 189