Signing.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- | High-level signing monad transformer for OpenPGP.

'SigningT' wraps a 'TK' 'SecretTK' and provides a
unified interface for creating signatures with any
signing-capable subkey or the primary key.

It handles key selection, payload construction
and signature generation.
-}
module Codec.Encryption.OpenPGP.Signing
    ( -- * SigningT transformer
      SigningT
    , runSigningT
    , SigningError (..)
    , renderSigningError

      -- * Signing target selection
    , SigningTarget (..)
    , AvailableSigner (..)
    , asKeyId
    , asFingerprint
    , asKeyPacket
    , asSKey
    , asIsPrimary
    , asUsage
    , listAvailableSigners
    , filterSigningCapable
    , filterByKeyId
    , filterByFingerprint

      -- * Signing payloads
    , SigningPayload (..)

      -- * Low-level signing
    , signWith

      -- * High-level signing operations
    , signUserId
    , signUat

      -- * Timestamp control
    , getCurrentTimestamp
    , setCurrentTimestamp
    , withTimestamp
    ) where

import Control.Monad (guard)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Control.Monad.Trans.RWS
    ( RWST (..)
    , ask
    , get
    , put
    , runRWST
    )
import Crypto.Error (eitherCryptoError)
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA.Types as RSATypes
import Crypto.Random.Types (MonadRandom, getRandomBytes)
import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BL
import Data.List (find)
import Data.Maybe (listToMaybe)
import qualified Data.Set as Set
import Data.Text (Text)

import Codec.Encryption.OpenPGP.Fingerprint
    ( eightOctetKeyID
    , fingerprint
    )
import Codec.Encryption.OpenPGP.SignatureQualities
    ( signatureHashedSubpacketsKnown
    )
import Codec.Encryption.OpenPGP.Signatures
    ( SignError (..)
    , payloadForCertRevocation
    , payloadForDirectKey
    , payloadForPrimaryKeyBinding
    , payloadForSubkeyBinding
    , payloadForSubkeyRevocation
    , payloadForUat
    , payloadForUserId
    , randomSignatureSalt
    , renderSignError
    , signCertRevocation
    , signDataWithEd25519
    , signDataWithEd25519V6
    , signDataWithEd448
    , signDataWithEd448V6
    , signDataWithRSA
    , signDataWithRSAV6
    , signDirectKey
    , signSubkeyBinding
    , signSubkeyRevocation
    )
import qualified Codec.Encryption.OpenPGP.Signatures as S
import Codec.Encryption.OpenPGP.Subpackets
    ( TextNormalizationMode (..)
    )
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA
import Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes
    ( RSA_PrivateKey (..)
    )
import Codec.Encryption.OpenPGP.Types.Internal.TK
    ( TK (..)
    , TKKind (..)
    , _tkPrimaryKey
    , _tkSubs
    )

-- | Signing-specific errors.
data SigningError
    = SigningSignError !SignError
    | SigningNoSignersAvailable
    | SigningInvalidTarget !ByteString
    | SigningKeyNotSigningCapable !ByteString
    | SigningKeyExpired !ByteString
    | SigningKeyNotYetValid !ByteString
    | SigningSKeyInitFailed !String
    deriving (Eq, Show)

renderSigningError :: SigningError -> String
renderSigningError (SigningSignError e) = renderSignError e
renderSigningError SigningNoSignersAvailable = "no signing-capable keys available"
renderSigningError (SigningInvalidTarget kid) = "invalid signing target: " ++ show kid
renderSigningError (SigningKeyNotSigningCapable kid) = "key is not signing-capable: " ++ show kid
renderSigningError (SigningKeyExpired kid) = "key has expired: " ++ show kid
renderSigningError (SigningKeyNotYetValid kid) = "key is not yet valid: " ++ show kid
renderSigningError (SigningSKeyInitFailed msg) = "failed to initialize secret key: " ++ msg

