-- Common.hs: hOpenPGP test suite
-- Copyright © 2012-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeApplications #-}

module Tests.Common
    ( addTimestampSeconds
    , armorPayload
    , assertFalse
    , assertTrue
    , collectSecretKeyInfos
    , conduitDecryptWithPKESKContext
    , loadArmor
    , loadAndDecompressPkts
    , loadSEIPDv2FixtureWithV4Secret
    , loadUnencryptedRsaSigner
    , loadV4EncryptedSecretKeyFixtureForProperty
    , loadV6UnencryptedSecretKeyFixtureForProperty
    , prependUnusableLatestPKESK
    , readFixtureLazy
    , readFixturePackets
    , readFixturePayload
    , reorderPrecedingPKESKs
    , reverseIf
    , runGet -- FIXME: this is confusing
    , selectRecipientKeyInfo
    , setKeyTimestamp
    , signCertificationAt
    , signSubkeyBindingWithRSAExtrasAt
    , signSubkeyRevocationWithRSAAt
    , timestampToUTCTime
    , assertSingleFailureContainsTimeline
    , assertSingleSignerFingerprint
    , encryptMessageDefault
    , expectV4PKPayload
    , expectV6PKPayload
    , extractV4SignatureAlgorithmFields
    , fp
    , loadKeyring
    , loadDeterministicEd25519Signer
    , loadDeterministicEd25519SignerV6
    , loadDeterministicEd448Signer
    , loadDeterministicEd448SignerV6
    , loadUnencryptedRsaSignerV6
    , messageIssuerSubpacketsAt
    , mkTestKeyring
    , setPKAlgorithm
    , signBinaryMessageWithRSAAt
    , signBinaryMessageWithEd25519At
    , signKeyRevocationWithReasonAt
    , signKeyRevocationWithReasonAndExtrasAt
    , signSubkeyBindingWithRSAAt
    , verifyTimelinePackets
    , signCertificationRevocationWithEd25519At
    , signCertificationWithEd25519At
    , verificationFixtureGroup
    , verifyMessageFromBytestring
    , verifyMessageFromBytestringBatch
    , verifyMessageFromPackets
    , verifyMessageFromPacketsBatch
    , certificateVerificationFixtures
    , fixturePath
    , messageVerificationFixtures
    , readPKIPassphrase
    , setKeyVersion
    , signCertificationRevocationAt
    , aesKeyWrapRFC3394ForTest
    , assertX25519EskShape
    , assertX448EskShape
    , buildCurve25519LegacyKdfParamForTest
    , buildECDHKDFParamForTest
    , cgp
    , conduitDecrypt -- FIXME: this is confusing
    , conduitDecryptChecked
    , conduitDecryptCheckedWithDecryptPolicy
    , conduitDecryptWithCandidatesCallbackAndPolicy
    , conduitDecryptWithDecryptPolicy
    , deriveECDHKekForTest
    , deriveX25519KekForTest
    , deriveX448KekForTest
    , doPkeyAndSkeyMatch
    , encodeChecksum16
    , forceVersionedRecipientIdentifier
    , isPrecedingESK
    , mkPKESKSessionMaterialOrFail
    , readFixtureStrict
    , selectRecipientKeyInfoByRawRecipientId
    , signDirectKeyWithRSAExtrasAt
    , testEncodeOpenPGPSessionMaterial
    , testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized
    , testSEIPDv2ForV4KeyArmor
    , testSEIPDv2TwoRecipientsArmor
    , testSEIPDv2ThreeRecipientsArmor
    )
where

import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
    ( Armor (..)
    , ArmorType (..)
    )
import Control.Error.Util (hush)
import Control.Monad (join, unless, void)
import Control.Monad.Trans.Resource (ResourceT)
import qualified Crypto.Error as CE
import qualified Crypto.Hash as CH
import qualified Crypto.Hash.Algorithms as CHA
import Crypto.KDF.HKDF (expand, extract)
import Crypto.Number.Serialize (os2ip)
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Types as ECCT
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import Data.Bifunctor (bimap, first)
import Data.Binary (get)
import Data.Binary.Get
    ( Get
    , getLazyByteString
    , getRemainingLazyByteString
    , getWord16be
    , getWord8
    , runGetOrFail
    )
import Data.Binary.Put (putWord64be, runPut)
import Data.Bits (xor)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16.Lazy as B16L
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.Char (toUpper)
import qualified Data.Conduit as DC
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.List (isInfixOf)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (catMaybes, listToMaybe)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Word (Word32, Word64)
import System.IO.Unsafe (unsafePerformIO)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit
    ( Assertion
    , assertBool
    , assertEqual
    , assertFailure
    , testCase
    )
import qualified "crypton" Crypto.Cipher.AES as AES
import qualified "crypton" Crypto.Cipher.Types as CCT

import Codec.Encryption.OpenPGP.Arbitrary ()
import Codec.Encryption.OpenPGP.Compression (decompressPkt)
import Codec.Encryption.OpenPGP.Encrypt
    ( PKESKSessionMaterial
    , encodeOpenPGPSessionMaterial
    , mkPKESKSessionMaterial
    )
import Codec.Encryption.OpenPGP.Fingerprint
    ( eightOctetKeyID
    , fingerprint
    )
import Codec.Encryption.OpenPGP.Internal
    ( curveFromCurve
    , curveToCurveoidBS
    , emptyPSC
    , lastPrimaryKey
    , lastSubkey
    , lastUIDorUAt
    )
import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint)
import Codec.Encryption.OpenPGP.Message
    ( ClearPayload
    , EncryptMessageOptions (..)
    , EncryptedPayload
    , MessageError (..)
    , Passphrase
    , RecoveredSessionMaterial (..)
    , SessionMaterialExposure (..)
    , VersionedPKPayload
    , asV4PKPayload
    , asV6PKPayload
    , encryptMessage
    )
import Codec.Encryption.OpenPGP.Policy
    ( DecryptPolicy
    , defaultDecryptPolicy
    )
import Codec.Encryption.OpenPGP.SecretKey
    ( decryptPrivateKey
    )
import Codec.Encryption.OpenPGP.Serialize
    ( dearmorIfAsciiArmored
    , parsePkts
    )
import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig)
import Codec.Encryption.OpenPGP.Signatures
    ( VerificationError (..)
    , renderSignError
    , renderVerificationError
    , signCertRevocationWithRSA
    , signCertificationWithRSA
    , signDataWithEd25519
    , signDataWithRSA
    , signDirectKeyWithRSA
    , signKeyRevocationWithRSA
    , signSubkeyRevocationWithRSA
    )
import Codec.Encryption.OpenPGP.Types
import Data.Conduit.OpenPGP.Compression (conduitDecompress)
import Data.Conduit.OpenPGP.Decrypt
    ( DecryptKeyResolution (..)
    , DecryptOptions (..)
    , DecryptOutcome (..)
    , PKESKRecipientKey (..)
    )
import qualified Data.Conduit.OpenPGP.Decrypt as DCD
import Data.Conduit.OpenPGP.Keyring
    ( conduitToSomeTKsEither
    , partitionSomeTKs
    , sinkPublicKeyringMap
    )
import Data.Conduit.OpenPGP.Message
    ( VerificationMode (..)
    , VerificationOptions (..)
    , VerificationPolicy (..)
    , defaultVerificationOptions
    , verifyMessage
    , verifyMessagePackets
    )

-- Test assertion helpers
assertTrue :: String -> Bool -> Assertion
assertTrue msg b = assertBool msg b

assertFalse :: String -> Bool -> Assertion
assertFalse msg b = assertBool msg (not b)

fixturePath :: FilePath -> FilePath
fixturePath file = "tests/data/" ++ file

readFixtureLazy :: FilePath -> IO BL.ByteString
readFixtureLazy = BL.readFile . fixturePath

readFixtureStrict :: FilePath -> IO B.ByteString
readFixtureStrict = B.readFile . fixturePath

readFixturePackets :: FilePath -> IO [Pkt]
readFixturePackets file =
    DC.runConduitRes $
        CB.sourceFile (fixturePath file)
            DC..| conduitGet get
            DC..| CL.consume

readFixtureDecompressedPackets :: FilePath -> IO [Pkt]
readFixtureDecompressedPackets file =
    DC.runConduitRes $
        CB.sourceFile (fixturePath file)
            DC..| conduitGet get
            DC..| conduitDecompress
            DC..| CL.consume

