hOpenPGP-3.1: Codec/Encryption/OpenPGP/Signatures.hs

{-# LANGUAGE ConstraintKinds #-}
-- Signatures.hs: OpenPGP (RFC9580) signature verification
-- Copyright © 2012-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Codec.Encryption.OpenPGP.Signatures
    ( SignError (..)
    , renderSignError
    , CertificationState (..)
    , certificationStateAt
    , VerificationError (..)
    , renderVerificationError
    , verifySigWith
    , verifyAgainstKeyring
    , verifyAgainstKeys
    , verifyAgainstKeysWithPolicy
    , verifyAgainstPKPs
    , verifyAgainstPKPsWithPolicy
    , verifyTKWith
    , verifyUnknownTKWith
    , signCertificationWithRSA
    , signDirectKeyWithRSA
    , signKeyRevocationWithRSA
    , signSubkeyRevocationWithRSA
    , signCertRevocationWithRSA
    , signUserIDwithRSA
    , crossSignSubkeyWithRSA
    , signDataWithEd25519
    , signDataWithEd25519Legacy
    , signDataWithEd25519V6
    , signDataWithEd448
    , signDataWithEd448V6
    , signDataWithRSA
    , signDataWithRSAV6

      -- * Builder-based API (Phase 2)
    , signDataWithRSABuilder
    , signDataWithRSAV6Builder
    , signDataWithEd25519Builder
    , signDataWithEd25519V6Builder
    , signDataWithEd448Builder
    , signDataWithEd448V6Builder
    , signDataWithAlgorithmicBuilder

      -- * Text normalization mode
    , TextNormalizationMode (..)
    ) where

import Control.Applicative ((<|>))
import Control.Error.Util (hush)
import Control.Lens ((&), (^.), _1)
import Control.Monad (liftM2, when)
import Crypto.Error (eitherCryptoError)
import Crypto.Hash (hashWith)
import qualified Crypto.Hash.Algorithms as CHA
import Crypto.Number.Serialize (i2osp, os2ip)
import qualified Crypto.PubKey.DSA as DSA
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import qualified Crypto.PubKey.RSA.Types as RSATypes
import Data.Bifunctor (first)
import Data.Binary.Put (runPut)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.Either (isRight, lefts, rights)
import Data.Function (on)
import Data.IxSet.Typed ((@=))
import qualified Data.IxSet.Typed as IxSet
import Data.List (find, intercalate, nub)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, mapMaybe)
import qualified Data.Set as Set
import Data.Text (Text)
import Data.Time.Clock (UTCTime (..), addUTCTime, diffUTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Word (Word16, Word8)
import GHC.TypeLits (ErrorMessage (..), TypeError)

import Codec.Encryption.OpenPGP.Expirations
    ( isPKTimeValidWithSelfSignatures
    , keyStateAt
    , keyStateValid
    )
import Codec.Encryption.OpenPGP.Fingerprint
    ( eightOctetKeyID
    , fingerprint
    )
import Codec.Encryption.OpenPGP.Internal
    ( PktStreamContext (..)
    , emptyPSC
    , issuer
    , issuerFP
    )
import Codec.Encryption.OpenPGP.Ontology
    ( isCertRevocationSig
    , isRevocationKeySSP
    , isRevokerP
    , isSubkeyBindingSig
    , isSubkeyRevocation
    )
import Codec.Encryption.OpenPGP.Policy
    ( VerificationPolicy (..)
    , VerificationPolicyAction (..)
    , applyVerificationPolicy
    , defaultVerificationPolicy
    , isVerificationError
    , isVerificationWarning
    , signatureV6SaltSizeForHashAlgorithm
    )
import Codec.Encryption.OpenPGP.SerializeForSigs
    ( payloadForSig
    , putKeyforSigning
    , putPartialSigforSigning
    , putSigTrailer
    , putUforSigning
    )
import Codec.Encryption.OpenPGP.SignatureQualities
    ( sigCT
    , sigHA
    , sigPKA
    , sigType
    , signatureHashedSubpacketsKnown
    , signatureSubpacketListsKnown
    )
import Codec.Encryption.OpenPGP.Subpackets
    ( PrivateKeyFor
    , SigBuilder
    , TextNormalizationMode (..)
    , sbHashAlgo
    , sbHashedSubs
    , sbSalt
    , sbSigType
    , sbTextNormMode
    , sbUnhashedSubs
    )
import qualified Codec.Encryption.OpenPGP.Subpackets as SP
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA
import Codec.Encryption.OpenPGP.Types.Internal.Pkt
    ( VerificationWarning (..)
    )
import Data.Conduit.OpenPGP.Keyring.Instances ()

data VerificationError
    = IssuerSubpacketMismatch
    | IssuerSubpacketUncheckable String
    | IssuerKeyIdProhibitedInV6Signature
    | IssuerFingerprintSubpacketMismatch
    | UnsupportedCriticalSubpacket SigType
    | UnknownCriticalPacketInStream Word8
    | BrokenCriticalPacketInStream Word8 String
    | ExternalVerificationError String
    | NonSignaturePacket
    | UnexpectedSignaturePayloadShape
    | MissingHashAlgorithm
    | HashComputationFailed String
    | UnexpectedKeyVersion
    | SignatureHashUnsupportedByAlgorithm HashAlgorithm PubKeyAlgorithm
    | KeyRevoked
    | SigningKeyUnavailableAtSignatureTime
    | MissingIssuer
    | SigningKeyNotFound (Maybe EightOctetKeyId) (Maybe Fingerprint)
    | MultipleVerificationSuccesses Int
    | UnsupportedKeyType PubKeyAlgorithm
    | SignatureMismatch PubKeyAlgorithm Fingerprint
    | SignatureShapeMismatch PubKeyAlgorithm
    | SignatureEncodingInvalid PubKeyAlgorithm String
    | SignaturePolicyHashUnsupported HashAlgorithm
    | SignaturePolicyPKAMismatch PubKeyAlgorithm PubKeyAlgorithm
    | SignatureExpired
    | CandidateKeyFailures [VerificationError]
    | {- | An embedded primary-key back-signature (type 0x19) in a subkey
      binding signature failed to verify.
      -}
      InvalidSubkeyBackSignature VerificationError
    deriving (Eq, Show)

data CertificationState
    = CertificationNotYetKnown
    | CertificationActive
    | CertificationRevoked
    deriving (Eq, Show)

renderVerificationError :: VerificationError -> String
renderVerificationError IssuerSubpacketMismatch =
    "verification failed: issuer subpacket does not match the actual signer"
renderVerificationError (IssuerSubpacketUncheckable err) =
    "verification failed: issuer subpacket cannot be checked ("
        ++ err
        ++ ")"
renderVerificationError IssuerKeyIdProhibitedInV6Signature =
    "verification failed: Issuer Key ID subpacket is prohibited in v6 signatures"
renderVerificationError IssuerFingerprintSubpacketMismatch =
    "verification failed: issuer fingerprint subpacket does not match the actual signer"
renderVerificationError (UnsupportedCriticalSubpacket sigType) =
    "verification failed: unsupported critical hashed subpacket in "
        ++ show sigType
        ++ " signature"
renderVerificationError (UnknownCriticalPacketInStream t) =
    "verification failed: unknown critical packet type in packet sequence ("
        ++ show t
        ++ ")"
renderVerificationError (BrokenCriticalPacketInStream t err) =
    "verification failed: broken critical packet type "
        ++ show t
        ++ ": "
        ++ err
renderVerificationError (ExternalVerificationError err) = err
renderVerificationError NonSignaturePacket =
    "verification failed: non-signature packet encountered where signature was expected"
renderVerificationError UnexpectedSignaturePayloadShape =
    "verification failed: unexpected signature payload shape"
renderVerificationError MissingHashAlgorithm =
    "verification failed: signature payload is missing hash algorithm"
renderVerificationError (HashComputationFailed err) =
    "verification failed: hash computation error (" ++ err ++ ")"
renderVerificationError UnexpectedKeyVersion =
    "verification failed: signing key has unexpected version (only v4 and v6 are supported)"
renderVerificationError (SignatureHashUnsupportedByAlgorithm ha pka) =
    "verification failed: hash algorithm "
        ++ show ha
        ++ " is not supported by "
        ++ show pka
        ++ " signing backend"
renderVerificationError KeyRevoked =
    "verification failed: signing key is revoked"
renderVerificationError SigningKeyUnavailableAtSignatureTime =
    "verification failed: signing key was not valid at the signature creation time"
renderVerificationError MissingIssuer =
    "verification failed: signature is missing issuer information"
renderVerificationError (SigningKeyNotFound meoki mfp) =
    "verification failed: signing key not found in keyring"
        ++ issuerContext meoki mfp
renderVerificationError (MultipleVerificationSuccesses n) =
    "verification failed: multiple successful key matches ("
        ++ show n
        ++ ")"
renderVerificationError (UnsupportedKeyType pka) =
    "verification failed: unsupported public key algorithm for verification ("
        ++ show pka
        ++ ")"
renderVerificationError (SignatureMismatch pka fpr) =
    "verification failed: "
        ++ show pka
        ++ " signature mismatch (signer "
        ++ show fpr
        ++ ")"
renderVerificationError (SignatureShapeMismatch pka) =
    "verification failed: malformed "
        ++ show pka
        ++ " signature encoding"
renderVerificationError (SignatureEncodingInvalid pka err) =
    "verification failed: invalid "
        ++ show pka
        ++ " key/signature encoding ("
        ++ err
        ++ ")"
renderVerificationError (SignaturePolicyHashUnsupported ha) =
    "verification failed: unsupported signature hash policy ("
        ++ show ha
        ++ ")"
renderVerificationError (SignaturePolicyPKAMismatch sigPka keyPka) =
    "verification failed: signature public-key algorithm "
        ++ show sigPka
        ++ " does not match key algorithm "
        ++ show keyPka
renderVerificationError SignatureExpired =
    "verification failed: signature expired"
renderVerificationError (CandidateKeyFailures errs) =
    "verification failed: no candidate key validated the signature ("
        ++ intercalate "; " (nub (map renderVerificationError errs))
        ++ ")"
renderVerificationError (InvalidSubkeyBackSignature err) =
    "verification failed: embedded primary-key back-signature verification failed: "
        ++ renderVerificationError err

issuerContext
    :: Maybe EightOctetKeyId -> Maybe Fingerprint -> String
issuerContext meoki mfp =
    case (meoki, mfp) of
        (Nothing, Nothing) -> ""
        _ ->
            " (issuer-keyid="
                ++ maybe "unknown" show meoki
                ++ ", issuer-fingerprint="
                ++ maybe "unknown" show mfp
                ++ ")"

verificationError
    :: VerificationError -> Either VerificationError a
verificationError = Left

renderVerificationResult
    :: Either VerificationError a -> Either String a
renderVerificationResult = first renderVerificationError

data SignError
    = SignBackendError String
    | SignUnsupportedCertificationType SigType
    | SignUnsupportedKeySignatureType SigType
    | SignV6SaltSizeMismatch HashAlgorithm Word8 Int
    | SignProducedWrongLength String Int Int
    deriving (Eq, Show)

renderSignError :: SignError -> String
renderSignError (SignBackendError err) =
    "signature backend error: " ++ err
renderSignError (SignUnsupportedCertificationType st) =
    "unsupported certification signature type: "
        ++ show st
        ++ " (expected one of GenericCert/PersonaCert/CasualCert/PositiveCert)"
renderSignError (SignUnsupportedKeySignatureType st) =
    "unsupported key signature type: "
        ++ show st
        ++ " (expected SignatureDirectlyOnAKey or KeyRevocationSig)"
renderSignError (SignV6SaltSizeMismatch ha expected actual) =
    "v6 signature salt size mismatch for "
        ++ show ha
        ++ ": expected "
        ++ show expected
        ++ ", got "
        ++ show actual
renderSignError (SignProducedWrongLength algo expected actual) =
    algo
        ++ " produced a non-"
        ++ show expected
        ++ "-byte signature (got "
        ++ show actual
        ++ ")"

data VerifiableSignatureV where
    VerifiableSignatureV4
        :: SignaturePayloadV 'SigPayloadV4 -> VerifiableSignatureV
    VerifiableSignatureV6
        :: SignaturePayloadV 'SigPayloadV6 -> VerifiableSignatureV

fromSignaturePayloadVerifiableSignatureV
    :: SignaturePayload -> Maybe VerifiableSignatureV
fromSignaturePayloadVerifiableSignatureV sigPayload =
    case toSomeSignaturePayload sigPayload of
        SomeSignaturePayload (payload@SigPayloadV4Data {}) ->
            Just (VerifiableSignatureV4 payload)
        SomeSignaturePayload (payload@SigPayloadV6Data {}) ->
            Just (VerifiableSignatureV6 payload)
        _ -> Nothing

isVerifiableSignaturePayload :: SignaturePayload -> Bool
isVerifiableSignaturePayload = isJust . fromSignaturePayloadVerifiableSignatureV

toSignaturePayloadFromVerifiable
    :: VerifiableSignatureV -> SignaturePayload
toSignaturePayloadFromVerifiable (VerifiableSignatureV4 payload) =
    toSignaturePayload payload
toSignaturePayloadFromVerifiable (VerifiableSignatureV6 payload) =
    toSignaturePayload payload

fromPktEitherVerifiableSignatureV
    :: Pkt -> Either VerificationError VerifiableSignatureV
fromPktEitherVerifiableSignatureV (SignaturePkt sigPayload) =
    case fromSignaturePayloadVerifiableSignatureV sigPayload of
        Just verifiableSig -> Right verifiableSig
        Nothing ->
            verificationError UnexpectedSignaturePayloadShape
fromPktEitherVerifiableSignatureV _ =
    verificationError NonSignaturePacket

signaturePKAAndMPIsFromClass
    :: SomeSignatureV
    -> Either VerificationError (PubKeyAlgorithm, NonEmpty MPI)
signaturePKAAndMPIsFromClass =
    fmap (\(pka, _, mpis) -> (pka, mpis))
        . signatureVerificationMaterialFromClass

signatureLeft16FromClass
    :: SomeSignatureV -> Either VerificationError Word16
signatureLeft16FromClass =
    fmap (\(_, l16, _) -> l16)
        . signatureVerificationMaterialFromClass

signatureVerificationMaterialFromClass
    :: SomeSignatureV
    -> Either VerificationError (PubKeyAlgorithm, Word16, NonEmpty MPI)
signatureVerificationMaterialFromClass (SomeSignatureV typedSig) =
    case typedSig of
        SignatureV3Packet (SigPayloadV3Data _ _ _ pka _ l16 mpis) ->
            Right (pka, l16, mpis)
        SignatureV4Packet (SigPayloadV4Data _ pka _ _ _ l16 mpis) ->
            Right (pka, l16, mpis)
        SignatureV6Packet (SigPayloadV6Data _ pka _ _ _ _ l16 mpis) ->
            Right (pka, l16, mpis)
        _ ->
            verificationError UnexpectedSignaturePayloadShape

verifySigWith
    :: VerificationPolicy
    -> ( Pkt
         -> Maybe UTCTime
         -> ByteString
         -> Either VerificationError Verification
       )
    -> Pkt
    -> PktStreamContext
    -> Maybe UTCTime
    -> Either VerificationError Verification
verifySigWith policy vf sig@(SignaturePkt _) state mt =
    case fromPktEitherVerifiableSignatureV sig of
        Right verifiableSig ->
            let (st, hs, us, checkSubpacket, checkUnhashedSubpackets) =
                    verifiableSignatureVerificationInputs verifiableSig
             in checkUnhashedSubpackets us
                    *> verifyWithSubpacketChecks
                        policy
                        vf
                        sig
                        state
                        mt
                        st
                        hs
                        checkSubpacket
        Left err ->
            Left err
  where
    checkV4Subpacket signer i@Issuer {} = checkIssuerSubpacket (eightOctetKeyID signer) i
    checkV4Subpacket signer i@IssuerFingerprint {} =
        checkIssuerFingerprintSubpacket
            PKA.IssuerFingerprintV4
            (fingerprint signer)
            i
    checkV4Subpacket _ _ = Right True
    -- RFC 9580 §5.2.3.35: v6 signatures MUST NOT include an Issuer Key ID subpacket.
    -- Treat any such subpacket as a verification error rather than merely uncheckable.
    checkV6Subpacket _ Issuer {} =
        case applyVerificationPolicy
            (vpLegacyIssuerKeyIdInV6 policy)
            "Issuer Key ID subpacket is prohibited in v6 signatures" of
            Left err -> verificationError IssuerKeyIdProhibitedInV6Signature
            Right warn -> Right True -- We don't have a warning type for this yet
    checkV6Subpacket signer i@IssuerFingerprint {} =
        checkIssuerFingerprintSubpacket
            PKA.IssuerFingerprintV6
            (fingerprint signer)
            i
    checkV6Subpacket _ _ = Right True
    rejectV6UnhashedIssuer (SigSubPacket _ Issuer {}) =
        case applyVerificationPolicy
            (vpLegacyIssuerKeyIdInV6 policy)
            "Issuer Key ID subpacket is prohibited in v6 signatures" of
            Left err -> verificationError IssuerKeyIdProhibitedInV6Signature
            Right warn -> Right () -- We don't have a warning type for this yet
    rejectV6UnhashedIssuer _ = Right ()
    verifiableSignatureVerificationInputs
        :: VerifiableSignatureV
        -> ( SigType
           , [SigSubPacket]
           , [SigSubPacket]
           , SomePKPayload
             -> SigSubPacketPayload
             -> Either VerificationError Bool
           , [SigSubPacket] -> Either VerificationError ()
           )
    verifiableSignatureVerificationInputs
        (VerifiableSignatureV4 (SigPayloadV4Data st _ _ hs us _ _)) =
            (st, hs, us, checkV4Subpacket, const (Right ()))
    verifiableSignatureVerificationInputs
        (VerifiableSignatureV6 (SigPayloadV6Data st _ _ _ hs us _ _)) =
            (st, hs, us, checkV6Subpacket, mapM_ rejectV6UnhashedIssuer)
verifySigWith _ _ _ _ _ =
    verificationError NonSignaturePacket

verifyWithSubpacketChecks
    :: VerificationPolicy
    -> ( Pkt
         -> Maybe UTCTime
         -> ByteString
         -> Either VerificationError Verification
       )
    -> Pkt
    -> PktStreamContext
    -> Maybe UTCTime
    -> SigType
    -> [SigSubPacket]
    -> ( SomePKPayload
         -> SigSubPacketPayload
         -> Either VerificationError Bool
       )
    -> Either VerificationError Verification
verifyWithSubpacketChecks policy vf sig state mt sigType hashedSubpackets checkSubpacket = do
    mapM_
        (rejectUnsupportedCriticalSubpacket policy sigType)
        hashedSubpackets
    v <- vf sig mt (payloadForSig sigType state)
    mapM_
        (checkSubpacket (v ^. verificationSigner) . _sspPayload)
        hashedSubpackets
    warnings <-
        if sigType == SubkeyBindingSig
            then verifySubkeyBackSignatures policy state mt hashedSubpackets
            else Right []
    isSignatureExpired sig mt
        *> pure
            ( v
                { _verificationWarnings =
                    _verificationWarnings v ++ warnings
                }
            )

{- | Verify embedded primary-key back-signatures (PrimaryKeyBindingSig, 0x19)
found in the hashed subpackets of a SubkeyBindingSig.

Per RFC 9580 §5.2.3.3, a signing-capable subkey MUST include an embedded
PrimaryKeyBindingSig (0x19) made by the subkey.  This requirement is
enforced strictly for v6 subkeys.  For v4 subkeys we still verify any
embedded back-sigs that are present, but do not reject a missing one —
real-world v4 signing subkeys predate the strict cross-certification
mandate and widespread interoperability requires accepting them.
-}
verifySubkeyBackSignatures
    :: VerificationPolicy
    -> PktStreamContext
    -> Maybe UTCTime
    -> [SigSubPacket]
    -> Either VerificationError [VerificationWarning]
verifySubkeyBackSignatures policy state mt hashedSubpackets = do
    subkeyPKP <-
        maybe
            (verificationError NonSignaturePacket)
            Right
            (subkeyPKPFromPkt (lastSubkey state))
    let embeddedSigs =
            [ sp
            | SigSubPacket _ (EmbeddedSignature sp) <- hashedSubpackets
            ]
        isSigningCapable =
            any
                ( \(SigSubPacket _ payload) ->
                    case payload of
                        KeyFlags flags -> SignDataKey `Set.member` flags
                        _ -> False
                )
                hashedSubpackets
        isV6Subkey = _keyVersion subkeyPKP == V6
    case embeddedSigs of
        [] ->
            -- Require back-sig only for v6 signing subkeys (RFC 9580 §5.2.3.3).
            if isSigningCapable && isV6Subkey
                then case applyVerificationPolicy
                    (vpMissingSubkeyBackSignature policy)
                    "Missing subkey back-signature (v6 signing subkey)" of
                    Left err ->
                        verificationError (SignaturePolicyHashUnsupported DeprecatedMD5) -- We'll need a better error type
                    Right warn -> Right [MissingSubkeyBackSignatureWarning]
                else Right []
        _ ->
            -- Always verify back-sigs that are present, regardless of key version.
            mapM_ (verifyOneBackSig policy subkeyPKP) embeddedSigs
                *> Right []
  where
    verifyOneBackSig vp subkeyPKP embSigPayload = do
        let embSigPkt = SignaturePkt embSigPayload
            backSigContext =
                emptyPSC
                    { lastPrimaryKey = lastPrimaryKey state
                    , lastSubkey = lastSubkey state
                    }
        case verifyAgainstKeyWithPolicy
            vp
            subkeyPKP
            embSigPkt
            mt
            (payloadForSig PrimaryKeyBindingSig backSigContext) of
            Left err -> verificationError (InvalidSubkeyBackSignature err)
            Right _ -> Right ()

rejectUnsupportedCriticalSubpacket
    :: VerificationPolicy
    -> SigType
    -> SigSubPacket
    -> Either VerificationError ()
rejectUnsupportedCriticalSubpacket policy sigType (SigSubPacket isCritical payload)
    | not isCritical = Right ()
    | not (isBindingSignatureType sigType) = Right ()
    | otherwise =
        case payload of
            UserDefinedSigSub {} ->
                case applyVerificationPolicy
                    (vpUnsupportedCriticalSubpacket policy)
                    ( "Unsupported critical subpacket in "
                        ++ show sigType
                        ++ " signature"
                    ) of
                    Left err -> verificationError (UnsupportedCriticalSubpacket sigType)
                    Right warn -> Right () -- We don't have a warning type for this yet
            OtherSigSub {} ->
                case applyVerificationPolicy
                    (vpUnsupportedCriticalSubpacket policy)
                    ( "Unsupported critical subpacket in "
                        ++ show sigType
                        ++ " signature"
                    ) of
                    Left err -> verificationError (UnsupportedCriticalSubpacket sigType)
                    Right warn -> Right ()
            _ -> Right ()

isBindingSignatureType :: SigType -> Bool
isBindingSignatureType SubkeyBindingSig = True
isBindingSignatureType PrimaryKeyBindingSig = True
isBindingSignatureType _ = False

checkIssuerSubpacket
    :: Either String EightOctetKeyId
    -> SigSubPacketPayload
    -> Either VerificationError Bool
checkIssuerSubpacket (Right signer) (Issuer i)
    | signer == i = Right True
    | otherwise = verificationError IssuerSubpacketMismatch
checkIssuerSubpacket (Left err) (Issuer _) =
    verificationError (IssuerSubpacketUncheckable err)
checkIssuerSubpacket _ _ = Right True

checkIssuerFingerprintSubpacket
    :: IssuerFingerprintVersion
    -> Fingerprint
    -> SigSubPacketPayload
    -> Either VerificationError Bool
checkIssuerFingerprintSubpacket expectedVersion signer (IssuerFingerprint kv i)
    | kv /= expectedVersion =
        verificationError IssuerFingerprintSubpacketMismatch
    | signer == i = Right True
    | otherwise =
        verificationError IssuerFingerprintSubpacketMismatch
checkIssuerFingerprintSubpacket _ _ _ = Right True

verifyTKWith
    :: ( Pkt
         -> PktStreamContext
         -> Maybe UTCTime
         -> Either VerificationError Verification
       )
    -> Maybe UTCTime
    -> TK k
    -> Either VerificationError (TK k)
verifyTKWith vsf mt tk = do
    verifiedUnknown <- verifyUnknownTKWith vsf mt (tkToUnknown tk)
    let typedSubkeys =
            Map.fromList [(keyPktToPkt kp, kp) | (kp, _) <- tk ^. tkSubs]
        verifiedTypedSubkeys =
            mapMaybe
                ( \(pkt, sigs) -> (\kp -> (kp, sigs)) <$> Map.lookup pkt typedSubkeys
                )
                (verifiedUnknown ^. tkuSubs)
    pure
        TK
            { _tkPrimaryKey = tk ^. tkPrimaryKey
            , _tkRevs = verifiedUnknown ^. tkuRevs
            , _tkUIDs = verifiedUnknown ^. tkuUIDs
            , _tkUAts = verifiedUnknown ^. tkuUAts
            , _tkSubs = verifiedTypedSubkeys
            }

verifyUnknownTKWith
    :: ( Pkt
         -> PktStreamContext
         -> Maybe UTCTime
         -> Either VerificationError Verification
       )
    -> Maybe UTCTime
    -> TKUnknown
    -> Either VerificationError TKUnknown
verifyUnknownTKWith vsf mt tk = do
    revokers <- checkRevokers tk
    revs <- checkKeyRevocations revokers tk
    let uids = filter (not . null . snd) . checkUidSigs $ tk ^. tkuUIDs
    let uats = filter (not . null . snd) . checkUAtSigs $ tk ^. tkuUAts
    let subs = concatMap checkSub $ tk ^. tkuSubs
    return (TKUnknown (tk ^. tkuKey) revs uids uats subs)
  where
    checkRevokers =
        Right
            . concat
            . rights
            . map verifyRevoker
            . filter isRevokerP
            . _tkuRevs
    checkKeyRevocations
        :: [(PubKeyAlgorithm, Fingerprint)]
        -> TKUnknown
        -> Either VerificationError [SignaturePayload]
    checkKeyRevocations rs k =
        Prelude.sequence
            . concatMap (filterRevs rs)
            . rights
            . map (liftM2 fmap (,) vSig)
            $ k
                ^. tkuRevs
    checkUidSigs
        :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])]
    checkUidSigs =
        map
            ( \(uid, sps) ->
                let verified = rights . map (\sp -> fmap ((,) sp) (vUid (uid, sp))) $ sps
                 in (uid, retainNonRevokedCertifications mt verified)
            )
    checkUAtSigs
        :: [([UserAttrSubPacket], [SignaturePayload])]
        -> [([UserAttrSubPacket], [SignaturePayload])]
    checkUAtSigs =
        map
            ( \(uat, sps) ->
                let verified = rights . map (\sp -> fmap ((,) sp) (vUAt (uat, sp))) $ sps
                 in (uat, retainNonRevokedCertifications mt verified)
            )
    checkSub
        :: (Pkt, [SignaturePayload]) -> [(Pkt, [SignaturePayload])]
    checkSub (pkt, sps) =
        if revokedSub pkt sps
            then []
            else checkSub' pkt sps
    revokedSub :: Pkt -> [SignaturePayload] -> Bool
    revokedSub _ [] = False
    revokedSub p sigs =
        any (vSubSig p) (filter subkeyRevocationEffective sigs)
    checkSub'
        :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])]
    checkSub' p sps =
        let goodsigs =
                filter (vSubSig p)
                    . filter signatureKnown
                    . filter isSubkeyBindingSig
                    $ sps
         in if null goodsigs
                then []
                else [(p, goodsigs)]
    getHasheds = signatureHashedSubpackets
    filterRevs
        :: [(PubKeyAlgorithm, Fingerprint)]
        -> (SignaturePayload, Verification)
        -> [Either VerificationError SignaturePayload]
    filterRevs vokers spv =
        case spv of
            (s, _)
                | isV4OrV6Sig s && sigType s == Just SignatureDirectlyOnAKey ->
                    [Right s | signatureKnown s]
            (s, v)
                | isV4OrV6Sig s
                , sigType s == Just KeyRevocationSig
                , Just pka <- sigPKA s ->
                    if (v ^. verificationSigner == tk ^. tkuKey . _1)
                        || any
                            ( \(p, f) ->
                                p == pka && f == fingerprint (v ^. verificationSigner)
                            )
                            vokers
                        then
                            if keyRevocationEffective s
                                then [verificationError KeyRevoked]
                                else [Right s | signatureKnown s]
                        else [Right s | signatureKnown s]
            _ -> []
    isV4OrV6Sig = isVerifiableSignaturePayload
    vUid
        :: (Text, SignaturePayload) -> Either VerificationError Verification
    vUid (uid, sp) =
        vsf
            (SignaturePkt sp)
            emptyPSC
                { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)
                , lastUIDorUAt = UserIdPkt uid
                }
            Nothing
    vUAt
        :: ([UserAttrSubPacket], SignaturePayload)
        -> Either VerificationError Verification
    vUAt (uat, sp) =
        vsf
            (SignaturePkt sp)
            emptyPSC
                { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)
                , lastUIDorUAt = UserAttributePkt uat
                }
            Nothing
    vSig :: SignaturePayload -> Either VerificationError Verification
    vSig sp =
        vsf
            (SignaturePkt sp)
            emptyPSC {lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)}
            Nothing
    vSubSig :: Pkt -> SignaturePayload -> Bool
    vSubSig sk sp =
        isRight
            ( vsf
                (SignaturePkt sp)
                emptyPSC
                    { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)
                    , lastSubkey = sk
                    }
                mt
            )
    verifyRevoker
        :: SignaturePayload
        -> Either VerificationError [(PubKeyAlgorithm, Fingerprint)]
    verifyRevoker sp =
        vSig sp
            *> pure
                ( map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp))
                    . filter isRevocationKeySSP
                    $ getHasheds sp
                )
    retainNonRevokedCertifications
        :: Maybe UTCTime
        -> [(SignaturePayload, Verification)]
        -> [SignaturePayload]
    retainNonRevokedCertifications validationTime verified =
        map fst $
            filter
                ( (== CertificationActive)
                    . certificationStateAt validationTime verified
                )
                certifications
      where
        certifications = filter (not . isCertRevocationSig . fst) verified
    signatureKnown = signatureKnownAt mt
    subkeyRevocationEffective sp = isSubkeyRevocation sp && signatureEffectiveAt mt sp
    keyRevocationEffective sp
        | isHistoricalKeyRevocation sp = signatureEffectiveAt mt sp
        | otherwise = signatureUnexpiredAt mt sp

