ChaCha20Poly1305.hs (6177B)
1 {-# OPTIONS_HADDOCK prune #-} 2 {-# LANGUAGE BangPatterns #-} 3 {-# LANGUAGE LambdaCase #-} 4 {-# LANGUAGE OverloadedStrings #-} 5 {-# LANGUAGE ViewPatterns #-} 6 7 -- | 8 -- Module: Crypto.AEAD.ChaCha20Poly1305 9 -- Copyright: (c) 2025 Jared Tobin 10 -- License: MIT 11 -- Maintainer: Jared Tobin <jared@ppad.tech> 12 -- 13 -- A pure AEAD-ChaCha20-Poly1305 implementation, as specified by 14 -- [RFC 8439](https://datatracker.ietf.org/doc/html/rfc8439). 15 16 module Crypto.AEAD.ChaCha20Poly1305 ( 17 -- * AEAD construction 18 encrypt 19 , decrypt 20 21 -- * Error information 22 , Error(..) 23 24 -- testing 25 , _poly1305_key_gen 26 ) where 27 28 import Data.Barrier (barrier) 29 import qualified Crypto.Cipher.ChaCha20 as ChaCha20 30 import qualified Crypto.MAC.Poly1305 as Poly1305 31 import Data.Bits ((.>>.)) 32 import qualified Data.Bits as B 33 import qualified Data.ByteString as BS 34 import qualified Data.ByteString.Internal as BI 35 import qualified Data.ByteString.Unsafe as BU 36 import Data.Word (Word8, Word64) 37 38 fi :: (Integral a, Num b) => a -> b 39 fi = fromIntegral 40 {-# INLINE fi #-} 41 42 -- constant-time equality comparison on bytestrings. fused fold: OR 43 -- the bytewise XORs into an accumulator directly, rather than via 44 -- packZipWith, so no intermediate ByteString holding the 45 -- (secret-derived) difference bytes is ever materialised on the 46 -- heap. The accumulator is routed through 'barrier' before the 47 -- zero-test so the LLVM backend cannot recover the array-equality 48 -- idiom and short-circuit on the first mismatch (see "Data.Barrier"). 49 ct_eq :: BS.ByteString -> BS.ByteString -> Bool 50 ct_eq a@(BI.PS _ _ la) b@(BI.PS _ _ lb) 51 | la /= lb = False 52 | otherwise = go 0 0 53 where 54 go :: Word8 -> Int -> Bool 55 go !acc !i 56 | i == la = barrier acc == 0 57 | otherwise = 58 let !x = BU.unsafeIndex a i 59 !y = BU.unsafeIndex b i 60 in go (acc B..|. B.xor x y) (i + 1) 61 {-# INLINE ct_eq #-} 62 63 -- little-endian bytestring encoding 64 unroll :: Word64 -> BS.ByteString 65 unroll i = case i of 66 0 -> BS.singleton 0 67 _ -> BS.unfoldr coalg i 68 where 69 coalg = \case 70 0 -> Nothing 71 m -> Just $! (fi m, m .>>. 8) 72 {-# INLINE unroll #-} 73 74 -- little-endian bytestring encoding for 64-bit ints, right-padding with zeros 75 unroll8 :: Word64 -> BS.ByteString 76 unroll8 (unroll -> u@(BI.PS _ _ l)) 77 | l < 8 = u <> BS.replicate (8 - l) 0 78 | otherwise = u 79 {-# INLINE unroll8 #-} 80 81 -- RFC8439 2.6 82 83 _poly1305_key_gen 84 :: BS.ByteString -- ^ 256-bit initial keying material 85 -> BS.ByteString -- ^ 96-bit nonce 86 -> Either Error BS.ByteString -- ^ 256-bit key (suitable for poly1305) 87 _poly1305_key_gen key nonce = case ChaCha20.block key 0 nonce of 88 Left ChaCha20.InvalidKey -> Left InvalidKey 89 Left ChaCha20.InvalidNonce -> Left InvalidNonce 90 Right k -> pure (BS.take 32 k) 91 {-# INLINEABLE _poly1305_key_gen #-} 92 93 pad16 :: BS.ByteString -> BS.ByteString 94 pad16 (BI.PS _ _ l) 95 | l `rem` 16 == 0 = mempty 96 | otherwise = BS.replicate (16 - l `rem` 16) 0 97 {-# INLINE pad16 #-} 98 99 -- | Error values. 100 data Error = 101 InvalidKey -- ^ the provided key was not 256 bits long 102 | InvalidNonce -- ^ the provided nonce was not 96 bits long 103 | InvalidMAC -- ^ the provided MAC does not authenticate the ciphertext 104 deriving (Eq, Show) 105 106 -- RFC8439 2.8 107 108 -- | Perform authenticated encryption on a plaintext and some additional 109 -- authenticated data, given a 256-bit key and 96-bit nonce, using 110 -- AEAD-ChaCha20-Poly1305. 111 -- 112 -- Produces a ciphertext and 128-bit message authentication code pair. 113 -- 114 -- >>> let key = "don't tell anyone my secret key!" 115 -- >>> let non = "or my nonce!" 116 -- >>> let pan = "and here's my plaintext" 117 -- >>> let aad = "i approve this message" 118 -- >>> let Right (cip, mac) = encrypt aad key nonce pan 119 -- >>> (cip, mac) 120 -- <(ciphertext, 128-bit MAC)> 121 encrypt 122 :: BS.ByteString -- ^ arbitrary-length additional authenticated data 123 -> BS.ByteString -- ^ 256-bit key 124 -> BS.ByteString -- ^ 96-bit nonce 125 -> BS.ByteString -- ^ arbitrary-length plaintext 126 -> Either Error (BS.ByteString, BS.ByteString) -- ^ (ciphertext, 128-bit MAC) 127 encrypt aad key nonce plaintext 128 | BS.length key /= 32 = Left InvalidKey 129 | BS.length nonce /= 12 = Left InvalidNonce 130 | otherwise = do 131 otk <- _poly1305_key_gen key nonce 132 case ChaCha20.cipher key 1 nonce plaintext of 133 Left ChaCha20.InvalidKey -> Left InvalidKey -- impossible, but.. 134 Left ChaCha20.InvalidNonce -> Left InvalidNonce -- ditto 135 Right cip -> do 136 let md0 = aad <> pad16 aad 137 md1 = md0 <> cip <> pad16 cip 138 md2 = md1 <> unroll8 (fi (BS.length aad)) 139 md3 = md2 <> unroll8 (fi (BS.length cip)) 140 case Poly1305.mac otk md3 of 141 Nothing -> Left InvalidKey 142 Just (Poly1305.MAC tag) -> pure (cip, tag) 143 144 -- | Decrypt an authenticated ciphertext, given a message authentication 145 -- code and some additional authenticated data, via a 256-bit key and 146 -- 96-bit nonce. 147 -- 148 -- >>> decrypt aad key non (cip, mac) 149 -- Right "and here's my plaintext" 150 -- >>> decrypt aad key non (cip, "it's a valid mac") 151 -- Left InvalidMAC 152 decrypt 153 :: BS.ByteString -- ^ arbitrary-length AAD 154 -> BS.ByteString -- ^ 256-bit key 155 -> BS.ByteString -- ^ 96-bit nonce 156 -> (BS.ByteString, BS.ByteString) -- ^ (arbitrary-length ciphertext, 128-bit MAC) 157 -> Either Error BS.ByteString 158 decrypt aad key nonce (cip, mac) 159 | BS.length key /= 32 = Left InvalidKey 160 | BS.length nonce /= 12 = Left InvalidNonce 161 | BS.length mac /= 16 = Left InvalidMAC 162 | otherwise = do 163 otk <- _poly1305_key_gen key nonce 164 let md0 = aad <> pad16 aad 165 md1 = md0 <> cip <> pad16 cip 166 md2 = md1 <> unroll8 (fi (BS.length aad)) 167 md3 = md2 <> unroll8 (fi (BS.length cip)) 168 case Poly1305.mac otk md3 of 169 Nothing -> Left InvalidKey 170 Just (Poly1305.MAC tag) 171 | ct_eq mac tag -> case ChaCha20.cipher key 1 nonce cip of 172 Left ChaCha20.InvalidKey -> Left InvalidKey 173 Left ChaCha20.InvalidNonce -> Left InvalidNonce 174 Right v -> pure v 175 | otherwise -> 176 Left InvalidMAC 177