loadFirstArmor :: FilePath -> IO Armor
loadFirstArmor file = do
    armors <- loadArmor file
    case armors of
        (a : _) -> pure a
        [] ->
            assertFailure (file ++ " armor file contained no armor blocks")
                >> fail "expected armor block"

readPKIPassphrase :: IO BL.ByteString
readPKIPassphrase = readFixtureLazy "pki-password.txt"

-- this needs a better name
runGet :: Get a -> BL.ByteString -> Either String a
runGet g bs = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail g bs)

extractV4SignatureAlgorithmFields
    :: BL.ByteString -> Either String (PubKeyAlgorithm, B.ByteString)
extractV4SignatureAlgorithmFields =
    runGet $ do
        version <- getWord8
        if version /= 4
            then
                fail
                    ("expected v4 signature payload, got version " ++ show version)
            else do
                _ <- getWord8 -- sig type
                pka <- getWord8
                _ <- getWord8 -- hash algo
                hlen <- getWord16be
                _ <- getLazyByteString (fromIntegral hlen)
                ulen <- getWord16be
                _ <- getLazyByteString (fromIntegral ulen)
                _ <- getWord16be -- left16
                algorithmFields <- getRemainingLazyByteString
                pure (toFVal pka, BL.toStrict algorithmFields)

conduitDecrypt
    :: (String -> IO BL.ByteString)
    -> DC.ConduitT Pkt Pkt (ResourceT IO) ()
conduitDecrypt cb =
    void $
        DCD.conduitDecrypt
            DecryptOptions
                { decryptOptionsKeyResolution = DecryptWithoutPKESK
                , decryptOptionsPolicy = defaultDecryptPolicy
                , decryptOptionsPassphraseCallback = cb
                }

conduitDecryptWithPKESKContext
    :: (Pkt -> IO (Maybe PKESKRecipientKey))
    -> (String -> IO BL.ByteString)
    -> DC.ConduitT Pkt Pkt (ResourceT IO) ()
conduitDecryptWithPKESKContext pkcb cb =
    void $
        DCD.conduitDecrypt
            DecryptOptions
                { decryptOptionsKeyResolution =
                    DecryptWithUnwrapCandidatesCallback
                        (asPKESKUnwrapCandidatesCallback pkcb)
                , decryptOptionsPolicy = defaultDecryptPolicy
                , decryptOptionsPassphraseCallback = cb
                }

conduitDecryptWithDecryptPolicy
    :: DecryptPolicy
    -> (Pkt -> IO (Maybe PKESKRecipientKey))
    -> (String -> IO BL.ByteString)
    -> DC.ConduitT Pkt Pkt (ResourceT IO) ()
conduitDecryptWithDecryptPolicy dp pkcb cb =
    void $
        DCD.conduitDecrypt
            DecryptOptions
                { decryptOptionsKeyResolution =
                    DecryptWithUnwrapCandidatesCallback
                        (asPKESKUnwrapCandidatesCallback pkcb)
                , decryptOptionsPolicy = dp
                , decryptOptionsPassphraseCallback = cb
                }

conduitDecryptChecked
    :: (String -> IO BL.ByteString)
    -> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome
conduitDecryptChecked cb =
    DCD.conduitDecrypt
        DecryptOptions
            { decryptOptionsKeyResolution = DecryptWithoutPKESK
            , decryptOptionsPolicy = defaultDecryptPolicy
            , decryptOptionsPassphraseCallback = cb
            }

conduitDecryptCheckedWithDecryptPolicy
    :: DecryptPolicy
    -> (Pkt -> IO (Maybe PKESKRecipientKey))
    -> (String -> IO BL.ByteString)
    -> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome
conduitDecryptCheckedWithDecryptPolicy dp pkcb cb =
    DCD.conduitDecrypt
        DecryptOptions
            { decryptOptionsKeyResolution =
                DecryptWithUnwrapCandidatesCallback
                    (asPKESKUnwrapCandidatesCallback pkcb)
            , decryptOptionsPolicy = dp
            , decryptOptionsPassphraseCallback = cb
            }

conduitDecryptWithCandidatesCallbackAndPolicy
    :: DecryptPolicy
    -> (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])
    -> (String -> IO BL.ByteString)
    -> DC.ConduitT Pkt Pkt (ResourceT IO) ()
conduitDecryptWithCandidatesCallbackAndPolicy dp candCb cb =
    void $
        DCD.conduitDecrypt
            DecryptOptions
                { decryptOptionsKeyResolution =
                    DecryptWithUnwrapCandidatesCallback candCb
                , decryptOptionsPolicy = dp
                , decryptOptionsPassphraseCallback = cb
                }

asPKESKUnwrapCandidatesCallback
    :: (Pkt -> IO (Maybe PKESKRecipientKey))
    -> KeyIdentifier
    -> PubKeyAlgorithm
    -> IO [PKESKRecipientKey]
asPKESKUnwrapCandidatesCallback pkcb keyIdentifier pka = do
    mk <- pkcb (pkeskProbePacket keyIdentifier pka)
    pure (maybe [] (: []) mk)

pkeskProbePacket :: KeyIdentifier -> PubKeyAlgorithm -> Pkt
pkeskProbePacket keyIdentifier pka =
    case keyIdentifier of
        KeyIdentifierWildcard ->
            PKESKPkt
                ( PKESKPayloadV3Packet
                    ( PKESKPayloadV3
                        3
                        (EightOctetKeyId (BL.replicate 8 0))
                        pka
                        (MPI 0 :| [])
                    )
                )
        KeyIdentifierEightOctet rid ->
            PKESKPkt
                ( PKESKPayloadV3Packet
                    (PKESKPayloadV3 3 rid pka (MPI 0 :| []))
                )
        KeyIdentifierFingerprint rid ->
            PKESKPkt
                ( PKESKPayloadV6Packet
                    (PKESKPayloadV6 (unFingerprint rid) pka mempty)
                )

readFixturePayload :: FilePath -> IO BL.ByteString
readFixturePayload fpr = do
    bs <- BL.readFile ("tests/data/" ++ fpr)
    case dearmorIfAsciiArmored bs of
        Left err ->
            assertFailure
                ("ASCII armor decode failed for " ++ fpr ++ ": " ++ err)
                >> pure mempty
        Right (_, payload) -> pure payload

testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized
    :: Assertion
testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized = do
    secretPackets <-
        DC.runConduitRes $
            CB.sourceFile "tests/data/unencrypted.seckey"
                DC..| conduitGet get
                DC..| CL.consume
    (publicKey, privateKey) <-
        case secretPackets of
            (SecretKeyPkt pkp ska : _) ->
                case (_pubkey pkp, ska) of
                    ( RSAPubKey (RSA_PublicKey pub)
                        , SUUnencrypted (RSAPrivateKey (RSA_PrivateKey prv)) _
                        ) ->
                            pure (pub, prv)
                    _ ->
                        assertFailure
                            "unencrypted.seckey did not contain a parseable unencrypted RSA key pair"
                            >> fail "expected RSA key pair from parsed secret key packet"
            _ ->
                assertFailure
                    "unencrypted.seckey did not begin with a secret key packet"
                    >> fail "expected secret key packet"
    let plaintext = "pkcs1-v1.5 regression payload" :: B.ByteString
    encrypted <-
        ( P15.encrypt publicKey plaintext
            :: IO (Either RSA.Error B.ByteString)
        )
    ciphertext <-
        case encrypted of
            Left err ->
                assertFailure ("RSA PKCS#1 v1.5 encryption failed: " ++ show err)
                    >> pure mempty
            Right ct -> pure ct
    decrypted <-
        ( P15.decryptSafer privateKey ciphertext
            :: IO (Either RSA.Error B.ByteString)
        )
    case decrypted of
        Left RSA.MessageNotRecognized ->
            assertFailure
                "parsed RSA private key decryption failed with MessageNotRecognized"
        Left err ->
            assertFailure
                ("parsed RSA private key decryption failed: " ++ show err)
        Right got ->
            assertEqual
                "parsed RSA private key decrypts PKCS#1 v1.5 payload"
                plaintext
                got

testEncodeOpenPGPSessionMaterial :: Assertion
testEncodeOpenPGPSessionMaterial = do
    let keyBytes = B.pack [1 .. 32]
        expected =
            B.singleton (fromFVal AES256)
                <> keyBytes
                <> encodeChecksum16 keyBytes
    case encodeOpenPGPSessionMaterial AES256 (SessionKey keyBytes) of
        Left err ->
            assertFailure
                ("encodeOpenPGPSessionMaterial failed: " ++ show err)
        Right encoded ->
            assertEqual "OpenPGP session material encoding" expected encoded