-- | The signing monad transformer.
newtype SigningT (tk :: TKKind) m a = SigningT
    { unSigningT
        :: ExceptT
            SigningError
            ( RWST
                (TK 'SecretTK)
                [Text]
                ThirtyTwoBitTimeStamp
                m
            )
            a
    }
    deriving newtype (Applicative, Functor, Monad)

-- | Run a 'SigningT' action.
runSigningT
    :: Monad m
    => TK 'SecretTK
    -- ^ The secret transferable key to sign with
    -> ThirtyTwoBitTimeStamp
    -- ^ Initial timestamp
    -> SigningT 'SecretTK m a
    -- ^ Action to run
    -> m (Either SigningError a)
runSigningT tk ts (SigningT action) =
    (runRWST (runExceptT action) tk) ts >>= \(e, _, _) -> return e

-- | Which key to sign with.
data SigningTarget
    = SignWithPrimary
    | SignWithKey !PKA.EightOctetKeyId
    | SignWithBest
    | SignWithBestFilter !(AvailableSigner -> Bool)

-- | A signing-capable key extracted from a 'TK'.
data AvailableSigner = AvailableSigner
    { asKeyId :: !PKA.EightOctetKeyId
    , asFingerprint :: !PKA.Fingerprint
    , asKeyPacket :: !(KeyPkt 'SecretPkt)
    , asSKey :: !SKey
    , asIsPrimary :: !Bool
    , asUsage :: !(Set.Set KeyFlag)
    }

signingCapableFlags :: Set.Set KeyFlag
signingCapableFlags = Set.fromList [SignDataKey, CertifyKeysKey, AuthKey]

isSigningCapable :: Set.Set KeyFlag -> Bool
isSigningCapable usage = not (Set.null (Set.intersection usage signingCapableFlags))

-- | List all signing-capable keys from a 'TK' 'SecretTK'.
listAvailableSigners :: TK 'SecretTK -> [AvailableSigner]
listAvailableSigners tk =
    primary : subs
  where
    primaryKp = _tkPrimaryKey tk
    primaryPkp = keyPktPKPayload primaryKp
    primarySka = secretKeyPktSKAddendum primaryKp
    primaryUsage =
        foldr
            Set.union
            Set.empty
            (map sigFlags (_tkDirectKeySigs tk ++ _tkRevs tk))
    primary =
        AvailableSigner
            { asKeyId = either error id (eightOctetKeyID primaryPkp)
            , asFingerprint = fingerprint primaryPkp
            , asKeyPacket = primaryKp
            , asSKey = case primarySka of
                SUSUnprotected sk _ -> sk
                _ -> error "encrypted secret key not supported in SigningT"
            , asIsPrimary = True
            , asUsage = primaryUsage
            }
    subs = do
        (subKp, subSigs) <- _tkSubs tk
        let subPkp = keyPktPKPayload subKp
            subSka = secretKeyPktSKAddendum subKp
            subUsage = foldr Set.union Set.empty (map sigFlags subSigs)
        guard (isSigningCapable subUsage)
        pure
            AvailableSigner
                { asKeyId = either error id (eightOctetKeyID subPkp)
                , asFingerprint = fingerprint subPkp
                , asKeyPacket = subKp
                , asSKey = case subSka of
                    SUSUnprotected sk _ -> sk
                    _ -> error "encrypted secret key not supported in SigningT"
                , asIsPrimary = False
                , asUsage = subUsage
                }
    sigFlags sig = case signatureHashedSubpacketsKnown sig of
        Nothing -> Set.empty
        Just hs -> foldr Set.union Set.empty (map goSub hs)
    goSub (SigSubPacket _ (KeyFlags flags)) = flags
    goSub _ = Set.empty

-- | A typed signing payload.
data SigningPayload
    = SPUserId !SigType !UserId
    | SPUat !SigType !UserAttribute
    | SPDirectKey
    | SPKeyRevocation
    | SPSubkeyRevocation !(KeyPkt 'PublicPkt)
    | SPCertRevocation !UserId
    | SPSignSubkeyBinding !(KeyPkt 'PublicPkt)
    | SPPrimaryKeyBinding !(KeyPkt 'PublicPkt)
    | SPRaw !SigType !ByteString
    deriving (Eq, Show)

-- | Sign an arbitrary payload with a selected key.
signWith
    :: forall m
     . MonadRandom m
    => SigningTarget
    -> SigningPayload
    -> SigningT 'SecretTK m (Either SigningError SignaturePayload)
signWith target payload = do
    tk <- SigningT . lift $ ask
    ts <- SigningT . lift $ get
    let signers = listAvailableSigners tk
        selected = resolveTarget target signers
    case selected of
        Nothing -> pure $ Left (signingErrorFromTarget target)
        Just signer -> do
            let kp = asKeyPacket signer
                ska = asSKey signer
            signWithPayload ts kp ska payload

signWithPayload
    :: (Monad m, MonadRandom m)
    => ThirtyTwoBitTimeStamp
    -> KeyPkt 'SecretPkt
    -> SKey
    -> SigningPayload
    -> SigningT 'SecretTK m (Either SigningError SignaturePayload)
signWithPayload ts kp ska payload = do
    result <- SigningT $ lift $ lift $ go ska
    pure $ first SigningSignError result
  where
    go _ska = case keyPktPKPayload kp of
        PKPayload V4 _ _ pka _ -> goV4 pka
        PKPayload V6 _ _ pka _ -> goV6 pka
        PKPayload DeprecatedV3 _ _ pka _ -> goV4 pka
    goV4 pka = case (pka, ska) of
        (RSA, RSAPrivateKey rsaPriv) -> signRSA ts kp (unRSA_PrivateKey rsaPriv) payload
        (EdDSALegacy, EdDSAPrivateKey EdSigningCurve25519 bs) ->
            signEd25519V4 ts kp bs payload
        (EdDSALegacy, Ed25519PrivateKey bs) ->
            signEd25519V4 ts kp bs payload
        (Ed448, EdDSAPrivateKey EdSigningCurve448 bs) ->
            signEd448V4 ts kp bs payload
        (Ed448, Ed448PrivateKey bs) ->
            signEd448V4 ts kp bs payload
        _ ->
            pure $
                Left (SignBackendError "unsupported signing key type for V4")
    goV6 pka = case (pka, ska) of
        (RSA, RSAPrivateKey rsaPriv) -> signRSA ts kp (unRSA_PrivateKey rsaPriv) payload
        (Ed25519, EdDSAPrivateKey EdSigningCurve25519 bs) ->
            signEd25519V6 ts kp bs payload
        (Ed25519, Ed25519PrivateKey bs) ->
            signEd25519V6 ts kp bs payload
        (Ed448, EdDSAPrivateKey EdSigningCurve448 bs) ->
            signEd448V6 ts kp bs payload
        (Ed448, Ed448PrivateKey bs) ->
            signEd448V6 ts kp bs payload
        _ ->
            pure $
                Left (SignBackendError "unsupported signing key type for V6")

signRSA
    :: MonadRandom m
    => ThirtyTwoBitTimeStamp
    -> KeyPkt 'SecretPkt
    -> RSATypes.PrivateKey
    -> SigningPayload
    -> m (Either SignError SignaturePayload)
signRSA ts kp p payload =
    case keyPktPKPayload kp of
        PKPayload V4 _ _ _ _ -> pure $ goV4 payload
        PKPayload V6 _ _ _ _ -> do
            salt <- randomSignatureSalt ha
            pure $ goV6 salt payload
        PKPayload DeprecatedV3 _ _ _ _ -> pure $ goV4 payload
  where
    ha = SHA512
    hashed = [SigSubPacket True (SigCreationTime ts)]
    unhashed = []
    goV4 = signPayloadWithRSA kp ha hashed unhashed p
    goV6 salt = signPayloadWithRSAV6 kp ha salt hashed unhashed p

signEd25519V4
    :: MonadRandom m
    => ThirtyTwoBitTimeStamp
    -> KeyPkt 'SecretPkt
    -> ByteString
    -> SigningPayload
    -> m (Either SignError SignaturePayload)
signEd25519V4 ts kp bs payload =
    case eitherCryptoError (Ed25519.secretKey bs) of
        Left err -> pure $ Left (SignBackendError (show err))
        Right sk ->
            let ha = SHA512
                hashed = [SigSubPacket True (SigCreationTime ts)]
                unhashed = []
             in pure $ signPayloadWithEd25519 kp ha hashed unhashed sk payload

signEd25519V6
    :: MonadRandom m
    => ThirtyTwoBitTimeStamp
    -> KeyPkt 'SecretPkt
    -> ByteString
    -> SigningPayload
    -> m (Either SignError SignaturePayload)
signEd25519V6 ts kp bs payload = do
    let ha = SHA512
    salt <- randomSignatureSalt ha
    case eitherCryptoError (Ed25519.secretKey bs) of
        Left err -> pure $ Left (SignBackendError (show err))
        Right sk ->
            let hashed = [SigSubPacket True (SigCreationTime ts)]
                unhashed = []
             in pure $
                    signPayloadWithEd25519V6 kp ha salt hashed unhashed sk payload

signEd448V4
    :: MonadRandom m
    => ThirtyTwoBitTimeStamp
    -> KeyPkt 'SecretPkt
    -> ByteString
    -> SigningPayload
    -> m (Either SignError SignaturePayload)
signEd448V4 ts kp bs payload =
    case eitherCryptoError (Ed448.secretKey bs) of
        Left err -> pure $ Left (SignBackendError (show err))
        Right sk ->
            let ha = SHA512
                hashed = [SigSubPacket True (SigCreationTime ts)]
                unhashed = []
             in pure $ signPayloadWithEd448 kp ha hashed unhashed sk payload

signEd448V6
    :: MonadRandom m
    => ThirtyTwoBitTimeStamp
    -> KeyPkt 'SecretPkt
    -> ByteString
    -> SigningPayload
    -> m (Either SignError SignaturePayload)
signEd448V6 ts kp bs payload = do
    let ha = SHA512
    salt <- randomSignatureSalt ha
    case eitherCryptoError (Ed448.secretKey bs) of
        Left err -> pure $ Left (SignBackendError (show err))
        Right sk ->
            let hashed = [SigSubPacket True (SigCreationTime ts)]
                unhashed = []
             in pure $
                    signPayloadWithEd448V6 kp ha salt hashed unhashed sk payload

signPayloadWithRSA
    :: KeyPkt 'SecretPkt
    -> HashAlgorithm
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> RSATypes.PrivateKey
    -> SigningPayload
    -> Either SignError SignaturePayload
signPayloadWithRSA kp ha hs us p payload =
    case payload of
        SPUserId st uid -> signDataWithRSA ha st p hs us (payloadForUserId pkp uid)
        SPUat st uat -> signDataWithRSA ha st p hs us (payloadForUat pkp uat)
        SPDirectKey ->
            signDataWithRSA
                ha
                DirectKeySignature
                p
                hs
                us
                (payloadForDirectKey pkp)
        SPKeyRevocation ->
            signDataWithRSA
                ha
                KeyRevocationSig
                p
                hs
                us
                (payloadForDirectKey pkp)
        SPSubkeyRevocation subKp ->
            signDataWithRSA
                ha
                SubkeyRevocationSig
                p
                hs
                us
                (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))
        SPCertRevocation uid ->
            signDataWithRSA
                ha
                CertRevocationSig
                p
                hs
                us
                (payloadForCertRevocation pkp uid)
        SPSignSubkeyBinding subKp ->
            signDataWithRSA
                ha
                SubkeyBindingSig
                p
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPPrimaryKeyBinding subKp ->
            signDataWithRSA
                ha
                PrimaryKeyBindingSig
                p
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPRaw st raw -> signDataWithRSA ha st p hs us (BL.fromStrict raw)
  where
    pkp = keyPktPKPayload kp

signPayloadWithRSAV6
    :: KeyPkt 'SecretPkt
    -> HashAlgorithm
    -> SignatureSalt
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> RSATypes.PrivateKey
    -> SigningPayload
    -> Either SignError SignaturePayload
signPayloadWithRSAV6 kp ha salt hs us p payload =
    case payload of
        SPUserId st uid ->
            signDataWithRSAV6 ha st salt p hs us (payloadForUserId pkp uid)
        SPUat st uat -> signDataWithRSAV6 ha st salt p hs us (payloadForUat pkp uat)
        SPDirectKey ->
            signDataWithRSAV6
                ha
                DirectKeySignature
                salt
                p
                hs
                us
                (payloadForDirectKey pkp)
        SPKeyRevocation ->
            signDataWithRSAV6
                ha
                KeyRevocationSig
                salt
                p
                hs
                us
                (payloadForDirectKey pkp)
        SPSubkeyRevocation subKp ->
            signDataWithRSAV6
                ha
                SubkeyRevocationSig
                salt
                p
                hs
                us
                (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))
        SPCertRevocation uid ->
            signDataWithRSAV6
                ha
                CertRevocationSig
                salt
                p
                hs
                us
                (payloadForCertRevocation pkp uid)
        SPSignSubkeyBinding subKp ->
            signDataWithRSAV6
                ha
                SubkeyBindingSig
                salt
                p
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPPrimaryKeyBinding subKp ->
            signDataWithRSAV6
                ha
                PrimaryKeyBindingSig
                salt
                p
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPRaw st raw -> signDataWithRSAV6 ha st salt p hs us (BL.fromStrict raw)
  where
    pkp = keyPktPKPayload kp

signPayloadWithEd25519
    :: KeyPkt 'SecretPkt
    -> HashAlgorithm
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> Ed25519.SecretKey
    -> SigningPayload
    -> Either SignError SignaturePayload
signPayloadWithEd25519 kp ha hs us sk payload =
    case payload of
        SPUserId st uid -> signDataWithEd25519 ha st sk hs us (payloadForUserId pkp uid)
        SPUat st uat -> signDataWithEd25519 ha st sk hs us (payloadForUat pkp uat)
        SPDirectKey ->
            signDataWithEd25519
                ha
                DirectKeySignature
                sk
                hs
                us
                (payloadForDirectKey pkp)
        SPKeyRevocation ->
            signDataWithEd25519
                ha
                KeyRevocationSig
                sk
                hs
                us
                (payloadForDirectKey pkp)
        SPSubkeyRevocation subKp ->
            signDataWithEd25519
                ha
                SubkeyRevocationSig
                sk
                hs
                us
                (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))
        SPCertRevocation uid ->
            signDataWithEd25519
                ha
                CertRevocationSig
                sk
                hs
                us
                (payloadForCertRevocation pkp uid)
        SPSignSubkeyBinding subKp ->
            signDataWithEd25519
                ha
                SubkeyBindingSig
                sk
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPPrimaryKeyBinding subKp ->
            signDataWithEd25519
                ha
                PrimaryKeyBindingSig
                sk
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPRaw st raw -> signDataWithEd25519 ha st sk hs us (BL.fromStrict raw)
  where
    pkp = keyPktPKPayload kp

signPayloadWithEd25519V6
    :: KeyPkt 'SecretPkt
    -> HashAlgorithm
    -> SignatureSalt
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> Ed25519.SecretKey
    -> SigningPayload
    -> Either SignError SignaturePayload
signPayloadWithEd25519V6 kp ha salt hs us sk payload =
    case payload of
        SPUserId st uid ->
            signDataWithEd25519V6
                ha
                st
                salt
                sk
                hs
                us
                (payloadForUserId pkp uid)
        SPUat st uat ->
            signDataWithEd25519V6 ha st salt sk hs us (payloadForUat pkp uat)
        SPDirectKey ->
            signDataWithEd25519V6
                ha
                DirectKeySignature
                salt
                sk
                hs
                us
                (payloadForDirectKey pkp)
        SPKeyRevocation ->
            signDataWithEd25519V6
                ha
                KeyRevocationSig
                salt
                sk
                hs
                us
                (payloadForDirectKey pkp)
        SPSubkeyRevocation subKp ->
            signDataWithEd25519V6
                ha
                SubkeyRevocationSig
                salt
                sk
                hs
                us
                (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))
        SPCertRevocation uid ->
            signDataWithEd25519V6
                ha
                CertRevocationSig
                salt
                sk
                hs
                us
                (payloadForCertRevocation pkp uid)
        SPSignSubkeyBinding subKp ->
            signDataWithEd25519V6
                ha
                SubkeyBindingSig
                salt
                sk
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPPrimaryKeyBinding subKp ->
            signDataWithEd25519V6
                ha
                PrimaryKeyBindingSig
                salt
                sk
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPRaw st raw -> signDataWithEd25519V6 ha st salt sk hs us (BL.fromStrict raw)
  where
    pkp = keyPktPKPayload kp

signPayloadWithEd448
    :: KeyPkt 'SecretPkt
    -> HashAlgorithm
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> Ed448.SecretKey
    -> SigningPayload
    -> Either SignError SignaturePayload
signPayloadWithEd448 kp ha hs us sk payload =
    case payload of
        SPUserId st uid -> signDataWithEd448 ha st sk hs us (payloadForUserId pkp uid)
        SPUat st uat -> signDataWithEd448 ha st sk hs us (payloadForUat pkp uat)
        SPDirectKey ->
            signDataWithEd448
                ha
                DirectKeySignature
                sk
                hs
                us
                (payloadForDirectKey pkp)
        SPKeyRevocation ->
            signDataWithEd448
                ha
                KeyRevocationSig
                sk
                hs
                us
                (payloadForDirectKey pkp)
        SPSubkeyRevocation subKp ->
            signDataWithEd448
                ha
                SubkeyRevocationSig
                sk
                hs
                us
                (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))
        SPCertRevocation uid ->
            signDataWithEd448
                ha
                CertRevocationSig
                sk
                hs
                us
                (payloadForCertRevocation pkp uid)
        SPSignSubkeyBinding subKp ->
            signDataWithEd448
                ha
                SubkeyBindingSig
                sk
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPPrimaryKeyBinding subKp ->
            signDataWithEd448
                ha
                PrimaryKeyBindingSig
                sk
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPRaw st raw -> signDataWithEd448 ha st sk hs us (BL.fromStrict raw)
  where
    pkp = keyPktPKPayload kp

