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