Poly1305.hs (7630B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE DerivingStrategies #-} 4 {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 {-# LANGUAGE LambdaCase #-} 6 {-# LANGUAGE MagicHash #-} 7 {-# LANGUAGE ViewPatterns #-} 8 {-# LANGUAGE UnboxedTuples #-} 9 10 -- | 11 -- Module: Crypto.MAC.Poly1305 12 -- Copyright: (c) 2025 Jared Tobin 13 -- License: MIT 14 -- Maintainer: Jared Tobin <jared@ppad.tech> 15 -- 16 -- A pure Poly1305 MAC implementation, as specified by 17 -- [RFC 8439](https://datatracker.ietf.org/doc/html/rfc8439). 18 19 module Crypto.MAC.Poly1305 ( 20 -- * Poly1305 message authentication code 21 MAC(..) 22 , mac 23 24 -- testing 25 , _poly1305_loop 26 , _roll16 27 ) where 28 29 import qualified Crypto.MAC.Poly1305.Arm as Arm 30 import qualified Data.Bits as B 31 import qualified Data.ByteString as BS 32 import qualified Data.ByteString.Internal as BI 33 import qualified Data.ByteString.Unsafe as BU 34 import Data.Word (Word8) 35 import Data.Word.Limb (Limb(..)) 36 import qualified Data.Word.Limb as L 37 import Data.Word.Wider (Wider(..)) 38 import qualified Data.Word.Wider as W 39 import qualified Foreign.Storable as Storable (pokeByteOff) 40 import qualified GHC.Exts as Exts 41 import qualified GHC.Word (Word8(..)) 42 43 -- utilities ------------------------------------------------------------------ 44 45 -- convert a Word8 to a Limb 46 limb :: Word8 -> Limb 47 limb (GHC.Word.W8# (Exts.word8ToWord# -> w)) = Limb w 48 {-# INLINABLE limb #-} 49 50 -- convert a Limb to a Word8 51 word8 :: Limb -> Word8 52 word8 (Limb w) = GHC.Word.W8# (Exts.wordToWord8# w) 53 {-# INLINABLE word8 #-} 54 55 -- convert a Limb to a Word8 after right-shifting 56 word8s :: Limb -> Exts.Int# -> Word8 57 word8s l s = 58 let !(Limb w) = L.shr# l s 59 in GHC.Word.W8# (Exts.wordToWord8# w) 60 {-# INLINABLE word8s #-} 61 62 -- 128-bit little-endian bytestring decoding 63 _roll16 :: BS.ByteString -> Wider 64 _roll16 bs@(BI.PS _ _ l) = 65 let byte :: Int -> Limb 66 byte i 67 | i < l = limb (BU.unsafeIndex bs i) 68 | otherwise = Limb 0## 69 {-# INLINE byte #-} 70 !w0 = (byte 07 `L.shl#` 56#) 71 `L.or#` (byte 06 `L.shl#` 48#) 72 `L.or#` (byte 05 `L.shl#` 40#) 73 `L.or#` (byte 04 `L.shl#` 32#) 74 `L.or#` (byte 03 `L.shl#` 24#) 75 `L.or#` (byte 02 `L.shl#` 16#) 76 `L.or#` (byte 01 `L.shl#` 08#) 77 `L.or#` byte 00 78 !w1 = (byte 15 `L.shl#` 56#) 79 `L.or#` (byte 14 `L.shl#` 48#) 80 `L.or#` (byte 13 `L.shl#` 40#) 81 `L.or#` (byte 12 `L.shl#` 32#) 82 `L.or#` (byte 11 `L.shl#` 24#) 83 `L.or#` (byte 10 `L.shl#` 16#) 84 `L.or#` (byte 09 `L.shl#` 08#) 85 `L.or#` byte 08 86 in Wider (# w0, w1, Limb 0##, Limb 0## #) 87 {-# INLINE _roll16 #-} 88 89 -- 128-bit little-endian bytestring encoding 90 unroll16 :: Wider -> BS.ByteString 91 unroll16 (Wider (# w0, w1, _, _ #)) = 92 BI.unsafeCreate 16 $ \ptr -> do 93 -- w0 94 Storable.pokeByteOff ptr 00 (word8 w0) 95 Storable.pokeByteOff ptr 01 (word8s w0 08#) 96 Storable.pokeByteOff ptr 02 (word8s w0 16#) 97 Storable.pokeByteOff ptr 03 (word8s w0 24#) 98 Storable.pokeByteOff ptr 04 (word8s w0 32#) 99 Storable.pokeByteOff ptr 05 (word8s w0 40#) 100 Storable.pokeByteOff ptr 06 (word8s w0 48#) 101 Storable.pokeByteOff ptr 07 (word8s w0 56#) 102 -- w1 103 Storable.pokeByteOff ptr 08 (word8 w1) 104 Storable.pokeByteOff ptr 09 (word8s w1 08#) 105 Storable.pokeByteOff ptr 10 (word8s w1 16#) 106 Storable.pokeByteOff ptr 11 (word8s w1 24#) 107 Storable.pokeByteOff ptr 12 (word8s w1 32#) 108 Storable.pokeByteOff ptr 13 (word8s w1 40#) 109 Storable.pokeByteOff ptr 14 (word8s w1 48#) 110 Storable.pokeByteOff ptr 15 (word8s w1 56#) 111 {-# INLINABLE unroll16 #-} 112 113 -- set high bit for chunk of length l (max 16) 114 set_hi :: Int -> Wider 115 set_hi l 116 | l < 8 = W.shl_limb 1 (8 * l) 117 | l < 16 = Wider (# Limb 0##, L.shl# (Limb 1##) s, Limb 0##, Limb 0## #) 118 | otherwise = Wider (# Limb 0##, Limb 0##, Limb 1##, Limb 0## #) 119 where 120 !(Exts.I# s) = 8 * (l - 8) 121 {-# INLINE set_hi #-} 122 123 -- bespoke constant-time 130-bit right shift 124 shr130 :: Wider -> Wider 125 shr130 (Wider (# _, _, l2, l3 #)) = 126 let !r0 = L.or# (L.shr# l2 2#) (L.shl# l3 62#) 127 !r1 = L.shr# l3 2# 128 in Wider (# r0, r1, Limb 0##, Limb 0## #) 129 {-# INLINE shr130 #-} 130 131 ------------------------------------------------------------------------------- 132 133 clamp :: Wider -> Wider 134 clamp r = r `W.and` 0x0ffffffc0ffffffc0ffffffc0fffffff 135 {-# INLINE clamp #-} 136 137 -- | A Poly1305 message authentication code. 138 -- 139 -- Note that you should compare MACs for equality using the 'Eq' 140 -- instance, which performs the comparison in constant time, instead 141 -- of unwrapping and comparing the underlying 'ByteStrings'. 142 -- 143 -- >>> let Just foo@(MAC bs0) = mac key "hi" 144 -- >>> let Just bar@(MAC bs1) = mac key "there" 145 -- >>> foo == bar -- do this 146 -- False 147 -- >>> bs0 == bs1 -- don't do this 148 -- False 149 newtype MAC = MAC BS.ByteString 150 deriving newtype Show 151 152 instance Eq MAC where 153 -- | A constant-time equality check for message authentication codes. 154 -- 155 -- Runs in variable-time only for invalid inputs. 156 (MAC a@(BI.PS _ _ la)) == (MAC b@(BI.PS _ _ lb)) 157 | la /= lb = False 158 | otherwise = go 0 0 159 where 160 -- fused fold: OR the bytewise XORs into an accumulator 161 -- directly, rather than via packZipWith, so no intermediate 162 -- ByteString holding the (secret-derived) difference bytes 163 -- is ever materialised on the heap. 164 go :: Word8 -> Int -> Bool 165 go !acc !i 166 | i == la = acc == 0 167 | otherwise = 168 let !x = BU.unsafeIndex a i 169 !y = BU.unsafeIndex b i 170 in go (acc B..|. B.xor x y) (i + 1) 171 172 -- | Produce a Poly1305 MAC for the provided message, given the 173 -- provided key. 174 -- 175 -- Per RFC8439: the key, which is essentially a /one-time/ key, 176 -- should be unique, and MUST be unpredictable for each invocation. 177 -- 178 -- The key must be exactly 256 bits in length. 179 -- 180 -- >>> mac "i'll never use this key again!!!" "a message needing authentication" 181 -- Just "O'\231Z\224\149\148\246\203[}\210\203\b\200\207" 182 mac 183 :: BS.ByteString -- ^ 256-bit one-time key 184 -> BS.ByteString -- ^ arbitrary-length message 185 -> Maybe MAC -- ^ 128-bit message authentication code 186 mac key@(BI.PS _ _ kl) msg 187 | kl /= 32 = Nothing 188 | Arm.poly1305_arm_available = 189 pure $! MAC (Arm.mac key msg) 190 | otherwise = 191 let (clamp . _roll16 -> r, _roll16 -> s) = BS.splitAt 16 key 192 in pure $! (MAC (_poly1305_loop r s msg)) 193 194 -- p = 2^130 - 5 195 -- 196 -- mask for the low 130 bits 197 mask130 :: Wider 198 mask130 = 0x3ffffffffffffffffffffffffffffffff 199 {-# INLINE mask130 #-} 200 201 -- partial reduction to [0, 2 ^ 131) 202 reduce_partial :: Wider -> Wider 203 reduce_partial x = 204 let !lo = x `W.and` mask130 205 !hi = shr130 x 206 in lo + 5 * hi 207 {-# INLINE reduce_partial #-} 208 209 -- [0, 2 ^ 131) -> [0, p) 210 reduce_full :: Wider -> Wider 211 reduce_full h = 212 let !lo = h `W.and` mask130 213 !hi = shr130 h 214 !h' = lo + 5 * hi 215 !h_5 = h' + 5 216 !reduced = h_5 `W.and` mask130 217 !carry = shr130 h_5 218 !gte = W.lt 0 carry 219 in W.select h' reduced gte 220 {-# INLINE reduce_full #-} 221 222 _poly1305_loop :: Wider -> Wider -> BS.ByteString -> BS.ByteString 223 _poly1305_loop !r !s !msg = 224 let loop !acc !bs = case BS.splitAt 16 bs of 225 (chunk@(BI.PS _ _ l), etc) 226 | l == 0 -> 227 let !final = reduce_full (reduce_partial acc) 228 in unroll16 (final + s) 229 | otherwise -> 230 let !n = _roll16 chunk `W.or` set_hi l 231 !prod = r * (acc + n) 232 !nacc = reduce_partial (reduce_partial prod) 233 in loop nacc etc 234 in loop 0 msg 235 {-# INLINE _poly1305_loop #-} 236