signPayloadWithEd448V6
    :: KeyPkt 'SecretPkt
    -> HashAlgorithm
    -> SignatureSalt
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> Ed448.SecretKey
    -> SigningPayload
    -> Either SignError SignaturePayload
signPayloadWithEd448V6 kp ha salt hs us sk payload =
    case payload of
        SPUserId st uid ->
            signDataWithEd448V6
                ha
                st
                salt
                sk
                hs
                us
                (payloadForUserId pkp uid)
        SPUat st uat ->
            signDataWithEd448V6 ha st salt sk hs us (payloadForUat pkp uat)
        SPDirectKey ->
            signDataWithEd448V6
                ha
                DirectKeySignature
                salt
                sk
                hs
                us
                (payloadForDirectKey pkp)
        SPKeyRevocation ->
            signDataWithEd448V6
                ha
                KeyRevocationSig
                salt
                sk
                hs
                us
                (payloadForDirectKey pkp)
        SPSubkeyRevocation subKp ->
            signDataWithEd448V6
                ha
                SubkeyRevocationSig
                salt
                sk
                hs
                us
                (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))
        SPCertRevocation uid ->
            signDataWithEd448V6
                ha
                CertRevocationSig
                salt
                sk
                hs
                us
                (payloadForCertRevocation pkp uid)
        SPSignSubkeyBinding subKp ->
            signDataWithEd448V6
                ha
                SubkeyBindingSig
                salt
                sk
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPPrimaryKeyBinding subKp ->
            signDataWithEd448V6
                ha
                PrimaryKeyBindingSig
                salt
                sk
                hs
                us
                (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))
        SPRaw st raw -> signDataWithEd448V6 ha st salt sk hs us (BL.fromStrict raw)
  where
    pkp = keyPktPKPayload kp