verifyAgainstKeyring
    :: PublicKeyring
    -> Pkt
    -> Maybe UTCTime
    -> ByteString
    -> Either VerificationError Verification
verifyAgainstKeyring kr sig mt payload = do
    let allKeys = map tkToUnknown (IxSet.toList kr)
        signerValidationTime = signatureCreationTimeFromPacket sig
        ikeys = (kr @=) <$> issuer sig
        ifpkeys = (kr @=) <$> issuerFP sig
        hintedKeys = maybe [] (map tkToUnknown . IxSet.toList) (ifpkeys <|> ikeys)
        hintedResult =
            if null hintedKeys
                then Left MissingIssuer
                else
                    verifyFromCandidates
                        allKeys
                        hintedKeys
                        sig
                        signerValidationTime
                        mt
                        payload
     in case hintedResult of
            Right v -> Right v
            Left hintedErr ->
                let fallbackResult =
                        verifyFromCandidates
                            allKeys
                            allKeys
                            sig
                            signerValidationTime
                            mt
                            payload
                 in if null hintedKeys
                        then case fallbackResult of
                            Right v -> Right v
                            Left _ ->
                                verificationError
                                    (SigningKeyNotFound (issuer sig) (issuerFP sig))
                        else case fallbackResult of
                            Right v -> Right v
                            Left _ -> Left hintedErr