mkPKESKSessionMaterialOrFail
    :: SymmetricAlgorithm -> SessionKey -> IO PKESKSessionMaterial
mkPKESKSessionMaterialOrFail symalgo sessionKey =
    case mkPKESKSessionMaterial symalgo sessionKey of
        Left err ->
            assertFailure ("mkPKESKSessionMaterial failed: " ++ show err)
                >> fail "mkPKESKSessionMaterial failed"
        Right material -> pure material

armorPayload :: Armor -> BL.ByteString
armorPayload (Armor _ _ bs) = BL.fromStrict (BLC8.toStrict bs)
armorPayload (ClearSigned _ _ inner) = armorPayload inner

selectRecipientKeyInfo
    :: Pkt -> [PKESKRecipientKey] -> Maybe PKESKRecipientKey
selectRecipientKeyInfo (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) keyInfos =
    listToMaybe
        [ keyInfo
        | keyInfo <- keyInfos
        , supportsPKESKAlgorithm pka keyInfo
        , matchesRecipientIdentifier rid keyInfo
        ]
selectRecipientKeyInfo (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) keyInfos
    | isWildcardEightOctetKeyId rid =
        listToMaybe
            [ keyInfo | keyInfo <- keyInfos, supportsPKESKAlgorithm pka keyInfo
            ]
    | otherwise =
        listToMaybe
            [ keyInfo
            | keyInfo <- keyInfos
            , supportsPKESKAlgorithm pka keyInfo
            , matchesEightOctetRecipientKeyId rid keyInfo
            ]
selectRecipientKeyInfo _ keyInfos = listToMaybe keyInfos

isWildcardEightOctetKeyId :: EightOctetKeyId -> Bool
isWildcardEightOctetKeyId (EightOctetKeyId rid) =
    BL.length rid == 8 && BL.all (== 0) rid

matchesEightOctetRecipientKeyId
    :: EightOctetKeyId -> PKESKRecipientKey -> Bool
matchesEightOctetRecipientKeyId (EightOctetKeyId rid) keyInfo =
    case pkeskRecipientPKPayload keyInfo of
        Nothing -> False
        Just pkp ->
            let fingerprintBytes = unFingerprint (fingerprint pkp)
             in BL.length fingerprintBytes >= 8
                    && BL.drop (BL.length fingerprintBytes - 8) fingerprintBytes == rid

supportsPKESKAlgorithm
    :: PubKeyAlgorithm -> PKESKRecipientKey -> Bool
supportsPKESKAlgorithm pka keyInfo =
    case pkeskRecipientSKey keyInfo of
        RSAPrivateKey {} -> pka == RSA
        ECDHPrivateKey {} -> pka == ECDH || pka == X25519
        X25519PrivateKey {} -> pka == X25519
        X448PrivateKey {} -> pka == X448
        _ -> False

matchesRecipientIdentifier
    :: BL.ByteString -> PKESKRecipientKey -> Bool
matchesRecipientIdentifier rid keyInfo =
    case pkeskRecipientPKPayload keyInfo of
        Nothing -> False
        Just pkp ->
            let fingerprintBytes = BL.toStrict (unFingerprint (fingerprint pkp))
                identifier = BL.toStrict rid
             in identifier == fingerprintBytes
                    || identifier == B.cons 0x04 fingerprintBytes
                    || identifier == B.cons 0x06 fingerprintBytes

buildECDHKDFParamForTest
    :: SomePKPayload
    -> PubKeyAlgorithm
    -> ECCT.Curve
    -> HashAlgorithm
    -> SymmetricAlgorithm
    -> B.ByteString
buildECDHKDFParamForTest recipientPKP pka curve kdfHA kdfSA =
    B.singleton (fromIntegral (B.length curveOid))
        <> curveOid
        <> B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA]
        <> "Anonymous Sender    "
        <> BL.toStrict (unFingerprint (fingerprint recipientPKP))
  where
    curveOid =
        either
            (const B.empty)
            id
            (curveToCurveoidBS (curveFromCurve curve))

buildCurve25519LegacyKdfParamForTest
    :: SomePKPayload
    -> PubKeyAlgorithm
    -> HashAlgorithm
    -> SymmetricAlgorithm
    -> B.ByteString
buildCurve25519LegacyKdfParamForTest recipientPKP pka kdfHA kdfSA =
    B.singleton (fromIntegral (B.length curveOid))
        <> curveOid
        <> B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA]
        <> "Anonymous Sender    "
        <> BL.toStrict (unFingerprint (fingerprint recipientPKP))
  where
    curveOid = "\x2b\x06\x01\x04\x01\x97\x55\x01\x05\x01"

deriveECDHKekForTest
    :: HashAlgorithm
    -> SymmetricAlgorithm
    -> B.ByteString
    -> B.ByteString
    -> B.ByteString
deriveECDHKekForTest kdfHA kdfSA sharedSecret kdfParam =
    B.take (keyLengthForTest kdfSA) digest
  where
    digest =
        case kdfHA of
            SHA256 ->
                BA.convert
                    ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)
                        :: CH.Digest CHA.SHA256
                    )
            SHA384 ->
                BA.convert
                    ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)
                        :: CH.Digest CHA.SHA384
                    )
            SHA512 ->
                BA.convert
                    ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)
                        :: CH.Digest CHA.SHA512
                    )
            _ ->
                BA.convert
                    ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)
                        :: CH.Digest CHA.SHA256
                    )

deriveX448KekForTest
    :: B.ByteString
    -> B.ByteString
    -> B.ByteString
    -> B.ByteString
deriveX448KekForTest ephemeralPublic recipientPublic sharedSecret =
    let ikm = ephemeralPublic <> recipientPublic <> sharedSecret
        prk = extract @CHA.SHA512 B.empty ikm
        info = "OpenPGP X448" :: B.ByteString
     in expand @CHA.SHA512 prk info 32

deriveX25519KekForTest
    :: B.ByteString
    -> B.ByteString
    -> B.ByteString
    -> B.ByteString
deriveX25519KekForTest ephemeralPublic recipientPublic sharedSecret =
    let ikm = ephemeralPublic <> recipientPublic <> sharedSecret
        prk = extract @CHA.SHA256 B.empty ikm
        info = "OpenPGP X25519" :: B.ByteString
     in expand @CHA.SHA256 prk info 16

keyLengthForTest :: SymmetricAlgorithm -> Int
keyLengthForTest AES128 = 16
keyLengthForTest AES192 = 24
keyLengthForTest AES256 = 32
keyLengthForTest _ = 16

aesKeyWrapRFC3394ForTest
    :: SymmetricAlgorithm
    -> B.ByteString
    -> B.ByteString
    -> B.ByteString
aesKeyWrapRFC3394ForTest sa kek plain =
    case sa of
        AES128 -> wrapWithCipher (initCipher kek :: AES.AES128) plain
        AES192 -> wrapWithCipher (initCipher kek :: AES.AES192) plain
        AES256 -> wrapWithCipher (initCipher kek :: AES.AES256) plain
        _ -> error "unsupported KEK algorithm in test"
  where
    initCipher keyBytes =
        case CE.eitherCryptoError (CCT.cipherInit keyBytes) of
            Left err -> error ("cipher init failed: " ++ show err)
            Right c -> c
    wrapWithCipher cipher plainBytes =
        let rs = chunksOf8ForTest plainBytes
            n = length rs
            a0 = B.replicate 8 0xA6
            (aFinal, rFinal) =
                foldl (\(a, r) j -> wrapRound cipher n j a r) (a0, rs) [0 .. 5]
         in aFinal <> B.concat rFinal
    wrapRound cipher n j a rs = foldl step (a, rs) [1 .. n]
      where
        step (aCurr, rCurr) i =
            let b = CCT.ecbEncrypt cipher (aCurr <> (rCurr !! (i - 1)))
                (aMsb, rLsb) = B.splitAt 8 b
                t = fromIntegral (n * j + i) :: Word64
                aNext = xorBSForTest aMsb (encodeWord64beForTest t)
             in (aNext, replaceAtForTest (i - 1) rLsb rCurr)

encodeWord64beForTest :: Word64 -> B.ByteString
encodeWord64beForTest = BL.toStrict . runPut . putWord64be

