-- |
-- Module      : Crypto.Cipher.AES.GCM
-- License     : BSD-style
-- Maintainer  : Kazu Yamamoto <kazu@iij.ad.jp>
-- Stability   : experimental
-- Portability : unknown
--
-- AES-GCM for callers that send many short messages under one key, which is
-- what a datagram transport does.
--
-- The interface in "Crypto.Cipher.Types" builds a state from the key /and/
-- the nonce and then walks it through appending the additional data,
-- encrypting and finalizing, copying the state at each step.  For a stream
-- that is nothing next to the encryption.  For a QUIC packet it is most of
-- the work: the key schedule and the table of multiples of @H@ depend on the
-- key alone, and rebuilding them for every nonce costs more than encrypting
-- 1440 bytes.
--
-- So here a t'Context' is built from the key once and holds both, and
-- 'encrypt' takes a nonce and a whole message and answers in one call.
--
-- > ctx <- throwCryptoError <$> pure (newContext key)
-- > let packet = encrypt ctx nonce header plaintext 16
--
-- This runs on AES-NI and carry-less multiply, or on the ARMv8 cryptographic
-- extension, and makes no branch and no memory access that depends on the key
-- or on the data.  Where the processor has neither, AES falls back to a table
-- driven implementation that is /not/ constant time; see the side channels
-- section of the README, and 'Crypto.System.CPU.processorOptions' for which is
-- in use.
--
-- The result is the ciphertext with the tag after it, which is the shape a
-- packet wants.  'decrypt' takes that shape back, compares the tag itself and
-- answers 'Nothing' when it does not match.
--
-- This computes the same thing as the general interface; the tests hold it to
-- that on the same vectors.
module Crypto.Cipher.AES.GCM (
    Context,
    newContext,
    encrypt,
    decrypt,
    decryptWithTag,

    -- * Header protection
    HeaderKey,
    newHeaderKey,
    encryptWithMask,
) where

import Crypto.Cipher.AES.Primitive (
    AES,
    AESGCMKey,
    gcmFullDecrypt,
    gcmFullDecryptTag,
    gcmFullEncrypt,
    gcmFullEncryptMask,
    gcmKeyInit,
    initAES,
 )
import Crypto.Cipher.Types (AuthTag)
import Crypto.Cipher.Types.AEAD (minimumTagLength)
import Crypto.Error
import Crypto.Internal.ByteArray (ByteArray, ByteArrayAccess)
import qualified Crypto.Internal.ByteArray as B
import Data.Word (Word8)
import Foreign.Ptr (Ptr)

-- | Everything a key determines: the AES key schedule and the table of
-- multiples of @H@.  Build it once and encrypt as many messages under it as
-- the key is good for.
data Context = Context !AES !AESGCMKey

-- | Take a key of 16, 24 or 32 bytes.  Any other length is reported as
-- 'CryptoError_KeySizeInvalid'.
newContext :: ByteArrayAccess key => key -> CryptoFailable Context
newContext :: forall key. ByteArrayAccess key => key -> CryptoFailable Context
newContext key
k = do
    AES
aes <- key -> CryptoFailable AES
forall key. ByteArrayAccess key => key -> CryptoFailable AES
initAES key
k
    Context -> CryptoFailable Context
forall a. a -> CryptoFailable a
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> CryptoFailable Context)
-> Context -> CryptoFailable Context
forall a b. (a -> b) -> a -> b
$ AES -> AESGCMKey -> Context
Context AES
aes (AES -> AESGCMKey
gcmKeyInit AES
aes)