verifyFromCandidates
    :: [TKUnknown]
    -> [TKUnknown]
    -> Pkt
    -> Maybe UTCTime
    -> Maybe UTCTime
    -> ByteString
    -> Either VerificationError Verification
verifyFromCandidates allKeys candidateTks sig signerValidationTime verificationTime payload =
    let candidateResults =
            map
                ( resolveCandidateSignerPKPs
                    allKeys
                    sig
                    signerValidationTime
                    (const True)
                )
                candidateTks
        candidateErrors = concatMap fst candidateResults
        usablePkps = concatMap snd candidateResults
     in if null usablePkps
            then
                if null candidateErrors
                    then
                        verificationError
                            (SigningKeyNotFound (issuer sig) (issuerFP sig))
                    else verificationError (CandidateKeyFailures candidateErrors)
            else case verifyAgainstPKPs usablePkps sig verificationTime payload of
                Left (CandidateKeyFailures errs)
                    | not (null candidateErrors) ->
                        verificationError
                            (CandidateKeyFailures (candidateErrors ++ errs))
                other -> other

verifyAgainstKeys
    :: [TKUnknown]
    -> Pkt
    -> Maybe UTCTime
    -> ByteString
    -> Either VerificationError Verification
verifyAgainstKeys ks sig mt payload =
    verifyAgainstKeysWithPolicy
        defaultVerificationPolicy
        ks
        sig
        mt
        payload

