SHA512.hs (7280B)
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.SHA512 10 -- Copyright: (c) 2024 Jared Tobin 11 -- License: MIT 12 -- Maintainer: Jared Tobin <jared@ppad.tech> 13 -- 14 -- SHA-512 and HMAC-SHA512 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.SHA512 ( 24 -- * SHA-512 message digest functions 25 hash 26 , Lazy.hash_lazy 27 28 -- * SHA512-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, Word64) 42 import Foreign.Ptr (Ptr) 43 import qualified GHC.Exts as Exts 44 import qualified Crypto.Hash.SHA512.Arm as Arm 45 import Crypto.Hash.SHA512.Internal 46 import qualified Crypto.Hash.SHA512.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-512. 58 -- 59 -- The 512-bit output digest is returned as a strict bytestring. 60 -- 61 -- >>> hash "strict bytestring input" 62 -- "<strict 512-bit message digest>" 63 hash :: BS.ByteString -> BS.ByteString 64 hash m 65 | Arm.sha512_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` 128) m 77 !total = el + fi l 78 if ll < 112 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 + 128 > l = acc 94 | otherwise = 95 let !nacc = update acc (parse m j) 96 in loop nacc (j + 128) 97 {-# INLINABLE _hash_blocks #-} 98 99 -- hmac ---------------------------------------------------------------------- 100 101 -- | Produce a message authentication code for a strict bytestring, 102 -- based on the provided (strict, bytestring) key, via SHA-512. 103 -- 104 -- The 512-bit MAC is returned as a strict bytestring. 105 -- 106 -- Per RFC 2104, the key /should/ be a minimum of 64 bytes long. Keys 107 -- exceeding 128 bytes in length will first be hashed (via SHA-512). 108 -- 109 -- >>> hmac "strict bytestring key" "strict bytestring input" 110 -- "<strict 512-bit MAC>" 111 hmac :: BS.ByteString -> BS.ByteString -> MAC 112 hmac k m 113 | Arm.sha512_arm_available = MAC (Arm.hmac k m) 114 | otherwise = MAC (cat (_hmac (prep_key k) m)) 115 {-# INLINABLE hmac #-} 116 117 prep_key :: BS.ByteString -> Block 118 prep_key k@(BI.PS _ _ l) 119 | l > 128 = parse_key (hash k) 120 | otherwise = parse_key k 121 {-# INLINABLE prep_key #-} 122 123 _hmac 124 :: Block -- ^ padded key 125 -> BS.ByteString -- ^ message 126 -> Registers 127 _hmac k m = 128 let !rs0 = update (iv ()) (xor k (Exts.wordToWord64# 0x3636363636363636##)) 129 !block = pad_registers_with_length (_hash 128 rs0 m) 130 !rs1 = update (iv ()) (xor k (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##)) 131 in update rs1 block 132 {-# INLINABLE _hmac #-} 133 134 -- the following functions are useful when we want to avoid allocating certain 135 -- components of the HMAC key and message on the heap. 136 137 -- Computes hmac(k, v) when k and v are Registers. 138 -- 139 -- The 64-byte result is written to the destination pointer. 140 _hmac_rr 141 :: Ptr Word64 -- ^ destination (8 Word64s) 142 -> Ptr Word64 -- ^ scratch block buffer (16 Word64s) 143 -> Registers -- ^ key 144 -> Registers -- ^ message 145 -> IO () 146 _hmac_rr rp bp k m 147 | Arm.sha512_arm_available = Arm._hmac_rr rp bp k m 148 | otherwise = do 149 let !key = pad_registers k 150 !block = pad_registers_with_length m 151 !rs = _hmac_bb key block 152 poke_registers rp rs 153 {-# INLINABLE _hmac_rr #-} 154 155 _hmac_bb 156 :: Block -- ^ key 157 -> Block -- ^ message 158 -> Registers 159 _hmac_bb k m = 160 let !rs0 = update (iv ()) (xor k (Exts.wordToWord64# 0x3636363636363636##)) 161 !rs1 = update rs0 m 162 !inner = pad_registers_with_length rs1 163 !rs2 = update (iv ()) (xor k (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##)) 164 in update rs2 inner 165 {-# INLINABLE _hmac_bb #-} 166 167 -- Calculate hmac(k, m) where m is the concatenation of v (registers), a 168 -- separator byte, and a ByteString. This avoids allocating 'v' on the 169 -- heap. 170 -- 171 -- The 64-byte result is written to the destination pointer. 172 _hmac_rsb 173 :: Ptr Word64 -- ^ destination pointer (8 x Word64) 174 -> Ptr Word64 -- ^ scratch block pointer (16 x Word64) 175 -> Registers -- ^ k 176 -> Registers -- ^ v 177 -> Word8 -- ^ separator byte 178 -> BS.ByteString -- ^ data 179 -> IO () 180 _hmac_rsb rp bp k v sep dat 181 | Arm.sha512_arm_available = Arm._hmac_rsb rp bp k v sep dat 182 | otherwise = do 183 let !key = pad_registers k 184 !rs0 = update (iv ()) (xor key (Exts.wordToWord64# 0x3636363636363636##)) 185 !inner = _hash_vsb 128 rs0 v sep dat 186 !block = pad_registers_with_length inner 187 !rs1 = update (iv ()) (xor key (Exts.wordToWord64# 0x5C5C5C5C5C5C5C5C##)) 188 !rs = update rs1 block 189 poke_registers rp rs 190 {-# INLINABLE _hmac_rsb #-} 191 192 -- hash(v || sep || dat) with a custom initial state and extra 193 -- prefix length. used for producing a more specialized hmac. 194 _hash_vsb 195 :: Word64 -- ^ extra prefix length 196 -> Registers -- ^ initial state 197 -> Registers -- ^ v 198 -> Word8 -- ^ sep 199 -> BS.ByteString -- ^ dat 200 -> Registers 201 _hash_vsb el rs0 v sep dat@(BI.PS _ _ l) 202 | l >= 63 = 203 -- first block is complete 204 let !b0 = parse_vsb v sep dat 205 !rs1 = update rs0 b0 206 !rest = BU.unsafeDrop 63 dat 207 !rlen = l - 63 208 !rs2 = _hash_blocks rs1 rest 209 !flen = rlen `rem` 128 210 !fin = BU.unsafeDrop (rlen - flen) rest 211 !total = el + 65 + fi l 212 in if flen < 112 213 then update rs2 (parse_pad1 fin total) 214 else let !(# pen, ult #) = parse_pad2 fin total 215 in update (update rs2 pen) ult 216 | otherwise = 217 -- message < 128 bytes, goes straight to padding 218 let !total = el + 65 + fi l 219 in if 65 + l < 112 220 then update rs0 (parse_pad1_vsb v sep dat total) 221 else let !(# pen, ult #) = parse_pad2_vsb v sep dat total 222 in update (update rs0 pen) ult 223 {-# INLINABLE _hash_vsb #-} 224