-- | Encrypt one message: the nonce, the additional data that is
-- authenticated but not encrypted, the plaintext, and how many bytes of tag
-- to produce, which GCM allows between 4 and 16.  Any other length throws
-- 'CryptoError_AuthenticationTagSizeInvalid', and so does 'decryptWithTag'.
--
-- The answer is the ciphertext followed by the tag.
--
-- A nonce must not be used twice with the same t'Context'.  Twelve bytes is
-- the size GCM is defined for and the only one that does not cost a further
-- pass.  A nonce of no bytes is refused: it would hand out the key GCM
-- authenticates with, so 'encrypt' and 'decryptWithTag' throw
-- 'CryptoError_IvSizeInvalid' for it, 'decrypt' gives 'Nothing' and
-- 'encryptWithMask' gives 'False'.
{-# INLINABLE encrypt #-}
encrypt
    :: ( ByteArrayAccess nonce
       , ByteArrayAccess aad
       , ByteArrayAccess ba
       , ByteArray output
       )
    => Context
    -> nonce
    -> aad
    -> ba
    -> Int
    -> output
encrypt :: forall nonce aad ba output.
(ByteArrayAccess nonce, ByteArrayAccess aad, ByteArrayAccess ba,
 ByteArray output) =>
Context -> nonce -> aad -> ba -> Int -> output
encrypt (Context AES
aes AESGCMKey
gk) nonce
nonce aad
aad ba
input Int
taglen
    | aad -> ba -> Bool
forall aad ba.
(ByteArrayAccess aad, ByteArrayAccess ba) =>
aad -> ba -> Bool
tooLongForC aad
aad ba
input =
        CryptoFailable output -> output
forall a. CryptoFailable a -> a
throwCryptoError (CryptoError -> CryptoFailable output
forall a. CryptoError -> CryptoFailable a
CryptoFailed CryptoError
CryptoError_ParameterInvalid)
    | nonce -> Bool
forall nonce. ByteArrayAccess nonce => nonce -> Bool
badNonce nonce
nonce =
        CryptoFailable output -> output
forall a. CryptoFailable a -> a
throwCryptoError (CryptoError -> CryptoFailable output
forall a. CryptoError -> CryptoFailable a
CryptoFailed CryptoError
CryptoError_IvSizeInvalid)
    | Int -> Bool
badTagLength Int
taglen =
        CryptoFailable output -> output
forall a. CryptoFailable a -> a
throwCryptoError (CryptoError -> CryptoFailable output
forall a. CryptoError -> CryptoFailable a
CryptoFailed CryptoError
CryptoError_AuthenticationTagSizeInvalid)
    | Bool
otherwise = AES -> AESGCMKey -> nonce -> aad -> ba -> Int -> output
forall iv aad ba output.
(ByteArrayAccess iv, ByteArrayAccess aad, ByteArrayAccess ba,
 ByteArray output) =>
AES -> AESGCMKey -> iv -> aad -> ba -> Int -> output
gcmFullEncrypt AES
aes AESGCMKey
gk nonce
nonce aad
aad ba
input Int
taglen

-- | Decrypt one message, in the shape 'encrypt' produced: the ciphertext with
-- its tag after it.  The tag is compared here, every byte of it whatever the
-- answer, and a message whose tag does not match gives 'Nothing' rather than
-- the plaintext.
--
-- 'Nothing' also comes back when the nonce has no bytes, the input is
-- shorter than the tag, or the tag length is outside 4 to 16.
{-# INLINABLE decrypt #-}
decrypt
    :: (ByteArrayAccess nonce, ByteArrayAccess aad, ByteArray ba)
    => Context
    -> nonce
    -> aad
    -> ba
    -> Int
    -> Maybe ba
decrypt :: forall nonce aad ba.
(ByteArrayAccess nonce, ByteArrayAccess aad, ByteArray ba) =>
Context -> nonce -> aad -> ba -> Int -> Maybe ba
decrypt (Context AES
aes AESGCMKey
gk) nonce
nonce aad
aad ba
input Int
taglen
    | aad -> ba -> Bool
forall aad ba.
(ByteArrayAccess aad, ByteArrayAccess ba) =>
aad -> ba -> Bool
tooLongForC aad
aad ba
input = Maybe ba
forall a. Maybe a
Nothing
    | nonce -> Bool
forall nonce. ByteArrayAccess nonce => nonce -> Bool
badNonce nonce
nonce Bool -> Bool -> Bool
|| Int -> Bool
badTagLength Int
taglen Bool -> Bool -> Bool
|| ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
input Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
taglen = Maybe ba
forall a. Maybe a
Nothing
    | Bool
otherwise = AES -> AESGCMKey -> nonce -> aad -> ba -> ba -> Maybe ba
forall iv aad ba tag output.
(ByteArrayAccess iv, ByteArrayAccess aad, ByteArrayAccess ba,
 ByteArrayAccess tag, ByteArray output) =>
AES -> AESGCMKey -> iv -> aad -> ba -> tag -> Maybe output
gcmFullDecrypt AES
aes AESGCMKey
gk nonce
nonce aad
aad ba
body ba
tag
  where
    (ba
body, ba
tag) = Int -> ba -> (ba, ba)
forall bs. ByteArray bs => Int -> bs -> (bs, bs)
B.splitAt (ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
input Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
taglen) ba
input

-- | Decrypt one message, the tag kept apart, and hand back the tag this end
-- computed.
--
-- For a caller whose protocol hands it the tag separately from the
-- ciphertext, so that 'decrypt' -- which wants the two together and compares
-- them itself -- does not fit.  Compare the two tags with '=='; the 'Eq'
-- instance of t'AuthTag' is a constant-time comparison, and taking them apart
-- to compare the bytes is how this goes wrong.
--
-- Nothing here says whether the message is authentic.  Until the comparison
-- is made and has come out equal, what this returns is not plaintext, it is
-- what the ciphertext turns into, and a caller must not act on it.
{-# INLINABLE decryptWithTag #-}
decryptWithTag
    :: (ByteArrayAccess nonce, ByteArrayAccess aad, ByteArray ba)
    => Context
    -> nonce
    -> aad
    -> ba
    -> Int
    -> (ba, AuthTag)
decryptWithTag :: forall nonce aad ba.
(ByteArrayAccess nonce, ByteArrayAccess aad, ByteArray ba) =>
Context -> nonce -> aad -> ba -> Int -> (ba, AuthTag)
decryptWithTag (Context AES
aes AESGCMKey
gk) nonce
nonce aad
aad ba
input Int
taglen
    | aad -> ba -> Bool
forall aad ba.
(ByteArrayAccess aad, ByteArrayAccess ba) =>
aad -> ba -> Bool
tooLongForC aad
aad ba
input =
        CryptoFailable (ba, AuthTag) -> (ba, AuthTag)
forall a. CryptoFailable a -> a
throwCryptoError (CryptoError -> CryptoFailable (ba, AuthTag)
forall a. CryptoError -> CryptoFailable a
CryptoFailed CryptoError
CryptoError_ParameterInvalid)
    | nonce -> Bool
forall nonce. ByteArrayAccess nonce => nonce -> Bool
badNonce nonce
nonce =
        CryptoFailable (ba, AuthTag) -> (ba, AuthTag)
forall a. CryptoFailable a -> a
throwCryptoError (CryptoError -> CryptoFailable (ba, AuthTag)
forall a. CryptoError -> CryptoFailable a
CryptoFailed CryptoError
CryptoError_IvSizeInvalid)
    | Int -> Bool
badTagLength Int
taglen =
        CryptoFailable (ba, AuthTag) -> (ba, AuthTag)
forall a. CryptoFailable a -> a
throwCryptoError (CryptoError -> CryptoFailable (ba, AuthTag)
forall a. CryptoError -> CryptoFailable a
CryptoFailed CryptoError
CryptoError_AuthenticationTagSizeInvalid)
    | Bool
otherwise = AES -> AESGCMKey -> nonce -> aad -> ba -> Int -> (ba, AuthTag)
forall iv aad ba output.
(ByteArrayAccess iv, ByteArrayAccess aad, ByteArrayAccess ba,
 ByteArray output) =>
AES -> AESGCMKey -> iv -> aad -> ba -> Int -> (output, AuthTag)
gcmFullDecryptTag AES
aes AESGCMKey
gk nonce
nonce aad
aad ba
input Int
taglen

----------------------------------------------------------------

-- | The key schedule for header protection, which QUIC keeps separately from
-- the one it encrypts with.  Built once, like a t'Context'.
newtype HeaderKey = HeaderKey AES

-- | Take a header protection key of 16, 24 or 32 bytes.
newHeaderKey :: ByteArrayAccess key => key -> CryptoFailable HeaderKey
newHeaderKey :: forall key. ByteArrayAccess key => key -> CryptoFailable HeaderKey
newHeaderKey key
k = AES -> HeaderKey
HeaderKey (AES -> HeaderKey)
-> CryptoFailable AES -> CryptoFailable HeaderKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> key -> CryptoFailable AES
forall key. ByteArrayAccess key => key -> CryptoFailable AES
initAES key
k

-- | Encrypt one message and, from a sample of the ciphertext it just
-- produced, make the header protection mask -- in one call, into two buffers
-- the caller already has.
--
-- QUIC takes its sample from the ciphertext, so the mask cannot be had before
-- the encryption.  It can be had before coming back, and with the buffers
-- already there nothing is allocated for either.  On an Apple M4 the mask
-- then costs about 0.02 us, where asking for it separately costs 0.11.
--
-- The sealed message wants @length input + taglen@ bytes and the mask
-- sixteen.  @sampleOffset@ says where the sixteen bytes of sample begin in
-- the sealed message, counting the tag as part of it.
--
-- 'False' comes back, and nothing is written, when the nonce has no bytes,
-- the sample would not fit, or the tag length is outside 4 to 16.
{-# INLINABLE encryptWithMask #-}
encryptWithMask
    :: (ByteArrayAccess nonce, ByteArrayAccess aad, ByteArrayAccess ba)
    => Context
    -> HeaderKey
    -> nonce
    -> aad
    -> ba
    -> Int
    -- ^ tag length
    -> Int
    -- ^ sample offset
    -> Ptr Word8
    -- ^ where the sealed message goes
    -> Ptr Word8
    -- ^ where the sixteen bytes of mask go
    -> IO Bool
encryptWithMask :: forall nonce aad ba.
(ByteArrayAccess nonce, ByteArrayAccess aad, ByteArrayAccess ba) =>
Context
-> HeaderKey
-> nonce
-> aad
-> ba
-> Int
-> Int
-> Ptr Word8
-> Ptr Word8
-> IO Bool
encryptWithMask (Context AES
aes AESGCMKey
gk) (HeaderKey AES
hp) nonce
nonce aad
aad ba
input Int
taglen Int
off Ptr Word8
outp Ptr Word8
maskp
    | aad -> ba -> Bool
forall aad ba.
(ByteArrayAccess aad, ByteArrayAccess ba) =>
aad -> ba -> Bool
tooLongForC aad
aad ba
input = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    | nonce -> Bool
forall nonce. ByteArrayAccess nonce => nonce -> Bool
badNonce nonce
nonce = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    | Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int -> Bool
badTagLength Int
taglen Bool -> Bool -> Bool
|| Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
16 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
input Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
taglen =
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    | Bool
otherwise = do
        AES
-> AESGCMKey
-> AES
-> nonce
-> aad
-> ba
-> Int
-> Int
-> Ptr Word8
-> Ptr Word8
-> IO ()
forall iv aad ba.
(ByteArrayAccess iv, ByteArrayAccess aad, ByteArrayAccess ba) =>
AES
-> AESGCMKey
-> AES
-> iv
-> aad
-> ba
-> Int
-> Int
-> Ptr Word8
-> Ptr Word8
-> IO ()
gcmFullEncryptMask AES
aes AESGCMKey
gk AES
hp nonce
nonce aad
aad ba
input Int
taglen Int
off Ptr Word8
outp Ptr Word8
maskp
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | The C behind all four takes its lengths as @uint32_t@, so a message or
-- its additional data from 2^32 bytes up cannot be handed to it: the length
-- would be truncated and most of the buffer left untouched, with nothing to
-- say so.  There is no splitting the work here -- the C does the whole
-- message in one call, tag and all -- so such a message is refused.
tooLongForC
    :: (ByteArrayAccess aad, ByteArrayAccess ba) => aad -> ba -> Bool
tooLongForC :: forall aad ba.
(ByteArrayAccess aad, ByteArrayAccess ba) =>
aad -> ba -> Bool
tooLongForC aad
aad ba
input =
    Int -> Bool
B.overCLength (aad -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length aad
aad) Bool -> Bool -> Bool
|| Int -> Bool
B.overCLength (ba -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length ba
input)

-- | SP 800-38D 5.2.1.1 asks for at least one byte of IV, and this is why.
--
-- GCM builds its pre-counter block from a nonce that is not twelve bytes as
-- @J0 = GHASH_H(IV || 0^s || [0]_64 || [len(IV)]_64)@.  For an empty IV that
-- input is one block of zeros, so @J0@ is zero, and the tag of a message
-- becomes @GHASH_H(A, C) XOR E(K, 0^128)@ -- where @E(K, 0^128)@ is the
-- definition of @H@.  The tag of an empty message under an empty nonce is
-- therefore @H@ itself, and any other full tag gives @H@ as the root of a
-- known polynomial.
--
-- @H@ belongs to the key, not to the nonce.  An attacker holding it, plus one
-- genuine message under any nonce, has @E(K, J0)@ for that nonce and can make
-- a tag that verifies for data of their own -- under a correct twelve-byte
-- nonce, and for every nonce they have seen.  One encryption with an empty
-- nonce and a full tag ends the authenticity of everything under the key.
--
-- 'Crypto.Cipher.AES.Primitive.gcmAeadInit' refuses the empty IV for this
-- reason, and these four have to as well.  Only the empty one is refused:
-- SP 800-38D allows every length from one byte up.
badNonce :: ByteArrayAccess nonce => nonce -> Bool
badNonce :: forall nonce. ByteArrayAccess nonce => nonce -> Bool
badNonce nonce
nonce = nonce -> Int
forall ba. ByteArrayAccess ba => ba -> Int
B.length nonce
nonce Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0

-- | GCM makes a sixteen-byte tag and a shorter one is a prefix of it.  Below
-- 'minimumTagLength' it authenticates next to nothing, and past sixteen the
-- C code would read beyond the tag it computed.
badTagLength :: Int -> Bool
badTagLength :: Int -> Bool
badTagLength Int
t = Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minimumTagLength Bool -> Bool -> Bool
|| Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
16