-- | Verify a signature against a list of keys with a custom verification policy.
verifyAgainstKeysWithPolicy
    :: VerificationPolicy
    -> [TKUnknown]
    -> Pkt
    -> Maybe UTCTime
    -> ByteString
    -> Either VerificationError Verification
verifyAgainstKeysWithPolicy policy ks sig mt payload = do
    let allpkps =
            filter
                ( \x ->
                    (((fingerprint x ==) <$> issuerFP sig) == Just True)
                        || ((==) <$> issuer sig <*> hush (eightOctetKeyID x))
                            == Just True
                )
                ( concatMap
                    ( \x ->
                        (x ^. tkuKey . _1)
                            : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x)
                    )
                    ks
                )
        allCandidatePkps =
            concatMap
                ( \x ->
                    (x ^. tkuKey . _1)
                        : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x)
                )
                ks
        normalizedCandidates
            | null allpkps = allCandidatePkps
            | otherwise = allpkps
    verifyAgainstPKPsWithPolicy
        policy
        normalizedCandidates
        sig
        mt
        payload

verifyAgainstPKPs
    :: [SomePKPayload]
    -> Pkt
    -> Maybe UTCTime
    -> ByteString
    -> Either VerificationError Verification
verifyAgainstPKPs pkps sig mt payload =
    verifyAgainstPKPsWithPolicy
        defaultVerificationPolicy
        pkps
        sig
        mt
        payload

-- | Verify a signature against a list of public key payloads with a custom verification policy.
verifyAgainstPKPsWithPolicy
    :: VerificationPolicy
    -> [SomePKPayload]
    -> Pkt
    -> Maybe UTCTime
    -> ByteString
    -> Either VerificationError Verification
verifyAgainstPKPsWithPolicy policy pkps sig mt payload =
    case rights results of
        [] -> verificationError (CandidateKeyFailures (lefts results))
        [r] -> isSignatureExpired sig mt *> pure r
        rs -> verificationError (MultipleVerificationSuccesses (length rs))
  where
    results =
        map
            (\pkp -> verifyAgainstKeyWithPolicy policy pkp sig mt payload)
            pkps

resolveCandidateSignerPKPs
    :: [TKUnknown]
    -> Pkt
    -> Maybe UTCTime
    -> (SomePKPayload -> Bool)
    -> TKUnknown
    -> ([VerificationError], [SomePKPayload])
resolveCandidateSignerPKPs _ _ Nothing matchesP tk =
    ([], filter matchesP (candidatePKPs tk))
resolveCandidateSignerPKPs allKeys _ (Just validationTime) matchesP tk =
    let rawMatches = filter matchesP (candidatePKPs tk)
     in case verifyUnknownTKWith
            ( verifySigWith
                defaultVerificationPolicy
                (verifyAgainstKeys allKeys)
            )
            (Just validationTime)
            tk of
            Left err -> (replicate (length rawMatches) err, [])
            Right verifiedTK ->
                let verifiedMatches =
                        map
                            ( \pkp ->
                                case historicallyValidSigner
                                    validationTime
                                    (timelineValidationTK pkp verifiedTK)
                                    pkp of
                                    Right () -> Right pkp
                                    Left err -> Left err
                            )
                            rawMatches
                 in (lefts verifiedMatches, rights verifiedMatches)
  where
    timelineValidationTK pkp verifiedTK'
        | fingerprint pkp == fingerprint (tk ^. tkuKey . _1) = tk
        | otherwise = verifiedTK'

candidatePKPs :: TKUnknown -> [SomePKPayload]
candidatePKPs tk =
    (tk ^. tkuKey . _1)
        : mapMaybe (subkeyPKPFromPkt . fst) (tk ^. tkuSubs)

historicallyValidSigner
    :: UTCTime
    -> TKUnknown
    -> SomePKPayload
    -> Either VerificationError ()
historicallyValidSigner validationTime tk pkp
    | fingerprint pkp == fingerprint (tk ^. tkuKey . _1) =
        if keyStateValid (keyStateAt validationTime tk)
            then Right ()
            else verificationError SigningKeyUnavailableAtSignatureTime
    | otherwise =
        case find
            ( \(pkt, _) ->
                maybe
                    False
                    ((== fingerprint pkp) . fingerprint)
                    (subkeyPKPFromPkt pkt)
            )
            (tk ^. tkuSubs) of
            Nothing -> verificationError SigningKeyUnavailableAtSignatureTime
            Just (subPkt, sigs) ->
                case subkeyPKPFromPkt subPkt of
                    Nothing -> verificationError SigningKeyUnavailableAtSignatureTime
                    Just subPKP ->
                        if isPKTimeValidWithSelfSignatures validationTime subPKP sigs
                            then Right ()
                            else verificationError SigningKeyUnavailableAtSignatureTime

signatureCreationTimeFromPacket :: Pkt -> Maybe UTCTime
signatureCreationTimeFromPacket (SignaturePkt sigPayload) = signatureCreationTime sigPayload
signatureCreationTimeFromPacket _ = Nothing

signatureCreationTime :: SignaturePayload -> Maybe UTCTime
signatureCreationTime =
    fmap
        (posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp)
        . sigCT

signatureKnownAt :: Maybe UTCTime -> SignaturePayload -> Bool
signatureKnownAt Nothing _ = True
signatureKnownAt (Just validationTime) sigPayload =
    maybe
        False
        (<= validationTime)
        (signatureCreationTime sigPayload)

signatureEffectiveAt :: Maybe UTCTime -> SignaturePayload -> Bool
signatureEffectiveAt Nothing _ = True
signatureEffectiveAt (Just validationTime) sigPayload =
    signatureKnownAt (Just validationTime) sigPayload
        && maybe
            True
            (validationTime <)
            (signatureExpirationTime sigPayload)

signatureUnexpiredAt :: Maybe UTCTime -> SignaturePayload -> Bool
signatureUnexpiredAt Nothing _ = True
signatureUnexpiredAt (Just validationTime) sigPayload =
    maybe
        True
        (validationTime <)
        (signatureExpirationTime sigPayload)

signatureExpirationTime :: SignaturePayload -> Maybe UTCTime
signatureExpirationTime sigPayload =
    addDurationToTime
        <$> signatureCreationTime sigPayload
        <*> signatureExpirationDuration sigPayload

signatureExpirationDuration
    :: SignaturePayload -> Maybe ThirtyTwoBitDuration
signatureExpirationDuration sigPayload =
    signatureHashedSubpacketsKnown sigPayload
        >>= firstSignatureExpirationDuration

firstSignatureExpirationDuration
    :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration
firstSignatureExpirationDuration =
    foldr
        ( \subpacket acc ->
            case subpacket of
                SigSubPacket _ (SigExpirationTime duration) -> Just duration
                _ -> acc
        )
        Nothing

addDurationToTime :: UTCTime -> ThirtyTwoBitDuration -> UTCTime
addDurationToTime baseTime duration =
    addUTCTime
        (fromIntegral (unThirtyTwoBitDuration duration))
        baseTime

certificationStateAt
    :: Maybe UTCTime
    -> [(SignaturePayload, Verification)]
    -> (SignaturePayload, Verification)
    -> CertificationState
certificationStateAt validationTime verified certification@(certificationSig, _)
    | not (signatureKnownAt validationTime certificationSig) =
        CertificationNotYetKnown
    | not (signatureEffectiveAt validationTime certificationSig) =
        CertificationRevoked
    | any (`revokesCertification` certification) visibleRevocations =
        CertificationRevoked
    | otherwise = CertificationActive
  where
    visibleRevocations =
        filter
            (signatureEffectiveAt validationTime . fst)
            (filter (isCertRevocationSig . fst) verified)

revokesCertification
    :: (SignaturePayload, Verification)
    -> (SignaturePayload, Verification)
    -> Bool
revokesCertification (revocationSig, revocationVerification) (certificationSig, certificationVerification) =
    sameSigner
        && certificationPrecedesRevocation certificationSig revocationSig
  where
    sameSigner =
        fingerprint (revocationVerification ^. verificationSigner)
            == fingerprint (certificationVerification ^. verificationSigner)

certificationPrecedesRevocation
    :: SignaturePayload -> SignaturePayload -> Bool
certificationPrecedesRevocation certificationSig revocationSig =
    case ( signatureCreationTime certificationSig
         , signatureCreationTime revocationSig
         ) of
        (Just certificationTime, Just revocationTime) ->
            certificationTime < revocationTime
        _ -> False

isHistoricalKeyRevocation :: SignaturePayload -> Bool
isHistoricalKeyRevocation sigPayload =
    case revocationReasonCode sigPayload of
        Just KeySuperseded -> True
        Just KeyRetiredAndNoLongerUsed -> True
        Just UserIdInfoNoLongerValid -> True
        _ -> False