signingErrorFromTarget :: SigningTarget -> SigningError
signingErrorFromTarget SignWithPrimary = SigningNoSignersAvailable
signingErrorFromTarget (SignWithKey kid) = SigningInvalidTarget (PKA.unEOKI kid)
signingErrorFromTarget SignWithBest = SigningNoSignersAvailable
signingErrorFromTarget (SignWithBestFilter _) = SigningNoSignersAvailable

resolveTarget
    :: SigningTarget -> [AvailableSigner] -> Maybe AvailableSigner
resolveTarget SignWithPrimary signers = listToMaybe (filter asIsPrimary signers)
resolveTarget (SignWithKey kid) signers = find (\s -> asKeyId s == kid) signers
resolveTarget SignWithBest signers = listToMaybe signers
resolveTarget (SignWithBestFilter p) signers = find p signers

-- | Sign a user ID with the primary key.
signUserId
    :: (MonadRandom m)
    => SigType
    -> UserId
    -> SigningT 'SecretTK m (Either SigningError SignaturePayload)
signUserId st uid = do
    result <- signWith SignWithPrimary (SPUserId st uid)
    pure result

-- | Sign a user attribute with the primary key.
signUat
    :: (MonadRandom m)
    => SigType
    -> UserAttribute
    -> SigningT 'SecretTK m (Either SigningError SignaturePayload)