chunksOf8ForTest :: B.ByteString -> [B.ByteString]
chunksOf8ForTest bs
    | B.null bs = []
    | otherwise =
        let (h, t) = B.splitAt 8 bs
         in h : chunksOf8ForTest t

replaceAtForTest :: Int -> a -> [a] -> [a]
replaceAtForTest idx x xs =
    let (prefix, suffix) = splitAt idx xs
     in case suffix of
            [] -> xs
            (_ : rest) -> prefix <> (x : rest)

xorBSForTest :: B.ByteString -> B.ByteString -> B.ByteString
xorBSForTest a b = B.pack (B.zipWith xor a b)

encodeChecksum16 :: B.ByteString -> B.ByteString
encodeChecksum16 bs =
    B.pack
        [fromIntegral (s `div` 256), fromIntegral (s `mod` 256)]
  where
    s =
        B.foldl'
            (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Int))
            0
            bs

verifyMessageFromPackets
    :: PublicKeyring -> BL.ByteString -> [Either String Verification]
verifyMessageFromPackets keyring signedMessage =
    map (either (Left . renderVerificationError) Right) $
        verifyMessagePackets
            defaultVerificationOptions
                { verificationPolicy = VerifyInformational
                , verificationMode = VerificationStreaming
                }
            keyring
            ( concatMap
                (either (const []) id . decompressPkt)
                (parsePkts signedMessage)
            )

verifyMessageFromPacketsBatch
    :: PublicKeyring -> BL.ByteString -> [Either String Verification]
verifyMessageFromPacketsBatch keyring signedMessage =
    map (either (Left . renderVerificationError) Right) $
        verifyMessagePackets
            defaultVerificationOptions
                { verificationPolicy = VerifyInformational
                , verificationMode = VerificationBatch
                }
            keyring
            ( concatMap
                (either (const []) id . decompressPkt)
                (parsePkts signedMessage)
            )

verifyMessageFromBytestring
    :: PublicKeyring -> BL.ByteString -> [Either String Verification]
verifyMessageFromBytestring keyring signedMessage =
    map (either (Left . renderVerificationError) Right) $
        verifyMessage
            defaultVerificationOptions
                { verificationPolicy = VerifyInformational
                , verificationMode = VerificationStreaming
                }
            keyring
            signedMessage

verifyMessageFromBytestringBatch
    :: PublicKeyring -> BL.ByteString -> [Either String Verification]
verifyMessageFromBytestringBatch keyring signedMessage =
    map (either (Left . renderVerificationError) Right) $
        verifyMessage
            defaultVerificationOptions
                { verificationPolicy = VerifyInformational
                , verificationMode = VerificationBatch
                }
            keyring
            signedMessage

assertMessageVerification
    :: (PublicKeyring -> BL.ByteString -> [Either String Verification])
    -> FilePath
    -> FilePath
    -> [Fingerprint]
    -> Assertion
assertMessageVerification verifier keyringFile messageFile issuers = do
    kr <- loadKeyring keyringFile
    signedMessage <- readFixtureLazy messageFile
    let verification = verifier kr signedMessage
        actual = map (fmap (fingerprint . _verificationSigner)) verification
    assertEqual
        (keyringFile ++ " for " ++ messageFile)
        (map Right issuers)
        actual

loadKeyring :: FilePath -> IO PublicKeyring
loadKeyring keyring =
    DC.runConduitRes $
        CB.sourceFile (fixturePath keyring)
            DC..| conduitGet get
            DC..| conduitToSomeTKsEither
            DC..| CL.map (fmap someTKToPublicViewTK . join . hush)
            DC..| CL.catMaybes
            DC..| sinkPublicKeyringMap

loadAndDecompressPkts :: FilePath -> IO [Pkt]
loadAndDecompressPkts = readFixtureDecompressedPackets

loadArmor :: FilePath -> IO [Armor]
loadArmor file = do
    armored <- readFixtureLazy file
    case AA.decodeLazy armored :: Either String [Armor] of
        Left err ->
            assertFailure
                ("Failed to decode armored fixture " ++ file ++ ": " ++ err)
                >> pure []
        Right armors -> pure armors

encryptMessageDefault
    :: SessionMaterialExposure
    -> Passphrase
    -> ClearPayload
    -> Either
        MessageError
        (EncryptedPayload, Maybe RecoveredSessionMaterial)
encryptMessageDefault exposure passphrase payload =
    encryptMessage
        ( RFC9580EncryptMessageOptions
            { rfc9580EncryptMessageExposure = exposure
            , rfc9580EncryptMessageSymmetricAlgorithm = AES256
            , rfc9580EncryptMessageS2K =
                Argon2 (Salt16 (B.pack [0x80 .. 0x8f])) 1 4 15
            , rfc9580EncryptMessageIV = IV "0123456789ABCDEF"
            }
        )
        passphrase
        payload

mkTestKeyring :: [TK 'PublicTK] -> PublicKeyring
mkTestKeyring tks =
    let someTKs = [SomePublicTK tk | tk <- tks]
     in fst (partitionSomeTKs someTKs)

addTimestampSeconds
    :: ThirtyTwoBitTimeStamp -> Word32 -> ThirtyTwoBitTimeStamp
addTimestampSeconds (ThirtyTwoBitTimeStamp ts) seconds = ThirtyTwoBitTimeStamp (ts + seconds)

timestampToUTCTime :: ThirtyTwoBitTimeStamp -> UTCTime
timestampToUTCTime = posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp

signCertificationAt
    :: SomePKPayload
    -> RSA.PrivateKey
    -> UserId
    -> ThirtyTwoBitTimeStamp
    -> [SigSubPacket]
    -> IO SignaturePayload
signCertificationAt signer signingKey uid creationTime hashedExtras = do
    (hashed, unhashed) <-
        messageIssuerSubpacketsAt signer creationTime
    case signCertificationWithRSA
        GenericCert
        signer
        uid
        (hashedExtras ++ hashed)
        unhashed
        signingKey of
        Left err ->
            assertFailure
                ("failed to sign certification: " ++ renderSignError err)
                >> fail "expected certification signature"
        Right sigPayload -> pure sigPayload

signCertificationRevocationAt
    :: SomePKPayload
    -> RSA.PrivateKey
    -> UserId
    -> ThirtyTwoBitTimeStamp
    -> [SigSubPacket]
    -> IO SignaturePayload
signCertificationRevocationAt signer signingKey uid creationTime hashedExtras = do
    (hashed, unhashed) <-
        messageIssuerSubpacketsAt signer creationTime
    case signCertRevocationWithRSA
        signer
        uid
        (hashedExtras ++ hashed)
        unhashed
        signingKey of
        Left err ->
            assertFailure
                ( "failed to sign certification revocation: "
                    ++ renderSignError err
                )
                >> fail "expected certification revocation signature"
        Right sigPayload -> pure sigPayload

messageIssuerSubpacketsAt
    :: SomePKPayload
    -> ThirtyTwoBitTimeStamp
    -> IO ([SigSubPacket], [SigSubPacket])
messageIssuerSubpacketsAt signer creationTime =
    case eightOctetKeyID signer of
        Left err ->
            assertFailure
                ("failed to derive issuer key id for timeline test: " ++ err)
                >> fail "expected issuer key id"
        Right issuerKeyId ->
            pure
                (
                    [ SigSubPacket False (SigCreationTime creationTime)
                    , SigSubPacket
                        False
                        (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer))
                    ]
                , [SigSubPacket False (Issuer issuerKeyId)]
                )

loadUnencryptedRsaSigner :: IO (SomePKPayload, RSA.PrivateKey)
loadUnencryptedRsaSigner = do
    secretPackets <-
        DC.runConduitRes $
            CB.sourceFile "tests/data/unencrypted.seckey"
                DC..| conduitGet get
                DC..| CL.consume
    case secretPackets of
        (SecretKeyPkt pkp ska : _) ->
            case ska of
                SUUnencrypted (RSAPrivateKey (RSA_PrivateKey privateKey)) _ ->
                    pure (pkp, privateKey)
                _ ->
                    assertFailure
                        "unencrypted.seckey did not contain an unencrypted RSA key"
                        >> fail "expected decrypted RSA private key"
        _ ->
            assertFailure
                "unencrypted.seckey did not begin with a secret key packet"
                >> fail "expected secret key packet"

loadUnencryptedRsaSignerV6 :: IO (SomePKPayload, RSA.PrivateKey)
loadUnencryptedRsaSignerV6 = do
    (signer, signingKey) <- loadUnencryptedRsaSigner
    pure (setKeyVersion V6 signer, signingKey)