revocationReasonCode :: SignaturePayload -> Maybe RevocationCode
revocationReasonCode sigPayload =
    ( \(SigSubPacket _ (ReasonForRevocation reasonCode _)) -> reasonCode
    )
        <$> find isReasonForRevocation (signatureSubpackets sigPayload)
  where
    isReasonForRevocation (SigSubPacket _ ReasonForRevocation {}) = True
    isReasonForRevocation _ = False

signatureSubpackets :: SignaturePayload -> [SigSubPacket]
signatureSubpackets sigPayload =
    case signatureSubpacketListsKnown sigPayload of
        Just (hashed, unhashed) -> hashed ++ unhashed
        Nothing -> []

signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]
signatureHashedSubpackets sigPayload =
    maybe [] id (signatureHashedSubpacketsKnown sigPayload)

subkeyPKPFromPkt :: Pkt -> Maybe SomePKPayload
subkeyPKPFromPkt (PublicSubkeyPkt p) = Just p
subkeyPKPFromPkt (SecretSubkeyPkt p _) = Just p
subkeyPKPFromPkt _ = Nothing

verifyAgainstKey'
    :: SomePKPayload
    -> Pkt
    -> Maybe UTCTime
    -> ByteString
    -> Either VerificationError Verification
verifyAgainstKey' pkp sig mt payload =
    verifyAgainstKeyWithPolicy
        defaultVerificationPolicy
        pkp
        sig
        mt
        payload

{- | Verify a signature against a key with a custom verification policy.
This allows callers to control whether certain signature features
(deprecated hash algorithms, PKA mismatches, etc.) are treated as
hard errors or warnings.
-}
verifyAgainstKeyWithPolicy
    :: VerificationPolicy
    -> SomePKPayload
    -> Pkt
    -> Maybe UTCTime
    -> ByteString
    -> Either VerificationError Verification
