Poly1305.hs (7199B)
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 = 159 BS.foldl' (B..|.) 0 (BS.packZipWith B.xor a b) == 0 160 161 -- | Produce a Poly1305 MAC for the provided message, given the 162 -- provided key. 163 -- 164 -- Per RFC8439: the key, which is essentially a /one-time/ key, 165 -- should be unique, and MUST be unpredictable for each invocation. 166 -- 167 -- The key must be exactly 256 bits in length. 168 -- 169 -- >>> mac "i'll never use this key again!!!" "a message needing authentication" 170 -- Just "O'\231Z\224\149\148\246\203[}\210\203\b\200\207" 171 mac 172 :: BS.ByteString -- ^ 256-bit one-time key 173 -> BS.ByteString -- ^ arbitrary-length message 174 -> Maybe MAC -- ^ 128-bit message authentication code 175 mac key@(BI.PS _ _ kl) msg 176 | kl /= 32 = Nothing 177 | Arm.poly1305_arm_available = 178 pure $! MAC (Arm.mac key msg) 179 | otherwise = 180 let (clamp . _roll16 -> r, _roll16 -> s) = BS.splitAt 16 key 181 in pure $! (MAC (_poly1305_loop r s msg)) 182 183 -- p = 2^130 - 5 184 -- 185 -- mask for the low 130 bits 186 mask130 :: Wider 187 mask130 = 0x3ffffffffffffffffffffffffffffffff 188 {-# INLINE mask130 #-} 189 190 -- partial reduction to [0, 2 ^ 131) 191 reduce_partial :: Wider -> Wider 192 reduce_partial x = 193 let !lo = x `W.and` mask130 194 !hi = shr130 x 195 in lo + 5 * hi 196 {-# INLINE reduce_partial #-} 197 198 -- [0, 2 ^ 131) -> [0, p) 199 reduce_full :: Wider -> Wider 200 reduce_full h = 201 let !lo = h `W.and` mask130 202 !hi = shr130 h 203 !h' = lo + 5 * hi 204 !h_5 = h' + 5 205 !reduced = h_5 `W.and` mask130 206 !carry = shr130 h_5 207 !gte = W.lt 0 carry 208 in W.select h' reduced gte 209 {-# INLINE reduce_full #-} 210 211 _poly1305_loop :: Wider -> Wider -> BS.ByteString -> BS.ByteString 212 _poly1305_loop !r !s !msg = 213 let loop !acc !bs = case BS.splitAt 16 bs of 214 (chunk@(BI.PS _ _ l), etc) 215 | l == 0 -> 216 let !final = reduce_full (reduce_partial acc) 217 in unroll16 (final + s) 218 | otherwise -> 219 let !n = _roll16 chunk `W.or` set_hi l 220 !prod = r * (acc + n) 221 !nacc = reduce_partial (reduce_partial prod) 222 in loop nacc etc 223 in loop 0 msg 224 {-# INLINE _poly1305_loop #-} 225