signUat st uat = do
    result <- signWith SignWithPrimary (SPUat st uat)
    pure result

-- | Get the current signing timestamp.
getCurrentTimestamp
    :: Monad m => SigningT tk m ThirtyTwoBitTimeStamp
getCurrentTimestamp = SigningT $ lift get

-- | Set the current signing timestamp.
setCurrentTimestamp
    :: Monad m => ThirtyTwoBitTimeStamp -> SigningT tk m ()
setCurrentTimestamp ts = SigningT $ lift $ put ts

-- | Execute an action with a specific timestamp.
withTimestamp
    :: Monad m
    => ThirtyTwoBitTimeStamp -> SigningT tk m a -> SigningT tk m a
withTimestamp ts action = do
    old <- getCurrentTimestamp
    setCurrentTimestamp ts
    result <- action
    setCurrentTimestamp old
    pure result

-- | Filter to only signing-capable keys.
filterSigningCapable :: [AvailableSigner] -> [AvailableSigner]
filterSigningCapable = filter (\s -> isSigningCapable (asUsage s))

-- | Filter by key ID.
filterByKeyId
    :: PKA.EightOctetKeyId -> [AvailableSigner] -> [AvailableSigner]
filterByKeyId kid = filter (\s -> asKeyId s == kid)

-- | Filter by fingerprint.
filterByFingerprint
    :: PKA.Fingerprint -> [AvailableSigner] -> [AvailableSigner]
filterByFingerprint fp = filter (\s -> asFingerprint s == fp)