verifyAgainstKeyWithPolicy policy pkp sig mt payload = do
    sigClass <-
        either
            (verificationError . const NonSignaturePacket)
            Right
            (fromPktEitherSomeSignatureV sig)
    let sigPayload =
            case sigClass of
                SomeSignatureV typedSig -> signaturePayloadFromSignatureV typedSig
    sigHash <-
        maybe
            (verificationError MissingHashAlgorithm)
            Right
            (sigHA sigPayload)
    sigDetails <- signaturePKAAndMPIsFromClass sigClass
    warnings <- enforcePKACompatibility policy sigPayload
    hashWarnings <- enforceSignatureHashPolicy policy sigHash
    _ <- isSignatureExpired sig mt
    let signedPayload = BL.toStrict (finalPayload sig payload)
    enforceLeft16Prefix sigClass sigHash signedPayload
    ( \verifiedSigner ->
            Verification verifiedSigner sigPayload (warnings ++ hashWarnings)
        )
        <$> verify' sigDetails pkp sigHash signedPayload
  where
    enforcePKACompatibility vp sigPayload =
        let sigPka = maybe (OtherPKA 0) id (sigPKA sigPayload)
            keyPka = _pkalgo pkp
         in if pkaCompatible sigPka keyPka
                then Right []
                else case applyVerificationPolicy
                    (vpPkaMismatch vp)
                    ( "PKA mismatch: signature uses "
                        ++ show sigPka
                        ++ " but key uses "
                        ++ show keyPka
                    ) of
                    Left err -> verificationError (SignaturePolicyPKAMismatch sigPka keyPka)
                    Right warn -> Right [PkaMismatchWarning sigPka keyPka]
    enforceSignatureHashPolicy vp sigHash =
        case sigHash of
            OtherHA {} ->
                case applyVerificationPolicy
                    (vpUnsupportedHashAlgorithm vp)
                    ("Unsupported hash algorithm: " ++ show sigHash) of
                    Left err -> verificationError (SignaturePolicyHashUnsupported sigHash)
                    Right warn -> Right [UnsupportedHashAlgorithmWarning sigHash]
            DeprecatedMD5 ->
                case applyVerificationPolicy
                    (vpDeprecatedHashAlgorithm vp)
                    ("Deprecated hash algorithm: MD5") of
                    Left err -> verificationError (SignaturePolicyHashUnsupported sigHash)
                    Right warn -> Right [DeprecatedHashAlgorithmWarning sigHash]
            SHA1 ->
                case applyVerificationPolicy
                    (vpDeprecatedHashAlgorithm vp)
                    ("Deprecated hash algorithm: SHA1") of
                    Left err -> verificationError (SignaturePolicyHashUnsupported sigHash)
                    Right warn -> Right [DeprecatedHashAlgorithmWarning sigHash]
            RIPEMD160 ->
                case applyVerificationPolicy
                    (vpDeprecatedHashAlgorithm vp)
                    ("Deprecated hash algorithm: RIPEMD160") of
                    Left err -> verificationError (SignaturePolicyHashUnsupported sigHash)
                    Right warn -> Right [DeprecatedHashAlgorithmWarning sigHash]
            _ -> Right []
    enforceLeft16Prefix sigClass sigHash signedPayload = do
        expectedLeft16 <-
            either
                (verificationError . HashComputationFailed)
                Right
                (left16FromSignedPayload sigHash signedPayload)
        actualLeft16 <- signatureLeft16FromClass sigClass
        if actualLeft16 == expectedLeft16
            then Right ()
            else
                verificationError
                    (SignatureMismatch (_pkalgo pkp) (fingerprint pkp))
    pkaCompatible RSA keyPka =
        keyPka
            `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly]
    pkaCompatible DeprecatedRSASignOnly keyPka =
        keyPka `elem` [RSA, DeprecatedRSASignOnly]
    pkaCompatible PKA.EdDSA keyPka =
        keyPka `elem` [PKA.EdDSA, PKA.Ed25519, PKA.Ed448]
    pkaCompatible PKA.Ed25519 keyPka =
        keyPka `elem` [PKA.EdDSA, PKA.Ed25519]
    pkaCompatible PKA.Ed448 keyPka =
        keyPka `elem` [PKA.EdDSA, PKA.Ed448]
    pkaCompatible sigPka keyPka = sigPka == keyPka
    verify' details pub@(PKPayload V4 _ _ _ pkey) ha pl =
        verifyByHash details pub pkey ha pl
    verify' details pub@(PKPayload V6 _ _ _ pkey) ha pl =
        verifyByHash details pub pkey ha pl
    verify' _ _ _ _ =
        verificationError UnexpectedKeyVersion
    verifyByHash details pub pkey ha pl =
        case ha of
            SHA1 -> verify'' details CHA.SHA1 pub pkey pl
            RIPEMD160 -> verify'' details CHA.RIPEMD160 pub pkey pl
            SHA224 -> verify'' details CHA.SHA224 pub pkey pl
            SHA256 -> verify'' details CHA.SHA256 pub pkey pl
            SHA384 -> verify'' details CHA.SHA384 pub pkey pl
            SHA512 -> verify'' details CHA.SHA512 pub pkey pl
            SHA3_256 -> verifyNoRSA SHA3_256 details CHA.SHA3_256 pub pkey pl
            SHA3_512 -> verifyNoRSA SHA3_512 details CHA.SHA3_512 pub pkey pl
            DeprecatedMD5 -> verify'' details CHA.MD5 pub pkey pl
            _ ->
                verificationError (SignaturePolicyHashUnsupported ha)
    verify'' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs =
        dsaVerify pub mpis hd pkey bs
    verify'' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs =
        ecdsaVerify pub mpis hd pkey bs
    verify'' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve25519 pkey) bs
        | sigPka `elem` [EdDSA, PKA.Ed25519] =
            ed25519Verify sigPka pub mpis hd pkey bs
    verify'' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve448 pkey) bs
        | sigPka `elem` [EdDSA, PKA.Ed448] =
            ed448Verify sigPka pub mpis hd pkey bs
    verify'' (RSA, mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs =
        rsaVerify pub mpis hd pkey bs
    verify'' (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka)
    verifyNoRSA ha' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs =
        dsaVerify pub mpis hd pkey bs
    verifyNoRSA ha' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs =
        ecdsaVerify pub mpis hd pkey bs
    verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve25519 pkey) bs
        | sigPka `elem` [EdDSA, PKA.Ed25519] =
            ed25519Verify sigPka pub mpis hd pkey bs
    verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve448 pkey) bs
        | sigPka `elem` [EdDSA, PKA.Ed448] =
            ed448Verify sigPka pub mpis hd pkey bs
    verifyNoRSA ha' (RSA, _) _ _ _ _ =
        verificationError (SignatureHashUnsupportedByAlgorithm ha' RSA)
    verifyNoRSA _ (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka)
    dsaVerify pub (r :| [s]) hd pkey bs =
        if DSA.verify hd pkey (dsaMPIsToSig r s) bs
            then Right pub
            else verificationError (SignatureMismatch DSA (fingerprint pub))
    dsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch DSA)
    ecdsaVerify pub (r :| [s]) hd pkey bs =
        if ECDSA.verify hd pkey (ecdsaMPIsToSig r s) bs
            then Right pub
            else
                verificationError (SignatureMismatch ECDSA (fingerprint pub))
    ecdsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch ECDSA)
    ed25519Verify sigPka pub (r :| [s]) hd pkey bs =
        case edPointToRawPublic 32 pkey of
            Left err ->
                verificationError (SignatureEncodingInvalid sigPka err)
            Right rawPub ->
                case cf2es (Ed25519.publicKey rawPub) of
                    Left err ->
                        verificationError (SignatureEncodingInvalid sigPka err)
                    Right ep ->
                        case cf2es
                            ( Ed25519.signature
                                (pad32 (i2osp (unMPI r)) <> pad32 (i2osp (unMPI s)))
                            ) of
                            Left err ->
                                verificationError (SignatureEncodingInvalid sigPka err)
                            Right es ->
                                let prehash = crazyHash hd bs :: B.ByteString
                                 in if Ed25519.verify ep prehash es
                                        then Right pub
                                        else
                                            verificationError (SignatureMismatch sigPka (fingerprint pub))
    ed25519Verify sigPka _ _ _ _ _ =
        verificationError (SignatureShapeMismatch sigPka)
    ed448Verify sigPka pub (r :| [s]) hd pkey bs =
        case edPointToRawPublic 57 pkey of
            Left err ->
                verificationError (SignatureEncodingInvalid sigPka err)
            Right rawPub ->
                case cf2es (Ed448.publicKey rawPub) of
                    Left err ->
                        verificationError (SignatureEncodingInvalid sigPka err)
                    Right ep ->
                        case cf2es
                            ( Ed448.signature
                                (padN 57 (i2osp (unMPI r)) <> padN 57 (i2osp (unMPI s)))
                            ) of
                            Left err ->
                                verificationError (SignatureEncodingInvalid sigPka err)
                            Right es ->
                                let prehash = crazyHash hd bs :: B.ByteString
                                 in if Ed448.verify ep prehash es
                                        then Right pub
                                        else
                                            verificationError (SignatureMismatch sigPka (fingerprint pub))
    ed448Verify sigPka _ _ _ _ _ =
        verificationError (SignatureShapeMismatch sigPka)
    edPointToRawPublic expectedLen (NativeEPoint (EPoint x)) =
        exactLengthPublic expectedLen "native" (i2osp x)
    edPointToRawPublic expectedLen (PrefixedNativeEPoint (EPoint x)) = do
        prefixed <-
            exactLengthPublic (expectedLen + 1) "prefixed-native" (i2osp x)
        if B.head prefixed /= 0x40
            then
                Left
                    "prefixed-native EdDSA public key is missing the 0x40 prefix"
            else Right (B.tail prefixed)
    exactLengthPublic expectedLen label bs
        | B.length bs == expectedLen = Right bs
        | otherwise =
            Left
                ( "invalid "
                    ++ label
                    ++ " EdDSA public key length: expected "
                    ++ show expectedLen
                    ++ " octets, got "
                    ++ show (B.length bs)
                )
    pad32 bs =
        let l = B.length bs
         in if l >= 32
                then bs
                else B.replicate (32 - l) 0 <> bs
    padN n bs =
        let l = B.length bs
         in if l >= n
                then bs
                else B.replicate (n - l) 0 <> bs
    cf2es = either (Left . show) return . eitherCryptoError
    rsaVerify pub mpis hd pkey bs =
        if P15.verify (Just hd) pkey bs (rsaMPItoSig pkey mpis)
            then Right pub
            else verificationError (SignatureMismatch RSA (fingerprint pub))
    dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s)
    ecdsaMPIsToSig r s = ECDSA.Signature (unMPI r) (unMPI s)
    rsaMPItoSig pkey (s :| []) =
        let sz = RSATypes.public_size pkey
            raw = i2osp (unMPI s)
            pad = sz - B.length raw
         in B.replicate pad 0 <> raw
    crazyHash h = BA.convert . hashWith h

isSignatureExpired
    :: Pkt -> Maybe UTCTime -> Either VerificationError Bool
isSignatureExpired _ Nothing = return False
isSignatureExpired s (Just t) =
    do
        sigClass <-
            either
                (verificationError . const NonSignaturePacket)
                Right
                (fromPktEitherSomeSignatureV s)
        if any
            (expiredBefore t)
            ( signatureHashedSubpackets
                ( case sigClass of
                    SomeSignatureV typedSig -> signaturePayloadFromSignatureV typedSig
                )
            )
            then verificationError SignatureExpired
            else return True
  where
    expiredBefore :: UTCTime -> SigSubPacket -> Bool
    expiredBefore ct (SigSubPacket _ (SigExpirationTime et)) =
        fromEnum
            ((posixSecondsToUTCTime . toEnum . fromEnum) et `diffUTCTime` ct)
            < 0
    expiredBefore _ _ = False

finalPayload :: Pkt -> ByteString -> ByteString
finalPayload s pl = BL.concat [pl, sigbit, trailer s]
  where
    sigbit = runPut $ putPartialSigforSigning s
    trailer :: Pkt -> ByteString
    trailer (SignaturePkt sigPayload) =
        maybe
            BL.empty
            (const (runPut $ putSigTrailer s))
            (fromSignaturePayloadVerifiableSignatureV sigPayload)
    trailer _ = BL.empty

normalizePayloadForSigType :: SigType -> ByteString -> ByteString
normalizePayloadForSigType CanonicalTextSig =
    stripTrailingWhitespacePerLine . canonicalizeLineEndings
normalizePayloadForSigType _ = id

normalizePayloadForSigTypeWith
    :: TextNormalizationMode -> SigType -> ByteString -> ByteString
normalizePayloadForSigTypeWith CleartextCompat st = normalizePayloadForSigType st
normalizePayloadForSigTypeWith RFC9580Strict CanonicalTextSig = canonicalizeLineEndings
normalizePayloadForSigTypeWith RFC9580Strict _ = id

canonicalizeLineEndings :: ByteString -> ByteString
canonicalizeLineEndings = BL.pack . go . BL.unpack
  where
    go [] = []
    go (0x0d : 0x0a : rest) = 0x0d : 0x0a : go rest
    go (0x0d : rest) = 0x0d : 0x0a : go rest
    go (0x0a : rest) = 0x0d : 0x0a : go rest
    go (w : rest) = w : go rest

stripTrailingWhitespacePerLine :: ByteString -> ByteString
stripTrailingWhitespacePerLine = BL.pack . go [] . BL.unpack
  where
    go lineRev [] = reverseTrimmed lineRev
    go lineRev (0x0d : 0x0a : rest) =
        reverseTrimmed lineRev ++ [0x0d, 0x0a] ++ go [] rest
    go lineRev (w : rest) = go (w : lineRev) rest

    reverseTrimmed :: [Word8] -> [Word8]
    reverseTrimmed = reverse . dropWhile isTrailingWhitespace

    isTrailingWhitespace :: Word8 -> Bool
    isTrailingWhitespace w = w == 0x20 || w == 0x09

hashWithSHA512 :: B.ByteString -> B.ByteString
hashWithSHA512 = BA.convert . hashWith CHA.SHA512

hashForSignatureAlgorithm
    :: HashAlgorithm -> B.ByteString -> Either String B.ByteString
hashForSignatureAlgorithm ha bs =
    case ha of
        SHA1 -> Right (BA.convert (hashWith CHA.SHA1 bs))
        RIPEMD160 -> Right (BA.convert (hashWith CHA.RIPEMD160 bs))
        SHA224 -> Right (BA.convert (hashWith CHA.SHA224 bs))
        SHA256 -> Right (BA.convert (hashWith CHA.SHA256 bs))
        SHA384 -> Right (BA.convert (hashWith CHA.SHA384 bs))
        SHA512 -> Right (BA.convert (hashWith CHA.SHA512 bs))
        SHA3_256 -> Right (BA.convert (hashWith CHA.SHA3_256 bs))
        SHA3_512 -> Right (BA.convert (hashWith CHA.SHA3_512 bs))
        DeprecatedMD5 -> Right (BA.convert (hashWith CHA.MD5 bs))
        _ ->
            Left
                ("unsupported hash algorithm for left16 derivation: " ++ show ha)

left16FromHashPrefix :: B.ByteString -> Either String Word16
left16FromHashPrefix bs
    | B.length bs >= 2 = Right (fromIntegral (os2ip (B.take 2 bs)))
    | otherwise = Left "hash output too short to derive left16"

left16FromSignedPayload
    :: HashAlgorithm -> B.ByteString -> Either String Word16
left16FromSignedPayload ha signedPayload = do
    digest <- hashForSignatureAlgorithm ha signedPayload
    left16FromHashPrefix digest

left16FromSignedPayloadForSign
    :: HashAlgorithm -> B.ByteString -> Either SignError Word16
left16FromSignedPayloadForSign ha =
    first SignBackendError . left16FromSignedPayload ha

ed25519Signer
    :: Ed25519.SecretKey -> B.ByteString -> B.ByteString
ed25519Signer sk prehash =
    BA.convert (Ed25519.sign sk (Ed25519.toPublic sk) prehash)

ed448Signer :: Ed448.SecretKey -> B.ByteString -> B.ByteString
ed448Signer sk prehash =
    BA.convert (Ed448.sign sk (Ed448.toPublic sk) prehash)

rsaPKCS15Sign
    :: HashAlgorithm
    -> RSATypes.PrivateKey
    -> B.ByteString
    -> Either SignError B.ByteString
rsaPKCS15Sign ha prv bytes =
    case ha of
        SHA1 ->
            first
                (SignBackendError . show)
                (P15.sign Nothing (Just CHA.SHA1) prv bytes)
        SHA224 ->
            first
                (SignBackendError . show)
                (P15.sign Nothing (Just CHA.SHA224) prv bytes)
        SHA256 ->
            first
                (SignBackendError . show)
                (P15.sign Nothing (Just CHA.SHA256) prv bytes)
        SHA384 ->
            first
                (SignBackendError . show)
                (P15.sign Nothing (Just CHA.SHA384) prv bytes)
        SHA512 ->
            first
                (SignBackendError . show)
                (P15.sign Nothing (Just CHA.SHA512) prv bytes)
        _ ->
            Left
                ( SignBackendError
                    ( "signature hash algorithm is not supported by RSA PKCS#1 v1.5 backend: "
                        ++ show ha
                    )
                )

validateV6SaltSize
    :: HashAlgorithm -> SignatureSalt -> Either SignError ()
validateV6SaltSize ha salt =
    let saltBytes = BL.toStrict (unSignatureSalt salt)
        actualSaltLen = B.length saltBytes
     in case signatureV6SaltSizeForHashAlgorithm ha of
            Nothing ->
                Left
                    ( SignBackendError
                        ( "signature hash algorithm does not define a V6 salt size: "
                            ++ show ha
                        )
                    )
            Just expectedSaltLen ->
                if actualSaltLen == fromIntegral expectedSaltLen
                    then Right ()
                    else
                        Left (SignV6SaltSizeMismatch ha expectedSaltLen actualSaltLen)

signEdDSAV4
    :: String
    -> Int
    -> Int
    -> (B.ByteString -> B.ByteString)
    -> TextNormalizationMode
    -> SigType
    -> PubKeyAlgorithm
    -> HashAlgorithm
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> ByteString
    -> Either SignError SignaturePayload
signEdDSAV4 algoName sigLen limbLen signer mode st pka ha has uhas payload = do
    let normalizedPayload = normalizePayloadForSigTypeWith mode st payload
        sig0 = SigV4 st pka ha has [] 0 (NE.fromList [MPI 0, MPI 0])
        prehash =
            hashWithSHA512
                (BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload))
        sigBytes = signer prehash
    if B.length sigBytes /= sigLen
        then
            Left
                (SignProducedWrongLength algoName sigLen (B.length sigBytes))
        else
            let (r, s) = B.splitAt limbLen sigBytes
             in ( \left16 ->
                    SigV4
                        st
                        pka
                        ha
                        has
                        uhas
                        left16
                        (NE.fromList [MPI (os2ip r), MPI (os2ip s)])
                )
                    <$> first SignBackendError (left16FromHashPrefix prehash)

signEdDSAV6
    :: String
    -> Int
    -> Int
    -> (B.ByteString -> B.ByteString)
    -> TextNormalizationMode
    -> SigType
    -> PubKeyAlgorithm
    -> HashAlgorithm
    -> SignatureSalt
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> ByteString
    -> Either SignError SignaturePayload
signEdDSAV6 algoName sigLen limbLen signer mode st pka ha salt has uhas payload = do
    validateV6SaltSize ha salt
    let normalizedPayload = normalizePayloadForSigTypeWith mode st payload
        sig0 = SigV6 st pka ha salt has [] 0 (NE.fromList [MPI 0, MPI 0])
        prehash =
            hashWithSHA512
                (BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload))
        sigBytes = signer prehash
    if B.length sigBytes /= sigLen
        then
            Left
                (SignProducedWrongLength algoName sigLen (B.length sigBytes))
        else
            let (r, s) = B.splitAt limbLen sigBytes
             in ( \left16 ->
                    SigV6
                        st
                        pka
                        ha
                        salt
                        has
                        uhas
                        left16
                        (NE.fromList [MPI (os2ip r), MPI (os2ip s)])
                )
                    <$> first SignBackendError (left16FromHashPrefix prehash)

signUserIDwithRSA
    :: SomePKPayload
    -- ^ public key "payload" of user ID being signed
    -> UserId
    -- ^ user ID being signed
    -> [SigSubPacket]
    -- ^ hashed signature subpackets
    -> [SigSubPacket]
    -- ^ unhashed signature subpackets
    -> RSATypes.PrivateKey
    -- ^ RSA signing key
    -> Either SignError SignaturePayload
signUserIDwithRSA = signCertificationWithRSA PositiveCert

signCertificationWithRSA
    :: SigType
    -- ^ certification type (GenericCert, PersonaCert, CasualCert, PositiveCert)
    -> SomePKPayload
    -- ^ public key "payload" of user ID being signed
    -> UserId
    -- ^ user ID being signed
    -> [SigSubPacket]
    -- ^ hashed signature subpackets
    -> [SigSubPacket]
    -- ^ unhashed signature subpackets
    -> RSATypes.PrivateKey
    -- ^ RSA signing key
    -> Either SignError SignaturePayload
signCertificationWithRSA st pkp uid hsigsubs usigsubs prv
    | st `elem` [GenericCert, PersonaCert, CasualCert, PositiveCert] = do
        let payloadToSign = BL.toStrict (finalPayload (SignaturePkt uidsigp) uidpayload)
        uidsigp'
            <$> left16FromSignedPayloadForSign SHA512 payloadToSign
            <*> first
                (SignBackendError . show)
                ( P15.sign
                    Nothing
                    (Just CHA.SHA512)
                    prv
                    payloadToSign
                )
    | otherwise =
        Left (SignUnsupportedCertificationType st)
  where
    uidpayload =
        runPut
            ( sequence_
                [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)]
            )
    uidsigp =
        SigV4 st RSA SHA512 hsigsubs usigsubs 0 (NE.fromList [MPI 0])
    uidsigp' left16 us =
        SigV4
            st
            RSA
            SHA512
            hsigsubs
            usigsubs
            left16
            (NE.fromList [MPI (os2ip us)])

signDirectKeyWithRSA
    :: SigType
    -- ^ key-scoped signature type (SignatureDirectlyOnAKey or KeyRevocationSig)
    -> SomePKPayload
    -- ^ primary key "payload" being signed
    -> [SigSubPacket]
    -- ^ hashed signature subpackets
    -> [SigSubPacket]
    -- ^ unhashed signature subpackets
    -> RSATypes.PrivateKey
    -- ^ RSA signing key
    -> Either SignError SignaturePayload
signDirectKeyWithRSA st pkp hsigsubs usigsubs prv
    | st `elem` [SignatureDirectlyOnAKey, KeyRevocationSig] =
        signDataWithRSA st prv hsigsubs usigsubs keypayload
    | otherwise =
        Left (SignUnsupportedKeySignatureType st)
  where
    keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp))

signKeyRevocationWithRSA
    :: SomePKPayload
    -- ^ primary key "payload" being revoked
    -> [SigSubPacket]
    -- ^ hashed signature subpackets
    -> [SigSubPacket]
    -- ^ unhashed signature subpackets
    -> RSATypes.PrivateKey
    -- ^ RSA signing key
    -> Either SignError SignaturePayload
signKeyRevocationWithRSA = signDirectKeyWithRSA KeyRevocationSig

signSubkeyRevocationWithRSA
    :: SomePKPayload
    -- ^ primary key "payload"
    -> SomePKPayload
    -- ^ public subkey "payload" being revoked
    -> [SigSubPacket]
    -- ^ hashed signature subpackets
    -> [SigSubPacket]
    -- ^ unhashed signature subpackets
    -> RSATypes.PrivateKey
    -- ^ RSA signing key
    -> Either SignError SignaturePayload
signSubkeyRevocationWithRSA pkp subpkp hsigsubs usigsubs prv =
    signDataWithRSA
        SubkeyRevocationSig
        prv
        hsigsubs
        usigsubs
        subkeypayload
  where
    subkeypayload =
        runPut
            ( sequence_
                [ putKeyforSigning (PublicKeyPkt pkp)
                , putKeyforSigning (PublicSubkeyPkt subpkp)
                ]
            )

signCertRevocationWithRSA
    :: SomePKPayload
    -- ^ primary key "payload"
    -> UserId
    -- ^ user ID certification being revoked
    -> [SigSubPacket]
    -- ^ hashed signature subpackets
    -> [SigSubPacket]
    -- ^ unhashed signature subpackets
    -> RSATypes.PrivateKey
    -- ^ RSA signing key
    -> Either SignError SignaturePayload
signCertRevocationWithRSA pkp uid hsigsubs usigsubs prv =
    signDataWithRSA
        CertRevocationSig
        prv
        hsigsubs
        usigsubs
        certpayload
  where
    certpayload =
        runPut
            ( sequence_
                [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)]
            )

crossSignSubkeyWithRSA
    :: SomePKPayload
    -- ^ public key "payload" of key being signed
    -> SomePKPayload
    -- ^ public subkey "payload" of key being signed
    -> [SigSubPacket]
    -- ^ hashed signature subpackets for binding sig
    -> [SigSubPacket]
    -- ^ unhashed signature subpackets for binding sig
    -> [SigSubPacket]
    -- ^ hashed signature subpackets for embedded sig
    -> [SigSubPacket]
    -- ^ unhashed signature subpackets for embedded sig
    -> RSATypes.PrivateKey
    -- ^ RSA signing key
    -> RSATypes.PrivateKey
    -- ^ RSA signing subkey
    -> Either SignError SignaturePayload
crossSignSubkeyWithRSA pkp subpkp subhsigsubs subusigsubs embhsigsubs embusigsubs prv ssb = do
    let embPayloadToSign =
            BL.toStrict (finalPayload (SignaturePkt embsigp) subkeypayload)
        subPayloadToSign =
            BL.toStrict (finalPayload (SignaturePkt subsigp) subkeypayload)
    ( \embleft16 subleft16 embsig subsig ->
            subsigp' (embsigp' embleft16 embsig) subleft16 subsig
        )
        <$> left16FromSignedPayloadForSign SHA512 embPayloadToSign
        <*> left16FromSignedPayloadForSign SHA512 subPayloadToSign
        <*> first
            (SignBackendError . show)
            ( P15.sign
                Nothing
                (Just CHA.SHA512)
                ssb
                embPayloadToSign
            )
        <*> first
            (SignBackendError . show)
            ( P15.sign
                Nothing
                (Just CHA.SHA512)
                prv
                subPayloadToSign
            )
  where
    subkeypayload =
        runPut
            ( sequence_
                [ putKeyforSigning (PublicKeyPkt pkp)
                , putKeyforSigning (PublicSubkeyPkt subpkp)
                ]
            )
    embsigp =
        SigV4
            PrimaryKeyBindingSig
            RSA
            SHA512
            embhsigsubs
            embusigsubs
            0
            (NE.fromList [MPI 0])
    embsigp' left16 es =
        SigV4
            PrimaryKeyBindingSig
            RSA
            SHA512
            embhsigsubs
            embusigsubs
            left16
            (NE.fromList [MPI (os2ip es)])
    subsigp =
        SigV4
            SubkeyBindingSig
            RSA
            SHA512
            subhsigsubs
            []
            0
            (NE.fromList [MPI 0])
    sspes es = SigSubPacket False (EmbeddedSignature es)
    subsigp' es left16 ss =
        SigV4
            SubkeyBindingSig
            RSA
            SHA512
            subhsigsubs
            (sspes es : subusigsubs)
            left16
            (NE.fromList [MPI (os2ip ss)])

signRSAV4Core
    :: TextNormalizationMode
    -> SigType
    -> HashAlgorithm
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> RSATypes.PrivateKey
    -> ByteString
    -> Either SignError SignaturePayload
signRSAV4Core mode st ha has uhas prv payload =
    ( \left16 ss ->
        SigV4 st RSA ha has uhas left16 (NE.fromList [MPI (os2ip ss)])
    )
        <$> left16FromSignedPayloadForSign ha payloadToSign
        <*> rsaPKCS15Sign ha prv payloadToSign
  where
    sig0 = SigV4 st RSA ha has [] 0 (NE.fromList [MPI 0])
    payloadToSign =
        BL.toStrict
            ( finalPayload
                (SignaturePkt sig0)
                (normalizePayloadForSigTypeWith mode st payload)
            )

signRSAV6Core
    :: TextNormalizationMode
    -> SigType
    -> HashAlgorithm
    -> SignatureSalt
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> RSATypes.PrivateKey
    -> ByteString
    -> Either SignError SignaturePayload
signRSAV6Core mode st ha salt has uhas prv payload = do
    validateV6SaltSize ha salt
    ( \left16 sigBytes ->
            SigV6
                st
                RSA
                ha
                salt
                has
                uhas
                left16
                (NE.fromList [MPI (os2ip sigBytes)])
        )
        <$> left16FromSignedPayloadForSign ha payloadToSign
        <*> rsaPKCS15Sign ha prv payloadToSign
  where
    sig0 = SigV6 st RSA ha salt has [] 0 (NE.fromList [MPI 0])
    payloadToSign =
        BL.toStrict
            ( finalPayload
                (SignaturePkt sig0)
                (normalizePayloadForSigTypeWith mode st payload)
            )

signDataWithRSA
    :: SigType
    -> RSATypes.PrivateKey
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithRSA st prv has uhas payload =
    signRSAV4Core CleartextCompat st SHA512 has uhas prv payload

signDataWithRSAV6
    :: SigType
    -> SignatureSalt
    -> RSATypes.PrivateKey
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithRSAV6 st salt prv has uhas payload =
    signRSAV6Core CleartextCompat st SHA512 salt has uhas prv payload

-- FIXME: clean this up
ed25519Params
    , ed25519LegacyParams
    , ed448Params
        :: (String, Int, Int, PubKeyAlgorithm)
ed25519Params = ("Ed25519", 64, 32, PKA.Ed25519)
ed25519LegacyParams = ("Ed25519Legacy", 64, 32, PKA.EdDSA)
ed448Params = ("Ed448", 114, 57, PKA.Ed448)

signDataWithEdDSAV4Generic
    :: (String, Int, Int, PubKeyAlgorithm)
    -> (B.ByteString -> B.ByteString)
    -> TextNormalizationMode
    -> HashAlgorithm
    -> SigType
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithEdDSAV4Generic (algoName, sigLen, limbLen, pka) signer mode ha st has uhas payload =
    signEdDSAV4
        algoName
        sigLen
        limbLen
        signer
        mode
        st
        pka
        ha
        has
        uhas
        payload

signDataWithEdDSAV6Generic
    :: (String, Int, Int, PubKeyAlgorithm)
    -> (B.ByteString -> B.ByteString)
    -> TextNormalizationMode
    -> HashAlgorithm
    -> SigType
    -> SignatureSalt
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithEdDSAV6Generic (algoName, sigLen, limbLen, pka) signer mode ha st salt has uhas payload =
    signEdDSAV6
        algoName
        sigLen
        limbLen
        signer
        mode
        st
        pka
        ha
        salt
        has
        uhas
        payload

signDataWithEd25519
    :: SigType
    -> Ed25519.SecretKey
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithEd25519 st sk has uhas payload =
    signDataWithEdDSAV4Generic
        ed25519Params
        (ed25519Signer sk)
        CleartextCompat
        SHA512
        st
        has
        uhas
        payload

signDataWithEd25519Legacy
    :: SigType
    -> Ed25519.SecretKey
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithEd25519Legacy st sk has uhas payload =
    signDataWithEdDSAV4Generic
        ed25519LegacyParams
        (ed25519Signer sk)
        CleartextCompat
        SHA512
        st
        has
        uhas
        payload

signDataWithEd25519V6
    :: SigType
    -> SignatureSalt
    -> Ed25519.SecretKey
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithEd25519V6 st salt sk has uhas payload =
    signDataWithEdDSAV6Generic
        ed25519Params
        (ed25519Signer sk)
        CleartextCompat
        SHA512
        st
        salt
        has
        uhas
        payload

signDataWithEd448
    :: SigType
    -> Ed448.SecretKey
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithEd448 st sk has uhas payload =
    signDataWithEdDSAV4Generic
        ed448Params
        (ed448Signer sk)
        CleartextCompat
        SHA512
        st
        has
        uhas
        payload

signDataWithEd448V6
    :: SigType
    -> SignatureSalt
    -> Ed448.SecretKey
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithEd448V6 st salt sk has uhas payload =
    signDataWithEdDSAV6Generic
        ed448Params
        (ed448Signer sk)
        CleartextCompat
        SHA512
        st
        salt
        has
        uhas
        payload

{- | Builder-based signature creation for RSA

Example usage:
  builder <- sigBuilderInit BinarySig RSA SHA512
  builder' <- addHashedSubs hashedSubpackets builder
  builder'' <- addUnhashedSubs unhashedSubpackets builder'
  sig <- signDataWithRSABuilder builder'' rsaPrivateKey payload
-}
signDataWithRSABuilder
    :: SigBuilder
        Codec.Encryption.OpenPGP.Types.Unhashed
        Codec.Encryption.OpenPGP.Types.V4Sig
        'PKA.RSA
    -> RSATypes.PrivateKey
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithRSABuilder builder prv payload =
    signRSAV4Core
        (sbTextNormMode builder)
        (sbSigType builder)
        (sbHashAlgo builder)
        (sbHashedSubs builder)
        (sbUnhashedSubs builder)
        prv
        payload

-- | Builder-based signature creation for RSA (v6)
signDataWithRSAV6Builder
    :: SigBuilder
        Codec.Encryption.OpenPGP.Types.Unhashed
        Codec.Encryption.OpenPGP.Types.V6Sig
        'PKA.RSA
    -> RSATypes.PrivateKey
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithRSAV6Builder builder prv payload =
    signRSAV6Core
        (sbTextNormMode builder)
        (sbSigType builder)
        (sbHashAlgo builder)
        (sbSalt builder)
        (sbHashedSubs builder)
        (sbUnhashedSubs builder)
        prv
        payload

{- | Builder-based signature creation for Ed25519 (v4)

Example usage:
  builder <- sigBuilderInit BinarySig Ed25519 SHA512
  builder' <- addHashedSubs hashedSubpackets builder
  builder'' <- addUnhashedSubs unhashedSubpackets builder'
  sig <- signDataWithEd25519Builder builder'' ed25519PrivateKey payload
-}
signDataWithEd25519Builder
    :: SigBuilder
        Codec.Encryption.OpenPGP.Types.Unhashed
        Codec.Encryption.OpenPGP.Types.V4Sig
        'PKA.Ed25519
    -> Ed25519.SecretKey
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithEd25519Builder builder sk payload =
    signDataWithEdDSAV4Generic
        ed25519Params
        (ed25519Signer sk)
        (sbTextNormMode builder)
        (sbHashAlgo builder)
        (sbSigType builder)
        (sbHashedSubs builder)
        (sbUnhashedSubs builder)
        payload

{- | Builder-based signature creation for Ed25519 (v6)

Example usage:
  builder <- sigBuilderInitV6 BinarySig Ed25519 SHA512 salt
  builder' <- addHashedSubs hashedSubpackets builder
  builder'' <- addUnhashedSubs unhashedSubpackets builder'
  sig <- signDataWithEd25519V6Builder builder'' ed25519PrivateKey payload
-}
signDataWithEd25519V6Builder
    :: SigBuilder
        Codec.Encryption.OpenPGP.Types.Unhashed
        Codec.Encryption.OpenPGP.Types.V6Sig
        'PKA.Ed25519
    -> Ed25519.SecretKey
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithEd25519V6Builder builder sk payload =
    signDataWithEdDSAV6Generic
        ed25519Params
        (ed25519Signer sk)
        (sbTextNormMode builder)
        (sbHashAlgo builder)
        (sbSigType builder)
        (sbSalt builder)
        (sbHashedSubs builder)
        (sbUnhashedSubs builder)
        payload

{- | Builder-based signature creation for Ed448 (v4)

Example usage:
  builder <- sigBuilderInit BinarySig Ed448 SHA512
  builder' <- addHashedSubs hashedSubpackets builder
  builder'' <- addUnhashedSubs unhashedSubpackets builder'
  sig <- signDataWithEd448Builder builder'' ed448PrivateKey payload
-}
signDataWithEd448Builder
    :: SigBuilder
        Codec.Encryption.OpenPGP.Types.Unhashed
        Codec.Encryption.OpenPGP.Types.V4Sig
        'PKA.Ed448
    -> Ed448.SecretKey
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithEd448Builder builder sk payload =
    signDataWithEdDSAV4Generic
        ed448Params
        (ed448Signer sk)
        (sbTextNormMode builder)
        (sbHashAlgo builder)
        (sbSigType builder)
        (sbHashedSubs builder)
        (sbUnhashedSubs builder)
        payload

-- | Builder-based signature creation for Ed448 (v6)
signDataWithEd448V6Builder
    :: SigBuilder
        Codec.Encryption.OpenPGP.Types.Unhashed
        Codec.Encryption.OpenPGP.Types.V6Sig
        'PKA.Ed448
    -> Ed448.SecretKey
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithEd448V6Builder builder sk payload =
    signDataWithEdDSAV6Generic
        ed448Params
        (ed448Signer sk)
        (sbTextNormMode builder)
        (sbHashAlgo builder)
        (sbSigType builder)
        (sbSalt builder)
        (sbHashedSubs builder)
        (sbUnhashedSubs builder)
        payload

{- | Algorithm-agnostic signature builder dispatcher (Phase 2)

Dispatches to the appropriate signing function based on the private key type.
The private key type (PrivateKeyFor algo) encodes the algorithm at the type level,
allowing compile-time verification that the key and builder algorithm match.

Example usage:
-}
class BuilderSigningAlgorithm (algo :: PKA.PubKeyAlgorithm) where
    signDataWithAlgorithmicBuilderImpl
        :: SigBuilder
            Codec.Encryption.OpenPGP.Types.Unhashed
            Codec.Encryption.OpenPGP.Types.V4Sig
            algo
        -> PrivateKeyFor algo
        -> ByteString
        -> Either SignError SignaturePayload

instance BuilderSigningAlgorithm 'PKA.RSA where
    signDataWithAlgorithmicBuilderImpl builder (SP.RSAPrivateKey prv) payload =
        signDataWithRSABuilder builder prv payload

instance BuilderSigningAlgorithm 'PKA.Ed25519 where
    signDataWithAlgorithmicBuilderImpl builder (SP.Ed25519PrivateKey sk) payload =
        signDataWithEd25519Builder builder sk payload

instance BuilderSigningAlgorithm 'PKA.Ed448 where
    signDataWithAlgorithmicBuilderImpl builder (SP.Ed448PrivateKey sk) payload =
        signDataWithEd448Builder builder sk payload

{- | Catch-all instance that produces a compile-time error for any algorithm
that is not supported by the algorithmic builder (e.g. DSA, ECDSA).
-}
instance
    {-# OVERLAPPABLE #-}
    ( TypeError
        ( 'Text
            "signDataWithAlgorithmicBuilder does not support this algorithm."
            ':$$: 'Text "Supported algorithms: RSA, Ed25519, Ed448."
            ':$$: 'Text
                    "For DSA or ECDSA, use signDataWith{DSA,ECDSA}Builder directly."
        )
    )
    => BuilderSigningAlgorithm algo
    where
    signDataWithAlgorithmicBuilderImpl = error "unreachable: TypeError fires at compile time"

signDataWithAlgorithmicBuilder
    :: forall (algo :: PKA.PubKeyAlgorithm)
     . BuilderSigningAlgorithm algo
    => SigBuilder
        Codec.Encryption.OpenPGP.Types.Unhashed
        Codec.Encryption.OpenPGP.Types.V4Sig
        algo
    -> PrivateKeyFor algo
    -> ByteString
    -> Either SignError SignaturePayload
signDataWithAlgorithmicBuilder =
    signDataWithAlgorithmicBuilderImpl