setKeyVersion :: KeyVersion -> SomePKPayload -> SomePKPayload
setKeyVersion keyVersion (PKPayload _ ts v3e pka pubkey) =
    PKPayload keyVersion ts v3e pka pubkey

setKeyTimestamp
    :: ThirtyTwoBitTimeStamp -> SomePKPayload -> SomePKPayload
setKeyTimestamp ts (PKPayload keyVersion _ v3e pka pubkey) =
    PKPayload keyVersion ts v3e pka pubkey

setPKAlgorithm
    :: PubKeyAlgorithm -> SomePKPayload -> SomePKPayload
setPKAlgorithm algorithm (PKPayload keyVersion ts v3e _ pubkey) =
    PKPayload keyVersion ts v3e algorithm pubkey

expectV4PKPayload
    :: String -> SomePKPayload -> IO (VersionedPKPayload V4)
expectV4PKPayload label pk =
    case asV4PKPayload pk of
        Left err ->
            assertFailure (label ++ " should have a v4 PKPayload: " ++ err)
                >> fail "expected v4 PKPayload"
        Right v4pk -> pure v4pk

expectV6PKPayload
    :: String -> SomePKPayload -> IO (VersionedPKPayload V6)
expectV6PKPayload label pk =
    case asV6PKPayload pk of
        Left err ->
            assertFailure (label ++ " should have a v6 PKPayload: " ++ err)
                >> fail "expected v6 PKPayload"
        Right v6pk -> pure v6pk

loadDeterministicEd25519Signer
    :: IO (SomePKPayload, Ed25519.SecretKey)
loadDeterministicEd25519Signer = do
    let seed = B.pack [1 .. 32]
    secretKey <-
        case CE.eitherCryptoError (Ed25519.secretKey seed) of
            Left err ->
                assertFailure
                    ( "failed to initialize deterministic Ed25519 secret key: "
                        ++ show err
                    )
                    >> fail "expected deterministic Ed25519 secret key"
            Right sk -> pure sk
    let publicKeyBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString
        signer =
            PKPayload
                V4
                0
                0
                EdDSA
                ( EdDSAPubKey
                    EdSigningCurve25519
                    ( PrefixedNativeEPoint
                        (EPoint (os2ip (B.cons 0x40 publicKeyBytes)))
                    )
                )
    pure (signer, secretKey)

loadDeterministicEd25519SignerV6
    :: IO (SomePKPayload, Ed25519.SecretKey)
loadDeterministicEd25519SignerV6 = do
    let seed = B.pack [1 .. 32]
    secretKey <-
        case CE.eitherCryptoError (Ed25519.secretKey seed) of
            Left err ->
                assertFailure
                    ( "failed to initialize deterministic Ed25519 secret key: "
                        ++ show err
                    )
                    >> fail "expected deterministic Ed25519 secret key"
            Right sk -> pure sk
    let publicKeyBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString
        signer =
            PKPayload
                V6
                0
                0
                EdDSA
                ( EdDSAPubKey
                    EdSigningCurve25519
                    (NativeEPoint (EPoint (os2ip publicKeyBytes)))
                )
    pure (signer, secretKey)

loadDeterministicEd448Signer
    :: IO (SomePKPayload, Ed448.SecretKey)
loadDeterministicEd448Signer = do
    let seed = B.pack [1 .. 57]
    secretKey <-
        case CE.eitherCryptoError (Ed448.secretKey seed) of
            Left err ->
                assertFailure
                    ( "failed to initialize deterministic Ed448 secret key: "
                        ++ show err
                    )
                    >> fail "expected deterministic Ed448 secret key"
            Right sk -> pure sk
    let publicKeyBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString
        signer =
            PKPayload
                V4
                0
                0
                EdDSA
                ( EdDSAPubKey
                    EdSigningCurve448
                    ( PrefixedNativeEPoint
                        (EPoint (os2ip (B.cons 0x40 publicKeyBytes)))
                    )
                )
    pure (signer, secretKey)

loadDeterministicEd448SignerV6
    :: IO (SomePKPayload, Ed448.SecretKey)
loadDeterministicEd448SignerV6 = do
    let seed = B.pack [1 .. 57]
    secretKey <-
        case CE.eitherCryptoError (Ed448.secretKey seed) of
            Left err ->
                assertFailure
                    ( "failed to initialize deterministic Ed448 secret key: "
                        ++ show err
                    )
                    >> fail "expected deterministic Ed448 secret key"
            Right sk -> pure sk
    let publicKeyBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString
        signer =
            PKPayload
                V6
                0
                0
                EdDSA
                ( EdDSAPubKey
                    EdSigningCurve448
                    (NativeEPoint (EPoint (os2ip publicKeyBytes)))
                )
    pure (signer, secretKey)

testSEIPDv2ForV4KeyArmor :: Assertion
testSEIPDv2ForV4KeyArmor = do
    armors <- loadArmor "seipdv2-for-v4-key.pgp.aa"
    armor <-
        case armors of
            [a] -> pure a
            _ ->
                assertFailure
                    "seipdv2-for-v4-key fixture should contain one armored payload"
                    >> fail "expected one armored payload"
    payload <-
        case armor of
            Armor ArmorMessage _ p -> pure p
            Armor atype _ _ ->
                assertFailure
                    ( "seipdv2-for-v4-key fixture should decode as a message block, got "
                        ++ show atype
                    )
                    >> fail "expected message block"
            _ ->
                assertFailure
                    "seipdv2-for-v4-key fixture should decode as an armored payload"
                    >> fail "expected armored payload"
    let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload))
    case packets of
        [ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))
            , SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _)
            ] -> do
                let ridHex = map toUpper (BLC8.unpack (B16L.encode rid))
                if ridHex
                    `elem` [ "C8263FC6D676044B6E973959C2F2C2CAE30DE908"
                           , "04C8263FC6D676044B6E973959C2F2C2CAE30DE908"
                           ]
                    then pure ()
                    else
                        assertFailure
                            ( "seipdv2-for-v4-key fixture should target the expected recipient fingerprint, got "
                                ++ ridHex
                            )
                assertEqual
                    "seipdv2-for-v4-key fixture should use ECDH PKESKv6"
                    ECDH
                    pka
                assertEqual
                    "seipdv2-for-v4-key fixture should use AES-256"
                    AES256
                    sa
                assertEqual
                    "seipdv2-for-v4-key fixture should use OCB"
                    OCB
                    aa
                assertEqual
                    "seipdv2-for-v4-key fixture should use 4KiB chunks"
                    6
                    chunkSize
        _ ->
            assertFailure
                ( "seipdv2-for-v4-key fixture should contain [PKESKPkt (PKESK6 ...), SymEncIntegrityProtectedDataPkt (SEIPD2 ...)], got: "
                    ++ show packets
                )

loadSEIPDv2FixtureWithV4Secret
    :: FilePath -> IO ([Pkt], [Pkt], BL.ByteString)
loadSEIPDv2FixtureWithV4Secret fixture = do
    messageArmor <- loadFirstArmor fixture
    encryptedSecretArmor <-
        loadFirstArmor "v4-encrypted-secret.pgp.aa"
    passphrase <- readPKIPassphrase
    pure
        ( parsePkts (armorPayload messageArmor)
        , parsePkts (armorPayload encryptedSecretArmor)
        , passphrase
        )

forceVersionedRecipientIdentifier :: Pkt -> Pkt
forceVersionedRecipientIdentifier pkt =
    case pkt of
        PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk))
            | BL.length rid == 20 ->
                PKESKPkt
                    (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x04 rid) pka esk))
            | BL.length rid == 32 ->
                PKESKPkt
                    (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x06 rid) pka esk))
            | otherwise -> pkt
        _ -> pkt

selectRecipientKeyInfoByRawRecipientId
    :: Pkt -> [PKESKRecipientKey] -> Maybe PKESKRecipientKey
selectRecipientKeyInfoByRawRecipientId (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) keyInfos =
    listToMaybe
        [ keyInfo
        | keyInfo <- keyInfos
        , supportsPKESKAlgorithm pka keyInfo
        , matchesRawRecipientFingerprint rid keyInfo
        ]
