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