selectRecipientKeyInfoByRawRecipientId (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) keyInfos
    | isWildcardEightOctetKeyId rid =
        listToMaybe
            [ keyInfo | keyInfo <- keyInfos, supportsPKESKAlgorithm pka keyInfo
            ]
    | otherwise =
        listToMaybe
            [ keyInfo
            | keyInfo <- keyInfos
            , supportsPKESKAlgorithm pka keyInfo
            , matchesEightOctetRecipientKeyId rid keyInfo
            ]
selectRecipientKeyInfoByRawRecipientId _ keyInfos = listToMaybe keyInfos

matchesRawRecipientFingerprint
    :: BL.ByteString -> PKESKRecipientKey -> Bool
matchesRawRecipientFingerprint rid keyInfo =
    case pkeskRecipientPKPayload keyInfo of
        Nothing -> False
        Just pkp ->
            BL.toStrict rid == BL.toStrict (unFingerprint (fingerprint pkp))

testSEIPDv2TwoRecipientsArmor :: Assertion
testSEIPDv2TwoRecipientsArmor =
    testSEIPDv2RecipientFixtureArmor
        "seipdv2-two-recipients.pgp.aa"
        2

testSEIPDv2ThreeRecipientsArmor :: Assertion
testSEIPDv2ThreeRecipientsArmor =
    testSEIPDv2RecipientFixtureArmor
        "seipdv2-three-recipients.pgp.aa"
        3

testSEIPDv2RecipientFixtureArmor :: FilePath -> Int -> Assertion
testSEIPDv2RecipientFixtureArmor file expectedRecipients = do
    armors <- loadArmor file
    armor <-
        case armors of
            [a] -> pure a
            _ ->
                assertFailure
                    (file ++ " fixture should contain one armored payload")
                    >> fail "expected one armored payload"
    payload <-
        case armor of
            Armor ArmorMessage _ p -> pure p
            Armor atype _ _ ->
                assertFailure
                    ( file
                        ++ " fixture should decode as a message block, got "
                        ++ show atype
                    )
                    >> fail "expected message block"
            _ ->
                assertFailure
                    (file ++ " fixture should decode as an armored payload")
                    >> fail "expected armored payload"
    let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload))
        pkesks =
            [ (rid, pka)
            | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _)) <-
                packets
            ]
        x25519Esks =
            [ BL.toStrict esk
            | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 esk)) <-
                packets
            ]
        x448Esks =
            [ BL.toStrict esk
            | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 esk)) <-
                packets
            ]
        seipdv2Packets =
            [ (sa, aa, chunkSize)
            | SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _) <-
                packets
            ]
    assertEqual
        ( file
            ++ " fixture should contain expected number of PKESKv6 packets"
        )
        expectedRecipients
        (length pkesks)
    if all (\(_, pka) -> pka == ECDH || pka == X25519) pkesks
        then pure ()
        else
            assertFailure
                ( file
                    ++ " fixture should use only ECDH/X25519 PKESKv6 packets, got "
                    ++ show (map snd pkesks)
                )
    if any ((== ECDH) . snd) pkesks
        then pure ()
        else
            assertFailure
                ( file
                    ++ " fixture should include an ECDH recipient for the v4 key"
                )
    mapM_ (assertX25519EskShape file) x25519Esks
    mapM_ (assertX448EskShape file) x448Esks
    if all
        ( \(rid, _) ->
            let l = BL.length rid
             in l == 20 || l == 21 || l == 32 || l == 33
        )
        pkesks
        then pure ()
        else
            assertFailure
                ( file
                    ++ " fixture should use 20/21-byte or 32/33-byte recipient identifiers"
                )
    case seipdv2Packets of
        [(sa, aa, chunkSize)] -> do
            assertEqual (file ++ " fixture should use AES-256") AES256 sa
            assertEqual (file ++ " fixture should use OCB") OCB aa
            assertEqual
                (file ++ " fixture should use 4KiB chunks")
                6
                chunkSize
        _ ->
            assertFailure
                ( file
                    ++ " fixture should contain one SymEncIntegrityProtectedDataV2 packet"
                )

assertX25519EskShape :: FilePath -> B.ByteString -> Assertion
assertX25519EskShape file x25519Esk
    | B.length x25519Esk < 33 =
        assertFailure
            ( file
                ++ " X25519 PKESKv6 ESK should contain 32-octet ephemeral and wrapped-len"
            )
    | otherwise = do
        let wrappedLen = fromIntegral (B.index x25519Esk 32) :: Int
            wrapped = B.drop 33 x25519Esk
        assertEqual
            (file ++ " X25519 PKESKv6 wrapped length octet")
            wrappedLen
            (B.length wrapped)

assertX448EskShape :: FilePath -> B.ByteString -> Assertion
assertX448EskShape file x448Esk
    | B.length x448Esk < 57 =
        assertFailure
            ( file
                ++ " X448 PKESKv6 ESK should contain 56-octet ephemeral and wrapped-len"
            )
    | otherwise = do
        let wrappedLen = fromIntegral (B.index x448Esk 56) :: Int
            wrapped = B.drop 57 x448Esk
        assertEqual
            (file ++ " X448 PKESKv6 wrapped length octet")
            wrappedLen
            (B.length wrapped)

prependUnusableLatestPKESK :: [Pkt] -> [Pkt]
prependUnusableLatestPKESK packets =
    let bogusRid = BL.pack (0x06 : replicate 32 0x99)
        bogusPKESK =
            PKESKPkt
                (PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk"))
        (eskPrefix, encryptedSuffix) = span isPrecedingESK packets
     in eskPrefix ++ [bogusPKESK] ++ encryptedSuffix

reorderPrecedingPKESKs :: [Pkt] -> [Pkt]
reorderPrecedingPKESKs packets =
    let (eskPrefix, encryptedSuffix) = span isPrecedingESK packets
        reorderedPKESKs = reverse [pkt | pkt@(PKESKPkt _) <- eskPrefix]
     in refillPKESKSlots eskPrefix reorderedPKESKs ++ encryptedSuffix
  where
    refillPKESKSlots [] _ = []
    refillPKESKSlots (pkt : rest) pkesks =
        case pkt of
            PKESKPkt {} ->
                case pkesks of
                    [] -> pkt : refillPKESKSlots rest []
                    (replacement : remaining) ->
                        replacement : refillPKESKSlots rest remaining
            _ -> pkt : refillPKESKSlots rest pkesks

isPrecedingESK :: Pkt -> Bool
isPrecedingESK (PKESKPkt _) = True
isPrecedingESK (SKESKPkt _) = True
isPrecedingESK _ = False

messageVerificationFixtures
    :: [(String, FilePath, FilePath, [Fingerprint])]
messageVerificationFixtures =
    [
        ( "uncompressed-ops-dsa"
        , "pubring.gpg"
        , "uncompressed-ops-dsa.gpg"
        , [fp "1EB2 0B2F 5A5C C3BE AFD6  E5CB 7732 CF98 8A63 EA86"]
        )
    ,
        ( "uncompressed-ops-dsa-sha384"
        , "pubring.gpg"
        , "uncompressed-ops-dsa-sha384.txt.gpg"
        , [fp "1EB2 0B2F 5A5C C3BE AFD6  E5CB 7732 CF98 8A63 EA86"]
        )
    ,
        ( "uncompressed-ops-rsa"
        , "pubring.gpg"
        , "uncompressed-ops-rsa.gpg"
        , [fp "CB79 3345 9F59 C70D F1C3  FBEE DEDC 3ECF 689A F56D"]
        )
    ,
        ( "compressedsig"
        , "pubring.gpg"
        , "compressedsig.gpg"
        , [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"]
        )
    ,
        ( "compressedsig-zlib"
        , "pubring.gpg"
        , "compressedsig-zlib.gpg"
        , [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"]
        )
    ,
        ( "compressedsig-bzip2"
        , "pubring.gpg"
        , "compressedsig-bzip2.gpg"
        , [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"]
        )
    ]

certificateVerificationFixtures
    :: [(String, FilePath, FilePath, [Fingerprint])]
certificateVerificationFixtures =
    [
        ( "userid"
        , "pubring.gpg"
        , "minimized.gpg"
        , [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"]
        )
    ,
        ( "subkey"
        , "pubring.gpg"
        , "subkey.gpg"
        , [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"]
        )
    ,
        ( "primary key binding"
        , "signing-subkey.gpg"
        , "primary-binding.gpg"
        , [fp "ED1B D216 F70E 5D5F 4444  48F9 B830 F2C4 83A9 9AE5"]
        )
    ,
        ( "attribute"
        , "pubring.gpg"
        , "uat.gpg"
        , [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"]
        )
    ,
        ( "primary key revocation"
        , "pubring.gpg"
        , "prikey-rev.gpg"
        , [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"]
        )
    ,
        ( "subkey revocation"
        , "pubring.gpg"
        , "subkey-rev.gpg"
        , [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"]
        )
    ,
        ( "6F87040E"
        , "pubring.gpg"
        , "6F87040E.pubkey"
        ,
            [ fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"
            , fp "CB79 3345 9F59 C70D F1C3  FBEE DEDC 3ECF 689A F56D"
            , fp "AF95 E4D7 BAC5 21EE 9740  BED7 5E9F 1523 4132 62DC"
            ]
        )
    ,
        ( "6F87040E-cr"
        , "pubring.gpg"
        , "6F87040E-cr.pubkey"
        ,
            [ fp "AF95 E4D7 BAC5 21EE 9740  BED7 5E9F 1523 4132 62DC"
            , fp "AF95 E4D7 BAC5 21EE 9740  BED7 5E9F 1523 4132 62DC"
            , fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"
            , fp "CB79 3345 9F59 C70D F1C3  FBEE DEDC 3ECF 689A F56D"
            , fp "AF95 E4D7 BAC5 21EE 9740  BED7 5E9F 1523 4132 62DC"
            ]
        )
    ,
        ( "simple RSA secret key"
        , "pubring.gpg"
        , "simple.seckey"
        , [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"]
        )
    ,
        ( "simple ECDSA public key"
        , "ecdsa-key-without-ecdh.pubkey"
        , "ecdsa-key-without-ecdh.pubkey"
        , [fp "174C CF12 C571 6D0E 527F  B50E F770 8BAD D606 3224"]
        )
    ]

verificationFixtureGroup
    :: String
    -> (PublicKeyring -> BL.ByteString -> [Either String Verification])
    -> [(String, FilePath, FilePath, [Fingerprint])]
    -> TestTree
verificationFixtureGroup groupName verifier fixtures =
    testGroup
        groupName
        [ testCase
            name
            ( assertMessageVerification
                verifier
                keyringFile
                messageFile
                issuers
            )
        | (name, keyringFile, messageFile, issuers) <- fixtures
        ]

loadV6UnencryptedSecretKeyFixtureForProperty
    :: IO (Either String (SomePKPayload, SKAddendum, SKey))
loadV6UnencryptedSecretKeyFixtureForProperty = do
    armored <- readFixtureLazy "v6-secret.pgp.aa"
    pure $ do
        armors <-
            first
                ("failed to decode v6 secret fixture: " ++)
                (AA.decodeLazy armored)
        armor <-
            case armors of
                (a : _) -> Right a
                [] -> Left "v6-secret.pgp.aa should contain one armored payload"
        let packets = parsePkts (armorPayload armor)
        (pkp, ska) <-
            case packets of
                (SecretKeyPkt pkpayload skaddendum : _) -> Right (pkpayload, skaddendum)
                _ -> Left "v6-secret.pgp.aa should begin with a secret key packet"
        skey <-
            case ska of
                SUUnencrypted x _ -> Right x
                _ ->
                    Left
                        "v6-secret.pgp.aa should contain unencrypted secret key material"
        Right (pkp, ska, skey)

loadV4EncryptedSecretKeyFixtureForProperty
    :: IO
        (Either String (SomePKPayload, SKAddendum, SKey, BL.ByteString))
loadV4EncryptedSecretKeyFixtureForProperty = do
    passphrase <- readPKIPassphrase
    packets <-
        DC.runConduitRes $
            CB.sourceFile "tests/data/aes256-sha512.seckey"
                DC..| conduitGet get
                DC..| CL.consume
    pure $ do
        (pkp, ska) <-
            case packets of
                (SecretKeyPkt pkpayload skaddendum : _) -> Right (pkpayload, skaddendum)
                _ ->
                    Left "aes256-sha512.seckey should begin with a secret key packet"
        skey <-
            case decryptPrivateKey (pkp, ska) passphrase of
                Right (SUUnencrypted x _) -> Right x
                Right other ->
                    Left
                        ("unexpected decrypted key shape for v4 fixture: " ++ show other)
                Left err ->
                    Left ("failed to decrypt v4 fixture secret key: " ++ err)
        Right (pkp, ska, skey, passphrase)

reverseIf :: Bool -> [a] -> [a]
reverseIf shouldReverse xs
    | shouldReverse = reverse xs
    | otherwise = xs

cgp :: DC.ConduitT B.ByteString Pkt (ResourceT IO) ()
cgp = conduitGet (get :: Get Pkt)

fp :: Text -> Fingerprint
fp = either error id . parseFingerprint

doPkeyAndSkeyMatch :: PKey -> SKey -> Assertion
doPkeyAndSkeyMatch (RSAPubKey (RSA_PublicKey rpub)) (RSAPrivateKey (RSA_PrivateKey rpriv)) =
    assertEqual
        "RSA private key matches RSA public key"
        rpub
        (RSA.private_pub rpriv)
doPkeyAndSkeyMatch (ECDSAPubKey (ECDSA_PublicKey ecpub)) (ECDSAPrivateKey (ECDSA_PrivateKey ecpriv)) =
    assertEqual
        "ECDSA private key curve matches ECDSA public key curve"
        (ECDSA.public_curve ecpub)
        (ECDSA.private_curve ecpriv)
doPkeyAndSkeyMatch _ _ = assertFailure "matching unimplemented"

{-# NOINLINE secretKeyInfoCacheRef #-}
secretKeyInfoCacheRef
    :: IORef [(([Pkt], BL.ByteString), [PKESKRecipientKey])]
secretKeyInfoCacheRef = unsafePerformIO (newIORef [])

collectSecretKeyInfos
    :: [Pkt] -> BL.ByteString -> IO [PKESKRecipientKey]
collectSecretKeyInfos pkts passphrase = do
    cache <- readIORef secretKeyInfoCacheRef
    case lookup (pkts, passphrase) cache of
        Just cached -> pure cached
        Nothing -> do
            keyInfos <- computeSecretKeyInfos
            modifyIORef'
                secretKeyInfoCacheRef
                (((pkts, passphrase), keyInfos) :)
            pure keyInfos
  where
    computeSecretKeyInfos = do
        let keyInfoResults = map toKeyInfo pkts
            keyInfos = catMaybes [mKeyInfo | Right mKeyInfo <- keyInfoResults]
            unlockErrors = [err | Left err <- keyInfoResults]
        unless (null unlockErrors) $
            assertFailure
                ( "one or more secret key packets failed to unlock (partial failures are surfaced to\
                  \ prevent silent key-context gaps):\n"
                    ++ unlines unlockErrors
                )
        pure keyInfos

    toKeyInfo (SecretKeyPkt pkp ska) = decryptToRecipientKey "SecretKeyPkt" pkp ska
    toKeyInfo (SecretSubkeyPkt pkp ska) = decryptToRecipientKey "SecretSubkeyPkt" pkp ska
    toKeyInfo _ = Right Nothing

    decryptToRecipientKey contextLabel pkp ska =
        case ska of
            SUUnencrypted skey _ ->
                Right
                    ( Just
                        ( PKESKRecipientKey
                            { pkeskRecipientPKPayload = Just pkp
                            , pkeskRecipientSKey = skey
                            }
                        )
                    )
            _ ->
                case decryptPrivateKey (pkp, ska) passphrase of
                    Right (SUUnencrypted skey _) ->
                        Right
                            ( Just
                                ( PKESKRecipientKey
                                    { pkeskRecipientPKPayload = Just pkp
                                    , pkeskRecipientSKey = skey
                                    }
                                )
                            )
                    Right decryptedSKA ->
                        Left
                            ( contextLabel
                                ++ " "
                                ++ show (fingerprint pkp)
                                ++ ": decryptPrivateKey returned unexpected protection: "
                                ++ show decryptedSKA
                            )
                    Left err ->
                        Left
                            ( contextLabel
                                ++ " "
                                ++ show (fingerprint pkp)
                                ++ ": decryptPrivateKey failed: "
                                ++ err
                            )

signSubkeyRevocationWithRSAAt
    :: SomePKPayload
    -> SomePKPayload
    -> RSA.PrivateKey
    -> ThirtyTwoBitTimeStamp
    -> IO SignaturePayload
signSubkeyRevocationWithRSAAt signer subkey signingKey creationTime = do
    (hashed, unhashed) <-
        messageIssuerSubpacketsAt signer creationTime
    case signSubkeyRevocationWithRSA
        signer
        subkey
        hashed
        unhashed
        signingKey of
        Left err ->
            assertFailure
                ("failed to sign subkey revocation: " ++ renderSignError err)
                >> fail "expected subkey revocation signature"
        Right sigPayload -> pure sigPayload

signSubkeyBindingWithRSAAt
    :: SomePKPayload
    -> SomePKPayload
    -> RSA.PrivateKey
    -> ThirtyTwoBitTimeStamp
    -> IO SignaturePayload
signSubkeyBindingWithRSAAt signer subkey signingKey creationTime = do
    signSubkeyBindingWithRSAExtrasAt
        signer
        subkey
        signingKey
        creationTime
        []

signDirectKeyWithRSAExtrasAt
    :: SomePKPayload
    -> RSA.PrivateKey
    -> ThirtyTwoBitTimeStamp
    -> [SigSubPacket]
    -> IO SignaturePayload
signDirectKeyWithRSAExtrasAt signer signingKey creationTime hashedExtras = do
    (hashed, unhashed) <-
        messageIssuerSubpacketsAt signer creationTime
    case signDirectKeyWithRSA
        SignatureDirectlyOnAKey
        signer
        (hashedExtras ++ hashed)
        unhashed
        signingKey of
        Left err ->
            assertFailure
                ( "failed to sign direct key self-signature: "
                    ++ renderSignError err
                )
                >> fail "expected direct key self-signature"
        Right sigPayload -> pure sigPayload

signSubkeyBindingWithRSAExtrasAt
    :: SomePKPayload
    -> SomePKPayload
    -> RSA.PrivateKey
    -> ThirtyTwoBitTimeStamp
    -> [SigSubPacket]
    -> IO SignaturePayload
signSubkeyBindingWithRSAExtrasAt signer subkey signingKey creationTime hashedExtras = do
    (hashed, unhashed) <-
        messageIssuerSubpacketsAt signer creationTime
    let bindingPayload =
            payloadForSig
                SubkeyBindingSig
                emptyPSC
                    { lastPrimaryKey = PublicKeyPkt signer
                    , lastSubkey = PublicSubkeyPkt subkey
                    }
    case signDataWithRSA
        SubkeyBindingSig
        signingKey
        (hashedExtras ++ hashed)
        unhashed
        bindingPayload of
        Left err ->
            assertFailure
                ("failed to sign subkey binding: " ++ renderSignError err)
                >> fail "expected subkey binding signature"
        Right sigPayload -> pure sigPayload

verifyTimelinePackets
    :: PublicKeyring
    -> BL.ByteString
    -> SignaturePayload
    -> [Either VerificationError Verification]
verifyTimelinePackets keyring payload sigPayload =
    verifyMessagePackets
        defaultVerificationOptions
            { verificationPolicy = VerifyStrict
            , verificationMode = VerificationBatch
            }
        keyring
        [ LiteralDataPkt BinaryData BL.empty 0 payload
        , SignaturePkt sigPayload
        ]

assertSingleSignerFingerprint
    :: String
    -> Fingerprint
    -> [Either VerificationError Verification]
    -> Assertion
assertSingleSignerFingerprint label expected results =
    case results of
        [Right verification] ->
            assertEqual
                label
                expected
                (fingerprint (_verificationSigner verification))
        other ->
            assertFailure
                ( label
                    ++ ", expected one successful verification result, got "
                    ++ show (length other)
                    ++ " result(s)"
                )

assertSingleFailureContainsTimeline
    :: String
    -> String
    -> [Either VerificationError Verification]
    -> Assertion
assertSingleFailureContainsTimeline label needle results =
    case results of
        [Left err] ->
            assertBool
                label
                (needle `isInfixOf` renderVerificationError err)
        other ->
            assertFailure
                ( label
                    ++ ", expected one verification failure result, got "
                    ++ show (length other)
                    ++ " result(s)"
                )

signCertificationWithEd25519At
    :: SomePKPayload
    -> SomePKPayload
    -> Ed25519.SecretKey
    -> UserId
    -> ThirtyTwoBitTimeStamp
    -> [SigSubPacket]
    -> IO SignaturePayload
signCertificationWithEd25519At certifiedSigner certifierSigner signingKey uid creationTime hashedExtras = do
    (hashed, unhashed) <-
        messageIssuerSubpacketsAt certifierSigner creationTime
    let state =
            emptyPSC
                { lastPrimaryKey = PublicKeyPkt certifiedSigner
                , lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText)
                }
    case signDataWithEd25519
        GenericCert
        signingKey
        (hashedExtras ++ hashed)
        unhashed
        (payloadForSig GenericCert state) of
        Left err ->
            assertFailure
                ("failed to sign Ed25519 certification: " ++ renderSignError err)
                >> fail "expected Ed25519 certification signature"
        Right sigPayload -> pure sigPayload

signCertificationRevocationWithEd25519At
    :: SomePKPayload
    -> SomePKPayload
    -> Ed25519.SecretKey
    -> UserId
    -> ThirtyTwoBitTimeStamp
    -> [SigSubPacket]
    -> IO SignaturePayload
signCertificationRevocationWithEd25519At certifiedSigner certifierSigner signingKey uid creationTime hashedExtras = do
    (hashed, unhashed) <-
        messageIssuerSubpacketsAt certifierSigner creationTime
    let state =
            emptyPSC
                { lastPrimaryKey = PublicKeyPkt certifiedSigner
                , lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText)
                }
    case signDataWithEd25519
        CertRevocationSig
        signingKey
        (hashedExtras ++ hashed)
        unhashed
        (payloadForSig CertRevocationSig state) of
        Left err ->
            assertFailure
                ( "failed to sign Ed25519 certification revocation: "
                    ++ renderSignError err
                )
                >> fail "expected Ed25519 certification revocation signature"
        Right sigPayload -> pure sigPayload

signKeyRevocationWithReasonAt
    :: SomePKPayload
    -> RSA.PrivateKey
    -> ThirtyTwoBitTimeStamp
    -> RevocationCode
    -> IO SignaturePayload
signKeyRevocationWithReasonAt signer signingKey creationTime reasonCode =
    signKeyRevocationWithReasonAndExtrasAt
        signer
        signingKey
        creationTime
        reasonCode
        []

signKeyRevocationWithReasonAndExtrasAt
    :: SomePKPayload
    -> RSA.PrivateKey
    -> ThirtyTwoBitTimeStamp
    -> RevocationCode
    -> [SigSubPacket]
    -> IO SignaturePayload
signKeyRevocationWithReasonAndExtrasAt signer signingKey creationTime reasonCode hashedExtras = do
    (hashed, unhashed) <-
        messageIssuerSubpacketsAt signer creationTime
    case signKeyRevocationWithRSA
        signer
        ( SigSubPacket False (ReasonForRevocation reasonCode "")
            : hashedExtras
            ++ hashed
        )
        unhashed
        signingKey of
        Left err ->
            assertFailure
                ("failed to sign key revocation: " ++ renderSignError err)
                >> fail "expected key revocation signature"
        Right sigPayload -> pure sigPayload

signBinaryMessageWithRSAAt
    :: SomePKPayload
    -> RSA.PrivateKey
    -> ThirtyTwoBitTimeStamp
    -> BL.ByteString
    -> IO SignaturePayload
signBinaryMessageWithRSAAt signer signingKey creationTime payload = do
    (hashed, unhashed) <-
        messageIssuerSubpacketsAt signer creationTime
    case signDataWithRSA BinarySig signingKey hashed unhashed payload of
        Left err ->
            assertFailure
                ("failed to sign RSA message payload: " ++ renderSignError err)
                >> fail "expected RSA message signature"
        Right sigPayload -> pure sigPayload

signBinaryMessageWithEd25519At
    :: SomePKPayload
    -> Ed25519.SecretKey
    -> ThirtyTwoBitTimeStamp
    -> BL.ByteString
    -> IO SignaturePayload
signBinaryMessageWithEd25519At signer signingKey creationTime payload = do
    (hashed, unhashed) <-
        messageIssuerSubpacketsAt signer creationTime
    case signDataWithEd25519 BinarySig signingKey hashed unhashed payload of
        Left err ->
            assertFailure
                ("failed to sign Ed25519 message payload: " ++ renderSignError err)
                >> fail "expected Ed25519 message signature"
        Right sigPayload -> pure sigPayload
