-- hop.hs: hOpenPGP-stateless OpenPGP (sop) tool
-- Copyright © 2019-2026  Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}

import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
    ( Armor (..)
    , ArmorType (..)
    )
import Codec.Encryption.OpenPGP.Compression
    ( CompressionError
    , decompressPkt
    , renderCompressionError
    )
import Codec.Encryption.OpenPGP.Encrypt
    ( PKESKEncryptError (..)
    , PKESKSessionMaterial (..)
    , RecipientEncryptRequest (..)
    , RecipientEncryptRequestOverrides (..)
    , RecipientEncryptResult (..)
    , RecipientPKESKVersionStrategyW (..)
    , RecipientPayloadShape (..)
    , defaultRecipientPayloadShape
    , encryptForRecipients
    , recipientEncryptionTarget
    , recipientEncryptionTargetWithStrategyTyped
    )
import Codec.Encryption.OpenPGP.Expirations
    ( effectiveKeyPreferencesAt
    , isTKTimeValid
    )
import Codec.Encryption.OpenPGP.Fingerprint
    ( eightOctetKeyID
    , fingerprint
    )
import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
import Codec.Encryption.OpenPGP.Message
    ( EncryptMessageOptions (..)
    , RecoveredSessionMaterial (..)
    , SessionMaterialExposure (..)
    , encryptMessage
    , encryptedPayloadBytes
    , mkClearPayload
    )
import Codec.Encryption.OpenPGP.Ontology
    ( isKUF
    , isPKBindingSig
    , isSKBindingSig
    )
import Codec.Encryption.OpenPGP.Policy
    ( defaultDecryptPolicy
    , defaultPolicy
    , defaultVerificationPolicy
    , lenientDecryptPolicy
    )
import Codec.Encryption.OpenPGP.S2K
    ( decodeOpenPGPEncodedSessionKey
    , skesk2Key
    , skesk2SessionKey
    )
import Codec.Encryption.OpenPGP.SecretKey
    ( decryptPrivateKey
    , encryptSecretKeyWithPolicy
    )
import Codec.Encryption.OpenPGP.Serialize (parsePkts)
import Codec.Encryption.OpenPGP.Signatures
    ( SignError (..)
    , renderSignError
    , signDataWithEd25519
    , signDataWithEd25519Legacy
    , signDataWithEd25519V6
    , signDataWithEd448
    , signDataWithEd448V6
    , signDataWithRSABuilder
    , signDataWithRSAV6
    , signKeyRevocationWithRSA
    , signUserIDwithRSA
    )
import qualified Codec.Encryption.OpenPGP.Subpackets as SP
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Version as HOV
import Control.Applicative (many, optional, some, (<|>))
import Control.Error.Util (note)
import Control.Exception
    ( IOException
    , SomeException
    , catch
    , displayException
    , evaluate
    , throwIO
    )
import Control.Lens ((^..))
import Control.Monad (forM, forM_, unless, when, (>=>))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State.Lazy (StateT, evalStateT, get, modify)
import Crypto.Error (eitherCryptoError)
import Crypto.Number.Serialize (i2ospOf_, os2ip)
import qualified Crypto.PubKey.Curve25519 as Curve25519
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import Crypto.Random.Types (MonadRandom, getRandomBytes)
import qualified Data.Aeson as A
import Data.Bifunctor (first)
import qualified Data.Binary as Bin
import Data.Binary.Get (runGet)
import Data.Binary.Put
    ( putByteString
    , putLazyByteString
    , putWord16be
    , putWord32be
    , putWord8
    , runPut
    )
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.Char (digitToInt, isHexDigit, isSpace, toLower)
import Data.Conduit (fuseBoth, runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.Combinators as CC
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Decrypt
    ( DecryptKeyResolution (..)
    , DecryptOutcome (..)
    , PKESKRecipientKey (..)
    )
import qualified Data.Conduit.OpenPGP.Decrypt as Decrypt
import Data.Conduit.OpenPGP.Keyring
    ( conduitDropErrorsAndNothings
    , conduitToSomeTKsDroppingEither
    , sinkPublicKeyringMap
    )
import Data.Conduit.OpenPGP.Verify
    ( conduitVerify
    , verifyPacketsBatch
    )
import Data.Data.Lens (biplate)
import Data.Either (fromRight, isLeft, isRight, rights)
import Data.IORef (IORef, atomicModifyIORef', newIORef)
import Data.List
    ( find
    , findIndex
    , intercalate
    , isInfixOf
    , isPrefixOf
    , isSuffixOf
    , nub
    , partition
    , stripPrefix
    )
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
    ( catMaybes
    , fromMaybe
    , isJust
    , listToMaybe
    , mapMaybe
    , maybeToList
    )
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Text.Encoding.Error (lenientDecode)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX
    ( POSIXTime
    , getPOSIXTime
    , posixSecondsToUTCTime
    , utcTimeToPOSIXSeconds
    )
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.Format.ISO8601 (iso8601ParseM)
import qualified Data.Vector as V
import Data.Version (showVersion)
import Data.Word (Word8)
import GHC.Generics
import Options.Applicative.Builder
    ( argument
    , command
    , eitherReader
    , footerDoc
    , headerDoc
    , help
    , helpDoc
    , info
    , long
    , metavar
    , option
    , prefs
    , progDesc
    , showHelpOnError
    , str
    , strArgument
    , strOption
    , switch
    , value
    )
import Options.Applicative.Extra
    ( execParserPure
    , helper
    , hsubparser
    , renderFailure
    )
import Options.Applicative.Types
    ( CompletionResult (..)
    , Parser
    , ParserResult (..)
    )
import Prettyprinter
    ( hardline
    , list
    , pretty
    , softline
    )
import Prettyprinter.Render.Text (hPutDoc)
import System.Directory (doesFileExist)
import System.Environment (getArgs, getProgName, lookupEnv)
import System.Exit
    ( ExitCode (..)
    , exitSuccess
    , exitWith
    )
import System.IO
    ( BufferMode (..)
    , Handle
    , hFlush
    , hPutStrLn
    , hSetBuffering
    , stderr
    , stdin
    )
import Text.Read (readMaybe)

import HOpenPGP.Tools.Common.Armor (doDeArmor)
import HOpenPGP.Tools.Common.Common
    ( banner
    , keyMatchesEightOctetKeyId
    , keyMatchesFingerprint
    , versioner
    , warranty
    )
import HOpenPGP.Tools.Common.TKUtils
    ( processTK
    , verifyTKWithTyped
    )
import Paths_hopenpgp_tools (version)

data Command
    = VersionC VersionOptions
    | ListProfilesC ListProfilesOptions
    | GenerateKeyC KeyGenOptions
    | ChangeKeyPasswordC ChangeKeyPasswordOptions
    | MergeCertsC MergeCertsOptions
    | ValidateUserIdC ValidateUserIdOptions
    | CertifyUserIdC CertifyUserIdOptions
    | RevokeKeyC RevokeKeyOptions
    | UpdateKeyC UpdateKeyOptions
    | VerifyC VerifyOptions
    | InlineVerifyC InlineVerifyOptions
    | EncryptC EncryptOptions
    | DecryptC DecryptOptions
    | InlineSignC InlineSignOptions
    | InlineDetachC InlineDetachOptions
    | ExtractCertC ExtractCertOptions
    | SignC SignOptions
    | UnsupportedC String
    | DeArmorC
    | ArmorC

data OutputFormat
    = Unstructured
    | JSON
    | YAML
    deriving (Eq, Read, Show)

data VerifyOptions
    = VerifyOptions
    { verifyNotBefore :: Maybe String
    , verifyNotAfter :: Maybe String
    , verifySigFile :: String
    , verifyCertFiles :: [String]
    }

data InlineVerifyOptions
    = InlineVerifyOptions
    { inlineNotBefore :: Maybe String
    , inlineNotAfter :: Maybe String
    , verificationsOut :: Maybe String
    , inlineCertFiles :: [String]
    }

data EncryptOptions
    = EncryptOptions
    { encNoArmor :: Bool
    , encProfile :: Maybe String
    , encAs :: AsBinaryText
    , encSignWithKeyFiles :: [String]
    , encSignWithKeyPasswords :: [String]
    , encSessionKeyOutFile :: Maybe String
    , encFor :: EncryptFor
    , encPasswords :: [String]
    , encRecipientCerts :: [String]
    }

data EncryptProfile
    = EncryptProfileRFC9580
    | EncryptProfileRFC4880
    deriving (Eq)

data Profile p = Profile
    { profileName :: String
    , profileDescription :: String
    , profileValue :: p
    , profileAliases :: [String]
    }

encryptProfiles :: [Profile EncryptProfile]
encryptProfiles =
    [ Profile
        "rfc9580"
        "SEIPDv2"
        EncryptProfileRFC9580
        ["default", "security", "performance"]
    , Profile
        "rfc4880"
        "SEIPDv1"
        EncryptProfileRFC4880
        ["compatibility"]
    ]

data DecryptOptions
    = DecryptOptions
    { decNoArmor :: Bool
    , decVerifyNotBefore :: Maybe String
    , decVerifyNotAfter :: Maybe String
    , decSessionKeys :: [String]
    , decSessionKeyOutFile :: Maybe String
    , decPasswords :: [String]
    , decKeyPasswords :: [String]
    , decKeyFiles :: [String]
    , decVerifyCerts :: [String]
    , decVerificationsOutFile :: Maybe String
    }

data InlineSignOptions
    = InlineSignOptions
    { inlineSignNoArmor :: Bool
    , inlineSignAs :: Maybe InlineSignMode
    , inlineSignKeyFiles :: [String]
    , inlineSignKeyPasswords :: [String]
    }

data InlineDetachOptions
    = InlineDetachOptions
    { inlineDetachNoArmor :: Bool
    , inlineDetachOutputSigs :: String
    }

data ChangeKeyPasswordOptions
    = ChangeKeyPasswordOptions
    { changeKeyPasswordNoArmor :: Bool
    , changeKeyPasswordOldPasswords :: [String]
    , changeKeyPasswordNewPassword :: Maybe String
    }

data MergeCertsOptions
    = MergeCertsOptions
    { mergeCertsNoArmor :: Bool
    , mergeCertsFiles :: [String]
    }

data ValidateUserIdOptions
    = ValidateUserIdOptions
    { validateUserIdAddrSpecOnly :: Bool
    , validateUserIdAt :: Maybe String
    , validateUserIdString :: String
    , validateUserIdAuthorityFiles :: [String]
    }

data CertifyUserIdOptions
    = CertifyUserIdOptions
    { certifyUserIds :: [String]
    , certifyUserIdNoArmor :: Bool
    , certifyUserIdNoRequireSelfSig :: Bool
    , certifyUserIdKeyPasswordFiles :: [String]
    , certifyUserIdSignerFiles :: [String]
    }

data RevokeKeyOptions
    = RevokeKeyOptions
    { revokeKeyNoArmor :: Bool
    , revokeKeyPasswordFiles :: [String]
    }

data UpdateKeyOptions
    = UpdateKeyOptions
    { updateKeyNoArmor :: Bool
    , updateKeySigningOnly :: Bool
    , updateKeyRevokeDeprecatedKeys :: Bool
    , updateKeyNoAddedCapabilities :: Bool
    , updateKeyPasswordFiles :: [String]
    , updateKeyMergeCerts :: [String]
    }

newtype ListProfilesOptions
    = ListProfilesOptions
    { profileSubcommand :: String
    }

data VersionOptions
    = VersionOptions
    { vBackend :: Bool
    , vExtended :: Bool
    , vSopSpec :: Bool
    , vSopv :: Bool
    }

data CliOptions
    = CliOptions
    { cliDebug :: Bool
    , cliCommand :: Command
    }

data SopFailure
    = MissingArg
    | IncompleteVerification
    | BadData
    | PasswordNotHumanReadable
    | ExpectedText
    | CannotDecrypt
    | UnsupportedAsymmetricAlgo
    | CertCannotEncrypt
    | UnsupportedOption
    | OutputExists
    | MissingInput
    | NoSignature
    | KeyIsProtected
    | KeyCannotSign
    | UnsupportedSpecialPrefix
    | IncompatibleOptions
    | UnsupportedProfile
    | UnsupportedSubcommand
    | PrimaryKeyBad
    | CertUserIdNoMatch
    | KeyCannotCertify

failureCode :: SopFailure -> Int
failureCode MissingArg = 19
failureCode IncompleteVerification = 23
failureCode BadData = 41
failureCode PasswordNotHumanReadable = 31
failureCode ExpectedText = 53
failureCode CannotDecrypt = 29
failureCode UnsupportedAsymmetricAlgo = 13
failureCode CertCannotEncrypt = 17
failureCode UnsupportedOption = 37
failureCode OutputExists = 59
failureCode MissingInput = 61
failureCode NoSignature = 3
failureCode KeyIsProtected = 67
failureCode KeyCannotSign = 79
failureCode UnsupportedSpecialPrefix = 71
failureCode IncompatibleOptions = 83
failureCode UnsupportedProfile = 89
failureCode UnsupportedSubcommand = 69
failureCode PrimaryKeyBad = 103
failureCode CertUserIdNoMatch = 107
failureCode KeyCannotCertify = 109

failWith :: MonadIO m => SopFailure -> String -> m a
failWith f msg = liftIO $ do
    BLC8.hPutStrLn stderr (BLC8.pack msg)
    exitWith (ExitFailure (failureCode f))

voP :: Parser VerifyOptions
voP =
    VerifyOptions
        <$> optional
            ( strOption
                ( long "not-before"
                    <> metavar "DATE"
                    <> help "ignore signatures before DATE"
                )
            )
        <*> optional
            ( strOption
                ( long "not-after"
                    <> metavar "DATE"
                    <> help "ignore signatures after DATE"
                )
            )
        <*> argument str (metavar "SIGNATURES" <> sigHelp)
        <*> some (strArgument (metavar "CERTS..." <> certHelp))
  where
    sigHelp =
        helpDoc . Just $
            pretty "file containing OpenPGP signatures"
    certHelp =
        helpDoc . Just $
            pretty "one or more certificate files"

ivoP :: Parser InlineVerifyOptions
ivoP =
    InlineVerifyOptions
        <$> optional
            ( strOption
                ( long "not-before"
                    <> metavar "DATE"
                    <> help "ignore signatures before DATE"
                )
            )
        <*> optional
            ( strOption
                ( long "not-after"
                    <> metavar "DATE"
                    <> help "ignore signatures after DATE"
                )
            )
        <*> optional
            ( strOption
                ( long "verifications-out"
                    <> metavar "VERIFICATIONS"
                    <> help "write verification records to file"
                )
            )
        <*> some (strArgument (metavar "CERTS..." <> certHelp))
  where
    certHelp =
        helpDoc . Just $
            pretty "one or more certificate files"

lpoP :: Parser ListProfilesOptions
lpoP =
    ListProfilesOptions
        <$> strArgument
            (metavar "SUBCOMMAND" <> help "subcommand to list profiles for")

vopP :: Parser VersionOptions
vopP =
    VersionOptions
        <$> switch
            (long "backend" <> help "show backend implementation version")
        <*> switch
            (long "extended" <> help "show extended version information")
        <*> switch (long "sop-spec" <> help "show targeted sop draft")
        <*> switch
            (long "sopv" <> help "show implemented sopv subset version")

encP :: Parser EncryptOptions
encP =
    EncryptOptions
        <$> switch (long "no-armor" <> help "output binary")
        <*> optional
            (strOption (long "profile" <> help "encryption profile"))
        <*> option
            (eitherReader asTypeReader)
            (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)
        <*> many
            (strOption (long "sign-with" <> help "signing key material"))
        <*> many
            ( strOption
                ( long "with-key-password"
                    <> help "password for unlocking signing key material"
                )
            )
        <*> optional
            ( strOption
                ( long "session-key-out"
                    <> metavar "SESSIONKEY"
                    <> help "write generated session key to file"
                )
            )
        <*> option
            (eitherReader encryptForReader)
            ( long "for"
                <> metavar "ENCRYPTION_PURPOSE"
                <> help
                    "select recipient key purpose (any, storage, communications)"
                <> value EncryptForAny
            )
        <*> many
            ( strOption
                (long "with-password" <> help "symmetric encryption password")
            )
        <*> many
            ( strArgument
                (metavar "CERT" <> help "recipient certificate files")
            )
  where
    astypeHelp =
        helpDoc . Just $
            pretty "what to treat the input as"
                <> softline
                <> list (map (pretty . fst) asTypes)

decP :: Parser DecryptOptions
decP =
    DecryptOptions
        <$> switch (long "no-armor" <> help "output binary")
        <*> optional
            ( strOption
                ( long "verify-not-before"
                    <> metavar "DATE"
                    <> help "ignore signatures before DATE when decrypting"
                )
            )
        <*> optional
            ( strOption
                ( long "verify-not-after"
                    <> metavar "DATE"
                    <> help "ignore signatures after DATE when decrypting"
                )
            )
        <*> many
            ( strOption
                (long "with-session-key" <> help "session key for decryption")
            )
        <*> optional
            ( strOption
                (long "session-key-out" <> help "write recovered session key")
            )
        <*> many
            ( strOption
                (long "with-password" <> help "password for SKESK decryption")
            )
        <*> many
            ( strOption
                ( long "with-key-password"
                    <> help "password for unlocking decryption key material"
                )
            )
        <*> many (strArgument (metavar "KEY" <> help "secret key material"))
        <*> many
            ( strOption
                ( long "verify-with"
                    <> help "certificate(s) to verify signatures with"
                )
            )
        <*> optional
            ( strOption
                ( long "verifications-out"
                    <> help "write verification results to file"
                )
            )

inlineSignP :: Parser InlineSignOptions
inlineSignP =
    InlineSignOptions
        <$> switch (long "no-armor" <> help "output binary")
        <*> optional
            ( option
                (eitherReader inlineSignModeReader)
                (long "as" <> metavar "DATATYPE" <> inlineSignAsHelp)
            )
        <*> some (strArgument (metavar "KEY" <> help "signing key file(s)"))
        <*> many
            ( strOption
                ( long "with-key-password"
                    <> metavar "PASSWORD"
                    <> help "password for encrypted signing key"
                )
            )
  where
    inlineSignAsHelp =
        helpDoc . Just $
            pretty "what to treat the input as"
                <> softline
                <> list [pretty "binary", pretty "text", pretty "clearsigned"]

inlineDetachP :: Parser InlineDetachOptions
inlineDetachP =
    InlineDetachOptions
        <$> switch (long "no-armor" <> help "output binary")
        <*> strOption
            ( long "signatures-out"
                <> metavar "SIGNATURES"
                <> help "write detached signatures to file"
            )

mergeCertsP :: Parser MergeCertsOptions
mergeCertsP =
    MergeCertsOptions
        <$> switch (long "no-armor" <> help "output binary")
        <*> some
            ( strArgument
                (metavar "CERTS..." <> help "one or more certificate files")
            )

validateUserIdP :: Parser ValidateUserIdOptions
validateUserIdP =
    ValidateUserIdOptions
        <$> switch
            ( long "addr-spec-only"
                <> help
                    "match only the addr-spec portion of conventional OpenPGP User IDs"
            )
        <*> optional
            ( strOption
                ( long "validate-at"
                    <> metavar "DATE"
                    <> help "evaluate certifications at DATE"
                )
            )
        <*> argument str (metavar "USERID" <> help "user ID to validate")
        <*> some
            ( strArgument
                ( metavar "CERTS..."
                    <> help "one or more authority certificate files"
                )
            )

certifyUserIdP :: Parser CertifyUserIdOptions
certifyUserIdP =
    CertifyUserIdOptions
        <$> some
            ( strOption
                ( long "userid"
                    <> metavar "USERID"
                    <> help "user ID to certify (repeatable)"
                )
            )
        <*> switch
            ( long "no-armor"
                <> help "output binary"
            )
        <*> switch
            ( long "no-require-self-sig"
                <> help "allow certifying user IDs that do not have self-signatures"
            )
        <*> many
            ( strOption
                ( long "with-key-password"
                    <> help "password for unlocking signer key material"
                )
            )
        <*> some
            ( strArgument
                (metavar "KEYS..." <> help "one or more signer key files")
            )

revokeKeyP :: Parser RevokeKeyOptions
revokeKeyP =
    RevokeKeyOptions
        <$> switch (long "no-armor" <> help "output binary")
        <*> many
            ( strOption
                ( long "with-key-password"
                    <> help "password for unlocking secret key material"
                )
            )

updateKeyP :: Parser UpdateKeyOptions
updateKeyP =
    UpdateKeyOptions
        <$> switch (long "no-armor" <> help "output binary")
        <*> switch
            ( long "signing-only"
                <> help "limit updated material to signing-capable key material"
            )
        <*> switch
            ( long "revoke-deprecated-keys"
                <> help
                    "emit revocations for deprecated key material when supported"
            )
        <*> switch
            ( long "no-added-capabilities"
                <> help
                    "do not add capabilities beyond existing target key material"
            )
        <*> many
            ( strOption
                ( long "with-key-password"
                    <> help "password for unlocking key material"
                )
            )
        <*> many
            ( strOption
                ( long "merge-certs"
                    <> metavar "CERTS"
                    <> help "additional certificate files to merge into target keys"
                )
            )

changeKeyPasswordP :: Parser ChangeKeyPasswordOptions
changeKeyPasswordP =
    ChangeKeyPasswordOptions
        <$> switch (long "no-armor" <> help "output binary")
        <*> many
            ( strOption
                ( long "old-key-password"
                    <> help "password(s) used to unlock existing secret key material"
                )
            )
        <*> optional
            ( strOption
                ( long "new-key-password"
                    <> help "password used to protect rewritten secret key material"
                )
            )

dispatch :: POSIXTime -> Command -> IO ()
dispatch cpt cmd' = banner' stderr >> hFlush stderr >> dispatch' cpt cmd'
  where
    dispatch' _ (VersionC o') = doVersion o'
    dispatch' _ (ListProfilesC o') = doListProfiles o'
    dispatch' t (GenerateKeyC o) = doGenerateKey t o
    dispatch' _ (ChangeKeyPasswordC o) = doChangeKeyPassword o
    dispatch' _ (MergeCertsC o) = doMergeCerts o
    dispatch' t (ValidateUserIdC o) = doValidateUserId t o
    dispatch' t (CertifyUserIdC o) = doCertifyUserId t o
    dispatch' t (RevokeKeyC o) = doRevokeKey t o
    dispatch' t (UpdateKeyC o) = doUpdateKey t o
    dispatch' t (VerifyC o') = doVerify t o'
    dispatch' t (InlineVerifyC o') = doInlineVerify t o'
    dispatch' t (EncryptC o') = doEncrypt t o'
    dispatch' t (DecryptC o') = doDecrypt t o'
    dispatch' t (InlineSignC o') = doInlineSign t o'
    dispatch' t (InlineDetachC o') = doInlineDetach t o'
    dispatch' _ (ExtractCertC o) = doExtractCert o
    dispatch' t (SignC o) = doSign t o
    dispatch' _ (UnsupportedC c) =
        failWith
            UnsupportedSubcommand
            ("command not yet implemented: " ++ c)
    dispatch' _ DeArmorC = doDeArmor
    dispatch' _ ArmorC = doArmor

main :: IO ()
main = do
    hSetBuffering stderr LineBuffering
    args <- getArgs
    ensureKnownSubcommand knownSopSubcommands args
    cpt <- getPOSIXTime
    let result =
            execParserPure
                (prefs showHelpOnError)
                ( info
                    (helper <*> versioner "hop" <*> cliP)
                    ( headerDoc (Just (banner "hop"))
                        <> progDesc "hOpenPGP SOP Tool"
                        <> footerDoc (Just (warranty "hop"))
                    )
                )
                args
    case result of
        Success cliOptions -> do
            let _ = cliDebug cliOptions
            dispatch cpt (cliCommand cliOptions)
        Failure f -> do
            let (msg, ec) = renderFailure f "hop"
            case ec of
                ExitSuccess -> putStrLn msg >> exitSuccess
                ExitFailure 1
                    | "Invalid option" `isInfixOf` msg
                        || "Invalid argument" `isInfixOf` msg ->
                        hPutStrLn stderr msg >> exitWith (ExitFailure 37)
                    | otherwise ->
                        hPutStrLn stderr msg >> exitWith (ExitFailure 19)
                _ -> hPutStrLn stderr msg >> exitWith ec
        CompletionInvoked compl -> do
            progn <- getProgName
            msg <- execCompletion compl progn
            putStr msg
            exitSuccess

knownSopSubcommands :: [String]
knownSopSubcommands =
    [ "armor"
    , "dearmor"
    , "change-key-password"
    , "decrypt"
    , "encrypt"
    , "certify-userid"
    , "extract-cert"
    , "generate-key"
    , "inline-detach"
    , "inline-sign"
    , "inline-verify"
    , "list-profiles"
    , "merge-certs"
    , "revoke-key"
    , "sign"
    , "update-key"
    , "validate-userid"
    , "verify"
    , "version"
    ]

ensureKnownSubcommand :: [String] -> [String] -> IO ()
ensureKnownSubcommand knownSubcommands args =
    if any (`elem` ["-h", "--help", "--version"]) args
        then pure ()
        else case find (not . isPrefixOf "-") args of
            Just subcommand
                | subcommand `notElem` knownSubcommands ->
                    failWith
                        UnsupportedSubcommand
                        ("unsupported subcommand: " ++ subcommand)
            _ -> pure ()

cliP :: Parser CliOptions
cliP =
    CliOptions
        <$> switch (long "debug" <> help "emit more verbose output")
        <*> cmd

banner' :: Handle -> IO ()
banner' h =
    hPutDoc
        h
        (banner "hop" <> hardline <> warranty "hop" <> hardline)

data Vrf
    = Vrf
    { _vrfmsg :: String
    , _vrfmfpr :: Maybe Fingerprint
    }
    deriving (Eq, Generic, Show)

instance A.ToJSON Vrf

cmd :: Parser Command
cmd =
    hsubparser
        ( command
            "armor"
            (info (pure ArmorC) (progDesc "Armor stdin to stdout"))
            <> command
                "dearmor"
                (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout"))
            <> command
                "change-key-password"
                ( info
                    (ChangeKeyPasswordC <$> changeKeyPasswordP)
                    (progDesc "Update a key password")
                )
            <> command
                "decrypt"
                (info (DecryptC <$> decP) (progDesc "Decrypt a message"))
            <> command
                "encrypt"
                (info (EncryptC <$> encP) (progDesc "Encrypt a message"))
            <> command
                "certify-userid"
                ( info
                    (CertifyUserIdC <$> certifyUserIdP)
                    (progDesc "Certify user IDs in a certificate")
                )
            <> command
                "extract-cert"
                ( info
                    (ExtractCertC <$> ecoP)
                    ( progDesc
                        "Extract a certificate from a secret key and output it to stdout"
                    )
                )
            <> command
                "generate-key"
                ( info
                    (GenerateKeyC <$> gkoP)
                    (progDesc "Generate a secret key and output it to stdout")
                )
            <> command
                "inline-detach"
                ( info
                    (InlineDetachC <$> inlineDetachP)
                    (progDesc "Create inline detached signatures")
                )
            <> command
                "inline-sign"
                ( info
                    (InlineSignC <$> inlineSignP)
                    (progDesc "Create inline signatures")
                )
            <> command
                "inline-verify"
                ( info
                    (InlineVerifyC <$> ivoP)
                    (progDesc "Verify inline-signed data")
                )
            <> command
                "list-profiles"
                (info (ListProfilesC <$> lpoP) (progDesc "List SOP profiles"))
            <> command
                "merge-certs"
                ( info
                    (MergeCertsC <$> mergeCertsP)
                    (progDesc "Merge OpenPGP certificates")
                )
            <> command
                "revoke-key"
                ( info
                    (RevokeKeyC <$> revokeKeyP)
                    (progDesc "Create a key revocation certificate")
                )
            <> command
                "sign"
                ( info
                    (SignC <$> soP)
                    (progDesc "Create detached signatures and output them to stdout")
                )
            <> command
                "update-key"
                (info (UpdateKeyC <$> updateKeyP) (progDesc "Update key material"))
            <> command
                "validate-userid"
                ( info
                    (ValidateUserIdC <$> validateUserIdP)
                    (progDesc "Validate a certificate user ID")
                )
            <> command
                "verify"
                (info (VerifyC <$> voP) (progDesc "Verify signatures"))
            <> command
                "version"
                ( info
                    (VersionC <$> vopP)
                    (progDesc "output hop version to stdout")
                )
        )

doArmor :: IO ()
doArmor = do
    m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
    let lbs = BL.fromChunks m
        armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs
    if armoredAlready
        then BL.putStr lbs
        else do
            let label' = guessLabel (decodeAllPackets lbs) lbs
                a = Armor label' [] lbs
            BL.putStr $ AA.encodeLazy [a]
  where
    decodeAllPackets lbs = runGet (many Bin.get) lbs
    guessLabel [] _ = ArmorMessage
    guessLabel (pkt : _) lbs =
        case pkt of
            SignaturePkt _ ->
                if all isSignaturePacket (decodeAllPackets lbs)
                    then ArmorSignature
                    else ArmorMessage
            SecretKeyPkt _ _ -> ArmorPrivateKeyBlock
            PublicKeyPkt _ -> ArmorPublicKeyBlock
            _ -> ArmorMessage
    isSignaturePacket SignaturePkt {} = True
    isSignaturePacket _ = False

doVersion :: VersionOptions -> IO ()
doVersion VersionOptions {..} = do
    let selected = length (filter id [vBackend, vExtended, vSopSpec, vSopv])
    when (selected > 1) $
        failWith
            IncompatibleOptions
            "version: --backend, --extended, --sop-spec, and --sopv are mutually exclusive"
    when vBackend $
        putStrLn $
            "hOpenPGP " ++ HOV.version
    when vExtended $ do
        mapM_ putStrLn $
            [ "hop " ++ showVersion version
            , ""
            , "This is hop, from hopenpgp-tools " ++ showVersion version ++ ","
            , "built with hOpenPGP " ++ HOV.version
            ]
    when vSopSpec $
        putStrLn "draft-dkg-openpgp-stateless-cli-16"
    when vSopv $
        putStrLn "1.0"
    unless (vBackend || vExtended || vSopSpec || vSopv) $
        putStrLn $
            "hop " ++ showVersion version

gkoP :: Parser KeyGenOptions
gkoP =
    KeyGenOptions
        <$> switch (long "no-armor" <> help "don't armor the output")
        <*> optional
            ( strOption
                ( long "with-key-password"
                    <> help "password used to protect generated secret key material"
                )
            )
        <*> optional
            ( strOption
                ( long "profile"
                    <> metavar "PROFILE"
                    <> help
                        "key generation profile (default, rfc4880, compatibility, security, performance)"
                )
            )
        <*> switch
            (long "signing-only" <> help "generate signing-only key material")
        <*> many
            ( strArgument
                (metavar "USERID" <> help "User ID associated with this key")
            )

data KeyGenOptions
    = KeyGenOptions
    { noArmor :: Bool
    , keyPassword :: Maybe String
    , keyProfile :: Maybe String
    , keySigningOnly :: Bool
    , userIds :: [String]
    }

doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()
doGenerateKey pt KeyGenOptions {..} = do
    profile <- parseKeyGenProfile keyProfile
    password <- parseGenerateKeyPassword keyPassword
    let ts = ThirtyTwoBitTimeStamp (floor pt)
        -- UPSTREAM: hOpenPGP should expose a supported legacy secret-key
        -- re-encryption path so password-protected v4 key generation does not
        -- need to switch to the v6 protection format here.
        keyVersion =
            if isJust password && keyVersionForProfile profile == V4
                then V6
                else keyVersionForProfile profile
        primaryKeySpec = primaryKeySpecForProfile profile
    sk <- generateSecretKey ts keyVersion primaryKeySpec
    baseKey <-
        buildKeyWith sk $ do
            case userIds of
                (primaryUid : restUids) -> do
                    addUserId ts True (T.pack primaryUid)
                    mapM_ (addUserId ts False . T.pack) restUids
                [] -> pure ()
            addSubkeysForProfile ts keyVersion profile keySigningOnly
            newkey <- get
            return newkey
    s <-
        maybe
            (pure (SomeSecretTK baseKey))
            (`encryptTransferableSecretKey` (SomeSecretTK baseKey))
            password
    let lbs = runPut $ Bin.put (someTKToUnknown s)
    BL.putStr $
        if not noArmor
            then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs]
            else lbs

type KeyBuilder = StateT (TK 'SecretTK) IO

buildKeyWith :: SecretKey -> KeyBuilder a -> IO a
buildKeyWith sk a = evalStateT a (bareTK sk)
  where
    bareTK (SecretKey pkp ska) =
        TK
            { _tkPrimaryKey = KeyPktSecretPrimary pkp ska
            , _tkRevs = []
            , _tkUIDs = []
            , _tkUAts = []
            , _tkSubs = []
            }

data GeneratedKeySpec
    = GeneratedRSAKey Int
    | GeneratedEd25519Key
    | GeneratedX25519Key
    deriving (Eq)

generateSecretKey
    :: ThirtyTwoBitTimeStamp
    -> KeyVersion
    -> GeneratedKeySpec
    -> IO SecretKey
generateSecretKey ts keyVersion (GeneratedRSAKey bits) = do
    (pub, priv) <- liftIO $ RSA.generate bits 0x10001
    return $ SecretKey (pkp pub) (ska priv)
  where
    pkp pub = PKPayload keyVersion ts 0 RSA (RSAPubKey (RSA_PublicKey pub))
    ska priv = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey priv)) 0 -- FIXME: calculate checksum
generateSecretKey ts keyVersion GeneratedEd25519Key = do
    priv <- Ed25519.generateSecretKey
    let pub = Ed25519.toPublic priv
        pubBytes = BA.convert pub :: B.ByteString
        privBytes = BA.convert priv :: B.ByteString
    pure $
        SecretKey
            ( PKPayload
                keyVersion
                ts
                0
                (toFVal 27)
                ( EdDSAPubKey
                    EdSigningCurve25519
                    (NativeEPoint (EPoint (os2ip pubBytes)))
                )
            )
            (SUUnencrypted (EdDSAPrivateKey EdSigningCurve25519 privBytes) 0)
generateSecretKey ts keyVersion GeneratedX25519Key = do
    priv <- Curve25519.generateSecretKey
    let pub = Curve25519.toPublic priv
        pubBytes = BA.convert pub :: B.ByteString
        privBytes = BA.convert priv :: B.ByteString
    pure $
        SecretKey
            ( PKPayload
                keyVersion
                ts
                0
                X25519
                ( EdDSAPubKey
                    EdSigningCurve25519
                    (NativeEPoint (EPoint (os2ip pubBytes)))
                )
            )
            (SUUnencrypted (X25519PrivateKey privBytes) 0)

data KeyGenProfile
    = KeyGenRFC4880
    | KeyGenSecurity
    | KeyGenSigningOnly
    deriving (Eq)

keyGenProfiles :: [Profile KeyGenProfile]
keyGenProfiles =
    [ Profile
        "security"
        "Ed25519 signing key, X25519 encryption subkey"
        KeyGenSecurity
        ["default", "performance", "rfc9580"]
    , Profile
        "rfc4880"
        "RSA-4096 (v4 keys)"
        KeyGenRFC4880
        ["compatibility"]
    ]

resolveProfile :: String -> [Profile p] -> Maybe p
resolveProfile name profiles =
    lookup name [(profileName p, profileValue p) | p <- profiles]
        <|> profileValue
            <$> find (\p -> name `elem` profileAliases p) profiles

parseKeyGenProfile :: Maybe String -> IO KeyGenProfile
parseKeyGenProfile Nothing = pure KeyGenSecurity
parseKeyGenProfile (Just name) =
    case resolveProfile name keyGenProfiles of
        Just p -> pure p
        Nothing ->
            failWith
                UnsupportedProfile
                ("generate-key: unsupported profile " ++ name)

keyVersionForProfile :: KeyGenProfile -> KeyVersion
keyVersionForProfile KeyGenRFC4880 = V4
keyVersionForProfile KeyGenSecurity = V6
keyVersionForProfile KeyGenSigningOnly = V6

primaryKeySpecForProfile :: KeyGenProfile -> GeneratedKeySpec
primaryKeySpecForProfile KeyGenRFC4880 = GeneratedRSAKey 4096
primaryKeySpecForProfile _ = GeneratedEd25519Key

parseGenerateKeyPassword
    :: Maybe String -> IO (Maybe BL.ByteString)
parseGenerateKeyPassword Nothing = pure Nothing
parseGenerateKeyPassword (Just passwordFile) =
    Just
        <$> ( loadPasswordFromFile
                "generate-key"
                "--with-key-password"
                passwordFile
                >>= normalizeHumanReadablePassword
                    "generate-key"
                    "--with-key-password"
            )

loadPasswordFiles
    :: String -> String -> [String] -> IO [BL.ByteString]
loadPasswordFiles context optionName = mapM (loadPasswordFromFile context optionName)

loadPasswordFromFile
    :: String -> String -> FilePath -> IO BL.ByteString
loadPasswordFromFile context optionName path = do
    case stripPrefix "@ENV:" path of
        Just varName
            | null varName ->
                failWith
                    BadData
                    (context ++ ": empty environment variable name in " ++ optionName)
            | otherwise -> do
                envValue <- lookupEnv varName
                case envValue of
                    Nothing ->
                        failWith
                            MissingInput
                            ( context
                                ++ ": environment variable not found for "
                                ++ optionName
                                ++ ": "
                                ++ varName
                            )
                    Just envVal -> pure (BLC8.pack envVal)
        Nothing ->
            case stripPrefix "@FD:" path of
                Just fdSpec -> loadPasswordFromFD context optionName fdSpec
                Nothing ->
                    case path of
                        '@' : _ ->
                            failWith
                                UnsupportedSpecialPrefix
                                ( context
                                    ++ ": unsupported special prefix for "
                                    ++ optionName
                                    ++ ": "
                                    ++ path
                                )
                        _ -> do
                            exists <- doesFileExist path
                            unless exists $
                                failWith
                                    MissingInput
                                    ( context
                                        ++ ": password file does not exist for "
                                        ++ optionName
                                        ++ ": "
                                        ++ path
                                    )
                            BL.readFile path

loadPasswordFromFD
    :: String -> String -> String -> IO BL.ByteString
loadPasswordFromFD context optionName fdSpec =
    case readMaybe fdSpec :: Maybe Int of
        Just fdNum
            | fdNum >= 0 ->
                ( do
                    let fdPath = "/dev/fd/" ++ show fdNum
                    exists <- doesFileExist fdPath
                    unless exists $
                        failWith
                            MissingInput
                            ( context
                                ++ ": file descriptor not available for "
                                ++ optionName
                                ++ ": "
                                ++ fdSpec
                            )
                    contents <- BL.readFile fdPath
                    _ <- evaluate (BL.length contents)
                    pure contents
                )
                    `catch` ( \err ->
                                failWith
                                    MissingInput
                                    ( context
                                        ++ ": failed reading file descriptor for "
                                        ++ optionName
                                        ++ ": "
                                        ++ fdSpec
                                        ++ " ("
                                        ++ displayException (err :: IOException)
                                        ++ ")"
                                    )
                            )
            | otherwise ->
                failWith
                    BadData
                    ( context
                        ++ ": invalid file descriptor in "
                        ++ optionName
                        ++ ": "
                        ++ fdSpec
                    )
        _ ->
            failWith
                BadData
                ( context
                    ++ ": invalid file descriptor in "
                    ++ optionName
                    ++ ": "
                    ++ fdSpec
                )

loadInputFromFile
    :: String -> String -> FilePath -> IO BL.ByteString
loadInputFromFile context optionName path = do
    case stripPrefix "@ENV:" path of
        Just varName
            | null varName ->
                failWith
                    BadData
                    (context ++ ": empty environment variable name in " ++ optionName)
            | otherwise -> do
                envValue <- lookupEnv varName
                case envValue of
                    Nothing ->
                        failWith
                            MissingInput
                            ( context
                                ++ ": environment variable not found for "
                                ++ optionName
                                ++ ": "
                                ++ varName
                            )
                    Just envVal -> pure (BLC8.pack envVal)
        Nothing ->
            case stripPrefix "@FD:" path of
                Just fdSpec -> loadInputFromFD context optionName fdSpec
                Nothing ->
                    case path of
                        '@' : _ ->
                            failWith
                                UnsupportedSpecialPrefix
                                ( context
                                    ++ ": unsupported special prefix for "
                                    ++ optionName
                                    ++ ": "
                                    ++ path
                                )
                        _ -> do
                            exists <- doesFileExist path
                            unless exists $
                                failWith
                                    MissingInput
                                    ( context
                                        ++ ": file does not exist for "
                                        ++ optionName
                                        ++ ": "
                                        ++ path
                                    )
                            BL.readFile path

loadInputFromFD
    :: String -> String -> String -> IO BL.ByteString
loadInputFromFD context optionName fdSpec =
    case readMaybe fdSpec :: Maybe Int of
        Just fdNum
            | fdNum >= 0 ->
                ( do
                    let fdPath = "/dev/fd/" ++ show fdNum
                    exists <- doesFileExist fdPath
                    unless exists $
                        failWith
                            MissingInput
                            ( context
                                ++ ": file descriptor not available for "
                                ++ optionName
                                ++ ": "
                                ++ fdSpec
                            )
                    contents <- BL.readFile fdPath
                    _ <- evaluate (BL.length contents)
                    pure contents
                )
                    `catch` ( \err ->
                                failWith
                                    MissingInput
                                    ( context
                                        ++ ": failed reading file descriptor for "
                                        ++ optionName
                                        ++ ": "
                                        ++ fdSpec
                                        ++ " ("
                                        ++ displayException (err :: IOException)
                                        ++ ")"
                                    )
                            )
            | otherwise ->
                failWith
                    BadData
                    ( context
                        ++ ": invalid file descriptor in "
                        ++ optionName
                        ++ ": "
                        ++ fdSpec
                    )
        _ ->
            failWith
                BadData
                ( context
                    ++ ": invalid file descriptor in "
                    ++ optionName
                    ++ ": "
                    ++ fdSpec
                )

normalizeHumanReadablePassword
    :: String -> String -> BL.ByteString -> IO BL.ByteString
normalizeHumanReadablePassword context optionName passwordBytes =
    case TE.decodeUtf8' (BL.toStrict passwordBytes) of
        Left _ ->
            failWith
                PasswordNotHumanReadable
                ( context
                    ++ ": password is not human-readable UTF-8 for "
                    ++ optionName
                )
        Right txt ->
            pure
                (BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt)))

passwordRetryCandidates :: BL.ByteString -> [BL.ByteString]
passwordRetryCandidates passwordBytes =
    case TE.decodeUtf8' (BL.toStrict passwordBytes) of
        Left _ -> [passwordBytes]
        Right txt ->
            let trimmed = BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt))
             in if trimmed == passwordBytes
                    then [passwordBytes]
                    else [passwordBytes, trimmed]

addSubkeysForProfile
    :: ThirtyTwoBitTimeStamp
    -> KeyVersion
    -> KeyGenProfile
    -> Bool
    -> KeyBuilder ()
addSubkeysForProfile ts keyVersion _profile signingOnly = do
    addSubkey ts keyVersion _profile [SignDataKey]
    unless signingOnly $ do
        addSubkey
            ts
            keyVersion
            _profile
            [EncryptStorageKey, EncryptCommunicationsKey]
        addSubkey ts keyVersion _profile [AuthKey]

subkeySpecForProfile
    :: KeyGenProfile -> [KeyFlag] -> GeneratedKeySpec
subkeySpecForProfile KeyGenRFC4880 _ = GeneratedRSAKey 4096
subkeySpecForProfile _ keyflags
    | any
        (`elem` keyflags)
        [EncryptStorageKey, EncryptCommunicationsKey] =
        GeneratedX25519Key
    | otherwise = GeneratedEd25519Key

encryptTransferableSecretKey
    :: BL.ByteString -> SomeTK -> IO SomeTK
encryptTransferableSecretKey password stk =
    case stk of
        SomePublicTK _ -> pure stk
        SomeSecretTK tk ->
            case _tkPrimaryKey tk of
                KeyPktSecretPrimary pkp ska -> do
                    encrypted <- encryptSecretAddendumForOutput pkp ska
                    subs' <- mapM encryptSub (_tkSubs tk)
                    pure $
                        SomeSecretTK
                            tk
                                { _tkPrimaryKey = KeyPktSecretPrimary pkp encrypted
                                , _tkSubs = subs'
                                }
                _ -> pure stk
  where
    encryptSub
        :: (MonadIO m, MonadRandom m) => (KeyPkt k, b) -> m (KeyPkt k, b)
    encryptSub (KeyPktSecretSubkey pkp ska, sigs) = do
        encrypted <- liftIO $ encryptSecretAddendumForOutput pkp ska
        pure (KeyPktSecretSubkey pkp encrypted, sigs)
    encryptSub other = pure other
    encryptSecretAddendumForOutput pkp ska =
        case ska of
            SUUnencrypted skey _ -> doEncryptSecret skey
            _ -> pure ska
      where
        doEncryptSecret skey = do
            encryptedResult <-
                encryptSecretKeyWithPolicy
                    defaultPolicy
                    pkp
                    skey
                    (Passphrase password)
            case encryptedResult of
                Left err ->
                    failWith
                        BadData
                        ( "generate-key: failed to protect secret key material: "
                            ++ show err
                        )
                Right val -> pure val

rsaSigningKey :: SKAddendum -> IO RSA.PrivateKey
rsaSigningKey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) =
    pure (k {RSA.private_p = 0, RSA.private_q = 0})
rsaSigningKey _ =
    failWith
        BadData
        "generate-key: unsupported secret key format for RSA signing"

issuerSubpacketsFor
    :: String -> SomePKPayload -> IO [SigSubPacket]
issuerSubpacketsFor context pkp =
    case _keyVersion pkp of
        V6 -> pure []
        _ ->
            case eightOctetKeyID pkp of
                Left err ->
                    failWith
                        BadData
                        (context ++ ": could not derive issuer key id: " ++ show err)
                Right keyId -> pure [SigSubPacket False (Issuer keyId)]

addUserId
    :: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder ()
addUserId ts primary userid = do
    tk <- get
    let pkp = keyPktPKPayload (_tkPrimaryKey tk)
        ska :: SKAddendum
        ska = case _tkPrimaryKey tk of
            KeyPktSecretPrimary _ ska' -> ska'
            _ -> error "addUserId: expected secret primary key"
    signed <- selfsign pkp ska userid
    modify (newUID signed)
  where
    newUID signed tk = tk {_tkUIDs = _tkUIDs tk ++ [signed]}
    selfsign pkp ska u = do
        issuer <- liftIO (unhashed pkp)
        sig <-
            liftIO $
                signWithKey
                    "generate-key"
                    pkp
                    PositiveCert
                    SHA512
                    (hashed pkp)
                    issuer
                    (userIdPayloadForSigning pkp (UserId u))
                    (Just ska)
        pure (u, [sig])
    hashed pkp =
        [ SigSubPacket False (SigCreationTime ts)
        , SigSubPacket
            False
            ( IssuerFingerprint
                (issuerFingerprintVersionFor pkp)
                (fingerprint pkp)
            )
        , SigSubPacket False (KeyFlags (S.singleton CertifyKeysKey))
        , SigSubPacket False (PrimaryUserId primary)
        , SigSubPacket
            False
            (PreferredHashAlgorithms [SHA512, SHA256, SHA384, SHA224])
        , SigSubPacket
            False
            (PreferredSymmetricAlgorithms [AES256, AES192, AES128])
        ]
    unhashed = issuerSubpacketsFor "generate-key"

addSubkey
    :: ThirtyTwoBitTimeStamp
    -> KeyVersion
    -> KeyGenProfile
    -> [KeyFlag]
    -> KeyBuilder ()
addSubkey ts keyVersion profile keyflags = do
    tk <- get
    (SecretKey subpkp subska) <-
        liftIO $
            generateSecretKey
                ts
                keyVersion
                (subkeySpecForProfile profile keyflags)
    let pkp = keyPktPKPayload (_tkPrimaryKey tk)
        ska :: SKAddendum
        ska = case _tkPrimaryKey tk of
            KeyPktSecretPrimary _ ska' -> ska'
            _ -> error "addSubkey: expected secret primary key"
    issuerPrimary <- liftIO (unhashed pkp)
    issuerSub <- liftIO (unhashed subpkp)
    embeddedBacksig <-
        if SignDataKey `elem` keyflags
            then
                Just
                    <$> liftIO
                        ( signWithKey
                            "generate-key"
                            subpkp
                            PrimaryKeyBindingSig
                            SHA512
                            (hashed subpkp)
                            issuerSub
                            (subkeyPayloadForSigning pkp subpkp)
                            (Just subska)
                        )
            else pure Nothing
    bindingSig <-
        liftIO $
            signWithKey
                "generate-key"
                pkp
                SubkeyBindingSig
                SHA512
                (hashedwithflags pkp)
                ( maybe
                    issuerPrimary
                    ( \sig -> SigSubPacket False (EmbeddedSignature sig) : issuerPrimary
                    )
                    embeddedBacksig
                )
                (subkeyPayloadForSigning pkp subpkp)
                (Just ska)
    modify (addIt subpkp subska bindingSig)
  where
    addIt sp ss binding tk =
        tk
            { _tkSubs = _tkSubs tk ++ [(KeyPktSecretSubkey sp ss, [binding])]
            }
    hashed pkp =
        [ SigSubPacket False (SigCreationTime ts)
        , SigSubPacket
            False
            ( IssuerFingerprint
                (issuerFingerprintVersionFor pkp)
                (fingerprint pkp)
            )
        ]
    hashedwithflags pkp =
        hashed pkp
            ++ [SigSubPacket False (KeyFlags (S.fromList keyflags))]
    unhashed = issuerSubpacketsFor "generate-key"

putKeyForSigning :: SomePKPayload -> Bin.Put
putKeyForSigning pkp@(PKPayload V6 _ _ _ _) = do
    putWord8 0x9A
    let bs = runPut (Bin.put pkp)
    putWord32be (fromIntegral (BL.length bs))
    putLazyByteString bs
putKeyForSigning pkp = do
    putWord8 0x99
    let bs = runPut (Bin.put pkp)
    putWord16be (fromIntegral (BL.length bs))
    putLazyByteString bs

putUserIdForSigning :: UserId -> Bin.Put
putUserIdForSigning (UserId u) = do
    let bs = TE.encodeUtf8 u
    putWord8 0xB4
    putWord32be (fromIntegral (B.length bs))
    putByteString bs

userIdPayloadForSigning
    :: SomePKPayload -> UserId -> BL.ByteString
userIdPayloadForSigning pkp uid =
    runPut $ do
        putKeyForSigning pkp
        putUserIdForSigning uid

subkeyPayloadForSigning
    :: SomePKPayload -> SomePKPayload -> BL.ByteString
subkeyPayloadForSigning primary sub =
    runPut $ do
        putKeyForSigning primary
        putKeyForSigning sub

issuerFingerprintVersionFor
    :: SomePKPayload -> IssuerFingerprintVersion
issuerFingerprintVersionFor pkp =
    case _keyVersion pkp of
        V6 -> IssuerFingerprintV6
        _ -> IssuerFingerprintV4

ecoP :: Parser ExtractCertOptions
ecoP =
    ExtractCertOptions
        <$> switch (long "no-armor" <> help "don't armor the output")

data ExtractCertOptions
    = ExtractCertOptions
    { ecNoArmor :: Bool
    }

doExtractCert :: ExtractCertOptions -> IO ()
doExtractCert ExtractCertOptions {..} = do
    kbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
    let lbs = BL.fromChunks kbs
    pkts <- decodeOpenPGPInput "stdin" lbs
    tks <-
        runConduitRes $
            CL.sourceList pkts
                .| conduitToSomeTKsDroppingEither
                .| conduitDropErrorsAndNothings
                .| CC.sinkList
    when (null tks) $
        failWith
            MissingInput
            "extract-cert: no transferable secret key found on standard input"
    let output = runPut $ mapM_ (Bin.put . someTKToUnknown . pubToSecret) tks
    BL.putStr $
        if not ecNoArmor
            then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
            else output
  where
    pubToSecret tk =
        case tk of
            SomeSecretTK _ -> SomePublicTK (someTKToPublicViewTK tk)
            SomePublicTK publicTk -> SomePublicTK publicTk

doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO ()
doChangeKeyPassword ChangeKeyPasswordOptions {..} = do
    input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
    packets <- decodeOpenPGPInput "stdin" input
    tks <-
        runConduitRes $
            CL.sourceList packets
                .| conduitToSomeTKsDroppingEither
                .| conduitDropErrorsAndNothings
                .| CC.sinkList
    when (null tks) $
        failWith
            MissingInput
            "change-key-password: no transferable secret key found on standard input"
    when (any (not . hasSecretKeyMaterial) tks) $
        failWith
            MissingInput
            "change-key-password: expected transferable secret key input on standard input"
    oldPasswordsRaw <-
        loadPasswordFiles
            "change-key-password"
            "--old-key-password"
            changeKeyPasswordOldPasswords
    let oldPasswords = concatMap passwordRetryCandidates oldPasswordsRaw
    newPassword <-
        parseChangeKeyPasswordNewPassword changeKeyPasswordNewPassword
    unlockedTks <-
        mapM
            ( unlockTransferableSecretKeyMaterial
                "change-key-password"
                "standard input"
                "--old-key-password"
                oldPasswords
            )
            tks
    rewrittenTks <-
        case newPassword of
            Just password -> mapM (encryptTransferableSecretKey password) unlockedTks
            Nothing -> pure unlockedTks
    let output = runPut (mapM_ (Bin.put . someTKToUnknown) rewrittenTks)
    BL.putStr $
        if changeKeyPasswordNoArmor || BL.null output
            then output
            else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output]

parseChangeKeyPasswordNewPassword
    :: Maybe String -> IO (Maybe BL.ByteString)
parseChangeKeyPasswordNewPassword Nothing = pure Nothing
parseChangeKeyPasswordNewPassword (Just passwordFile) =
    Just
        <$> ( loadPasswordFromFile
                "change-key-password"
                "--new-key-password"
                passwordFile
                >>= normalizeHumanReadablePassword
                    "change-key-password"
                    "--new-key-password"
            )

hasSecretKeyMaterial :: SomeTK -> Bool
hasSecretKeyMaterial tk =
    case tk of
        SomeSecretTK _ -> True
        SomePublicTK _ -> False

doValidateUserId :: POSIXTime -> ValidateUserIdOptions -> IO ()
doValidateUserId cpt ValidateUserIdOptions {..} = do
    authorityTks <-
        concat
            <$> mapM
                (loadCertTKsFromFile "validate-userid")
                validateUserIdAuthorityFiles
    validateAtTime <- verificationUpperBound cpt validateUserIdAt
    input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
    certPkts <- decodeOpenPGPInput "standard input" input
    certTks <-
        runConduitRes $
            CL.sourceList certPkts
                .| conduitToSomeTKsDroppingEither
                .| conduitDropErrorsAndNothings
                .| CC.sinkList
    when (null certTks) $
        failWith
            MissingInput
            "validate-userid: no certificate found on standard input"
    let targetUserId = T.pack validateUserIdString
    forM_ certTks $ \certTk ->
        when
            ( not
                ( certificateHasMatchingValidatedUserId
                    authorityTks
                    validateAtTime
                    validateUserIdAddrSpecOnly
                    targetUserId
                    certTk
                )
            )
            $ failWith
                CertUserIdNoMatch
                ( "validate-userid: certificate has no correctly bound user ID matching "
                    ++ validateUserIdString
                )

certificateHasMatchingValidatedUserId
    :: [SomeTK] -> Maybe UTCTime -> Bool -> Text -> SomeTK -> Bool
certificateHasMatchingValidatedUserId authorityTks validateAtTime addrSpecOnly targetUserId certTk =
    case verifyTKWithTyped
        defaultVerificationPolicy
        (certTk : authorityTks)
        validateAtTime
        certTk of
        Left _ -> False
        Right verifiedTk ->
            any matchingBoundUid (_tkUIDs (someTKToPublicViewTK verifiedTk))
  where
    matchingBoundUid (uid, sigs) =
        useridMatches addrSpecOnly targetUserId uid
            && any (signatureMatchesSigner certTk) sigs
            && any
                (\sig -> any (`signatureMatchesSigner` sig) authorityTks)
                sigs

useridMatches :: Bool -> Text -> Text -> Bool
useridMatches False targetUserId uid = uid == targetUserId
useridMatches True targetUserId uid =
    case conventionalAddrSpec uid of
        Just addrSpec -> addrSpec == targetUserId
        Nothing -> False

conventionalAddrSpec :: Text -> Maybe Text
conventionalAddrSpec uid =
    let (prefix, suffix) = T.breakOnEnd (T.pack "<") uid
     in if T.null prefix
            then Nothing
            else case T.unsnoc suffix of
                Just (addrSpec, '>')
                    | T.any (== '<') addrSpec -> Nothing
                    | otherwise -> guardNonEmpty (T.strip addrSpec)
                _ -> Nothing
  where
    guardNonEmpty text
        | T.null text = Nothing
        | otherwise = Just text

signatureMatchesSigner :: SomeTK -> SignaturePayload -> Bool
signatureMatchesSigner signer sig =
    maybe
        False
        (keyMatchesFingerprint False signer)
        (signatureIssuerFingerprint sig)
        || maybe
            False
            (keyMatchesEightOctetKeyId False signer . Right)
            (signatureIssuerKeyId sig)

signatureIssuerFingerprint
    :: SignaturePayload -> Maybe Fingerprint
signatureIssuerFingerprint =
    listToMaybe . mapMaybe getIssuerFingerprint . signatureSubpackets
  where
    getIssuerFingerprint (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) =
        Just issuerFingerprint
    getIssuerFingerprint _ = Nothing

signatureIssuerKeyId :: SignaturePayload -> Maybe EightOctetKeyId
signatureIssuerKeyId = listToMaybe . mapMaybe getIssuerKeyId . signatureSubpackets
  where
    getIssuerKeyId (SigSubPacket _ (Issuer issuerKeyId)) = Just issuerKeyId
    getIssuerKeyId _ = Nothing

signatureSubpackets :: SignaturePayload -> [SigSubPacket]
signatureSubpackets (SigV4 _ _ _ hashed unhashed _ _) = hashed ++ unhashed
signatureSubpackets (SigV6 _ _ _ _ hashed unhashed _ _) = hashed ++ unhashed
signatureSubpackets _ = []

doCertifyUserId :: POSIXTime -> CertifyUserIdOptions -> IO ()
doCertifyUserId _cpt CertifyUserIdOptions {..} = do
    signerPasswordsRaw <-
        loadPasswordFiles
            "certify-userid"
            "--with-key-password"
            certifyUserIdKeyPasswordFiles
    let signerPasswords = concatMap passwordRetryCandidates signerPasswordsRaw
    signerTks <-
        concat
            <$> mapM
                ( \p ->
                    loadCertifySignerTKsFromFile signerPasswords "certify-userid" p
                )
                certifyUserIdSignerFiles
    when (null signerTks) $
        failWith
            MissingInput
            "certify-userid: no signer certificate found"
    input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
    certPkts <- decodeOpenPGPInput "standard input" input
    targetTks <-
        runConduitRes $
            CL.sourceList certPkts
                .| conduitToSomeTKsDroppingEither
                .| conduitDropErrorsAndNothings
                .| CC.sinkList
    when (null targetTks) $
        failWith
            MissingInput
            "certify-userid: no certificate found on standard input"
    let targetUserIds = map T.pack certifyUserIds
        requireSelfSig = not certifyUserIdNoRequireSelfSig
    updatedTargets <-
        mapM
            ( \targetTk ->
                addUserIdCertifications
                    targetTk
                    targetUserIds
                    requireSelfSig
                    signerTks
            )
            targetTks
    let output = runPut (mapM_ (Bin.put . someTKToUnknown) updatedTargets)
    BL.putStr $
        if certifyUserIdNoArmor
            then output
            else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]

loadCertifySignerTKsFromFile
    :: [BL.ByteString] -> String -> String -> IO [SomeTK]
loadCertifySignerTKsFromFile signerPasswords context path = do
    lbs <- loadInputFromFile context "file" path
    packets <- decodeOpenPGPInput path lbs
    tks <-
        runConduitRes $
            CL.sourceList packets
                .| conduitToSomeTKsDroppingEither
                .| conduitDropErrorsAndNothings
                .| CC.sinkList
    let fallbackTks = signingFallbackTKs packets
    when (null tks && null fallbackTks) $
        failWith
            MissingInput
            ("certify-userid: no signer key material found in " ++ path)
    mapM
        ( unlockTransferableSecretKeyMaterial
            "certify-userid failed"
            path
            "--with-key-password"
            signerPasswords
        )
        (if null tks then fallbackTks else tks)

addUserIdCertifications
    :: SomeTK -> [Text] -> Bool -> [SomeTK] -> IO SomeTK
addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks = do
    forM_ targetUserIds $ \targetUserId ->
        case find
            ((== targetUserId) . fst)
            (_tkUIDs (someTKToPublicViewTK targetTk)) of
            Nothing ->
                failWith
                    CertUserIdNoMatch
                    ( "certify-userid: target certificate has no user ID matching "
                        ++ T.unpack targetUserId
                    )
            Just (_, sigs) ->
                when
                    ( requireSelfSig
                        && not (any (signatureMatchesSigner targetTk) sigs)
                    )
                    $ failWith
                        CertUserIdNoMatch
                        ( "certify-userid: target user ID has no self-signature: "
                            ++ T.unpack targetUserId
                        )
    newSigs <-
        concat
            <$> forM
                signerTks
                ( \signerTk ->
                    forM
                        targetUserIds
                        ( \targetUserId -> do
                            sig <- createUIDCertification targetUserId signerTk
                            pure (targetUserId, sig)
                        )
                )
    let updateUID (uid, sigs) =
            if uid `elem` targetUserIds
                then (uid, sigs ++ map snd (filter ((== uid) . fst) newSigs))
                else (uid, sigs)
    pure $ case targetTk of
        SomePublicTK tk -> SomePublicTK tk {_tkUIDs = map updateUID (_tkUIDs tk)}
        SomeSecretTK tk -> SomeSecretTK tk {_tkUIDs = map updateUID (_tkUIDs tk)}

createUIDCertification
    :: Text -> SomeTK -> IO SignaturePayload
createUIDCertification targetUserId signerTk = do
    signerSka <-
        case signerTk of
            SomeSecretTK secretTk ->
                case _tkPrimaryKey secretTk of
                    KeyPktSecretPrimary _ ska -> pure ska
                    _ ->
                        failWith
                            KeyCannotCertify
                            "certify-userid: signer certificate has no secret key material"
            SomePublicTK _ ->
                failWith
                    KeyCannotCertify
                    "certify-userid: signer certificate has no secret key material"
    let signerPkp =
            keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK signerTk))
    signingKey <- rsaSigningKey signerSka
    issuer <- issuerSubpacketsFor "certify-userid" signerPkp
    let hashed = [SigSubPacket False (SigCreationTime (_timestamp signerPkp))]
        certification =
            signUserIDwithRSA
                signerPkp
                (UserId targetUserId)
                hashed
                issuer
                signingKey
    case certification of
        Left err ->
            failWith
                BadData
                ("certify-userid: failed to create certification: " ++ show err)
        Right sig -> pure sig

doRevokeKey :: POSIXTime -> RevokeKeyOptions -> IO ()
doRevokeKey _cpt RevokeKeyOptions {..} = do
    keyPasswordsRaw <-
        loadPasswordFiles
            "revoke-key"
            "--with-key-password"
            revokeKeyPasswordFiles
    let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
    input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
    keyPkts <- decodeOpenPGPInput "standard input" input
    keyTks <-
        runConduitRes $
            CL.sourceList keyPkts
                .| conduitToSomeTKsDroppingEither
                .| conduitDropErrorsAndNothings
                .| CC.sinkList
    when (null keyTks) $
        failWith
            MissingInput
            "revoke-key: no key found on standard input"
    revocationSigPkts <-
        mapM (createKeyRevocation keyPasswords) keyTks
    let output = runPut (mapM_ Bin.put revocationSigPkts)
    BL.putStr $
        if revokeKeyNoArmor
            then output
            else AA.encodeLazy [Armor ArmorSignature [] output]
  where
    createKeyRevocation keyPasswords' keyTk = do
        unlockedTk <-
            unlockTransferableSecretKeyMaterial
                "revoke-key failed"
                "standard input"
                "--with-key-password"
                keyPasswords'
                keyTk
        (pkp, mSka) <-
            case unlockedTk of
                SomeSecretTK secretTk ->
                    pure $ case _tkPrimaryKey secretTk of
                        KeyPktSecretPrimary pkp ska -> (pkp, Just ska)
                        _ -> error "createKeyRevocation: unexpected primary key type"
                SomePublicTK publicTk ->
                    pure $ case _tkPrimaryKey publicTk of
                        KeyPktPublicPrimary pkp -> (pkp, Nothing)
                        _ -> error "createKeyRevocation: unexpected primary key type"
        ska <-
            case mSka of
                Just s -> pure s
                Nothing ->
                    failWith
                        KeyCannotCertify
                        "revoke-key: key has no secret key material"
        signingKey <- rsaSigningKey ska
        issuer <- issuerSubpacketsFor "revoke-key" pkp
        let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]
            revocation = signKeyRevocationWithRSA pkp hashed issuer signingKey
        case revocation of
            Left err ->
                failWith
                    BadData
                    ("revoke-key: failed to create revocation: " ++ show err)
            Right sig -> pure (SignaturePkt sig)

hasBadPrimaryKey :: SomeTK -> Bool
hasBadPrimaryKey stk =
    primaryKeyTooSmallForVerification stk
        || hasHardPrimaryKeyRevocation stk

hasHardPrimaryKeyRevocation :: SomeTK -> Bool
hasHardPrimaryKeyRevocation stk =
    any isHardKeyRevocation (_tkRevs (someTKToPublicViewTK stk))
  where
    isHardKeyRevocation sig = case sig of
        SigV4 KeyRevocationSig _ _ hashedSubs _ _ _ ->
            any hasHardReason hashedSubs
        SigV6 KeyRevocationSig _ _ _ hashedSubs _ _ _ ->
            any hasHardReason hashedSubs
        _ -> False
      where
        hasHardReason (SigSubPacket _ (ReasonForRevocation reason _)) =
            not (reason `elem` [KeySuperseded, KeyRetiredAndNoLongerUsed])
        hasHardReason _ = False

doUpdateKey :: POSIXTime -> UpdateKeyOptions -> IO ()
doUpdateKey cpt UpdateKeyOptions {..} = do
    keyPasswordsRaw <-
        loadPasswordFiles
            "update-key"
            "--with-key-password"
            updateKeyPasswordFiles
    let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
    when updateKeyRevokeDeprecatedKeys $
        hPutStrLn
            stderr
            "Warning: update-key: --revoke-deprecated-keys requested, but no deprecated-key detector is available; proceeding without synthetic revocations."
    stdinInput <-
        runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
    stdinPkts <- decodeOpenPGPInput "stdin" stdinInput
    stdinTks <-
        runConduitRes $
            CL.sourceList stdinPkts
                .| conduitToSomeTKsDroppingEither
                .| conduitDropErrorsAndNothings
                .| CC.sinkList
    when (null stdinTks) $
        failWith
            MissingInput
            "update-key: no key found on standard input"
    updateSourceTks <-
        concat
            <$> mapM
                (\p -> loadVerifyTKsFromFile "update-key" p)
                updateKeyMergeCerts
    when (null updateSourceTks) $
        failWith MissingInput "update-key: no update keys found"
    stdinUnlocked <-
        mapM
            (unlockUpdateKeyMaterial "standard input" keyPasswords)
            stdinTks
    when (any hasBadPrimaryKey stdinUnlocked) $
        failWith
            PrimaryKeyBad
            "update-key: primary key is too weak or hard-revoked"
    updateUnlocked <-
        mapM
            (unlockUpdateKeyMaterial "update input" keyPasswords)
            updateSourceTks
    let updateTks =
            if updateKeySigningOnly
                then filter (updateKeyHasSigningCapability cpt) updateUnlocked
                else updateUnlocked
    when (updateKeySigningOnly && null updateTks) $
        failWith
            MissingInput
            "update-key: no signing-capable update keys found"
    let updatedTks =
            map
                ( \targetTk ->
                    let mergedTkUnknown =
                            foldl'
                                (<>)
                                (someTKToUnknown targetTk)
                                ( map
                                    someTKToUnknown
                                    ( selectUpdateMergeInputs
                                        cpt
                                        updateKeyNoAddedCapabilities
                                        targetTk
                                        updateTks
                                    )
                                )
                     in case fromUnknownToTKEither mergedTkUnknown of
                            Right mergedStk -> mergedStk
                            Left _ -> targetTk
                )
                stdinUnlocked
        -- Choose armor type based on whether updated key has secret material
        armorType =
            if any hasSecretKeyMaterial updatedTks
                then ArmorPrivateKeyBlock
                else ArmorPublicKeyBlock
        output = runPut (mapM_ (Bin.put . someTKToUnknown) updatedTks)
    BL.putStr $
        if updateKeyNoArmor
            then output
            else AA.encodeLazy [Armor armorType [] output]

doMergeCerts :: MergeCertsOptions -> IO ()
doMergeCerts MergeCertsOptions {..} = do
    stdinInput <-
        runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
    stdinPkts <- decodeOpenPGPInput "stdin" stdinInput
    stdinTks <-
        runConduitRes $
            CL.sourceList stdinPkts
                .| conduitToSomeTKsDroppingEither
                .| conduitDropErrorsAndNothings
                .| CC.sinkList
    mergeInTks <-
        concat
            <$> mapM
                (\p -> loadVerifyTKsFromFile "merge-certs" p)
                mergeCertsFiles
    let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks
        output = runPut (mapM_ (Bin.put . someTKToUnknown) mergedTks)
    BL.putStr $
        if mergeCertsNoArmor || BL.null output
            then output
            else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]

mergeCertificatesForOutput
    :: [SomeTK] -> [SomeTK] -> [SomeTK]
mergeCertificatesForOutput stdinTks mergeInTks =
    map mergeGroup (groupByPrimaryKey stdinTks)
  where
    -- Upstream could expose this as a dedicated helper over TKWithWireRep
    -- so downstreams can keep packet provenance while merging certs.
    mergeGroup (base, rest) =
        let primary = certificatePrimaryFingerprint base
            mergedStdin =
                case fromUnknownToTKEither
                    (foldl' (<>) (someTKToUnknown base) (map someTKToUnknown rest)) of
                    Right mergedStk -> mergedStk
                    Left _ -> base
            matchingMergeInputs =
                filter ((== primary) . certificatePrimaryFingerprint) mergeInTks
            mergedAll =
                case fromUnknownToTKEither
                    ( foldl'
                        (<>)
                        (someTKToUnknown mergedStdin)
                        (map someTKToUnknown matchingMergeInputs)
                    ) of
                    Right mergedStk -> mergedStk
                    Left _ -> mergedStdin
         in mergedAll

groupByPrimaryKey :: [SomeTK] -> [(SomeTK, [SomeTK])]
groupByPrimaryKey [] = []
groupByPrimaryKey (tk : rest) =
    let primary = certificatePrimaryFingerprint tk
        (samePrimary, differentPrimary) =
            partition ((== primary) . certificatePrimaryFingerprint) rest
     in (tk, samePrimary) : groupByPrimaryKey differentPrimary

certificatePrimaryFingerprint :: SomeTK -> B.ByteString
certificatePrimaryFingerprint =
    BL.toStrict
        . unFingerprint
        . fingerprint
        . keyPktPKPayload
        . _tkPrimaryKey
        . someTKToPublicViewTK

unlockUpdateKeyMaterial
    :: String -> [BL.ByteString] -> SomeTK -> IO SomeTK
unlockUpdateKeyMaterial _ [] tk = pure tk
unlockUpdateKeyMaterial source keyPasswords tk =
    unlockTransferableSecretKeyMaterial
        "update-key failed"
        source
        "--with-key-password"
        keyPasswords
        tk

updateKeyHasSigningCapability :: POSIXTime -> SomeTK -> Bool
updateKeyHasSigningCapability cpt tk =
    any
        ( \funKey ->
            S.null (fkufs funKey) || S.member SignDataKey (fkufs funKey)
        )
        (tkToFunKeysAt cpt tk)

selectUpdateMergeInputs
    :: POSIXTime
    -> Bool
    -> SomeTK
    -> [SomeTK]
    -> [SomeTK]
selectUpdateMergeInputs cpt noAddedCaps targetTk updateTks =
    filteredByCaps
  where
    targetPrimary = certificatePrimaryFingerprint targetTk
    mergeCandidates =
        filter
            ((== targetPrimary) . certificatePrimaryFingerprint)
            updateTks
    targetCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt targetTk))
    addsCapabilities updateTk =
        let updateCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt updateTk))
         in not (S.null (updateCapabilities S.\\ targetCapabilities))
    filteredByCaps =
        if noAddedCaps
            then filter (not . addsCapabilities) mergeCandidates
            else mergeCandidates

soP :: Parser SignOptions
soP =
    SignOptions
        <$> switch (long "no-armor" <> help "don't armor the output")
        <*> optional
            ( strOption
                ( long "micalg-out"
                    <> metavar "MICALG"
                    <> help "write MIME micalg parameter value to file"
                )
            )
        <*> many
            ( strOption
                ( long "with-key-password"
                    <> help "password for unlocking signing key material"
                )
            )
        <*> option
            (eitherReader asTypeReader)
            (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)
        <*> some
            ( strArgument
                ( metavar "KEYS..."
                    <> help "paths to at least one secret key, one key per filename"
                )
            )
  where
    astypeHelp =
        helpDoc . Just $
            pretty "what to treat the input as"
                <> softline
                <> list (map (pretty . fst) asTypes)

data SignOptions
    = SignOptions
    { sNoArmor :: Bool
    , sMicalgOut :: Maybe String
    , sKeyPasswords :: [String]
    , sAs :: AsBinaryText
    , sKeyFiles :: [String]
    }

asTypes :: [(String, AsBinaryText)]
asTypes = [("binary", AsBinary), ("text", AsText)]

data AsBinaryText
    = AsBinary
    | AsText
    deriving (Eq)

data InlineSignMode
    = InlineSignAsBinary
    | InlineSignAsText
    | InlineSignAsClearSigned
    deriving (Eq)

data EncryptFor
    = EncryptForAny
    | EncryptForStorage
    | EncryptForCommunications
    deriving (Eq)

asTypeReader :: String -> Either String AsBinaryText
asTypeReader = note "unknown as type" . flip lookup asTypes

encryptForReader :: String -> Either String EncryptFor
encryptForReader "any" = Right EncryptForAny
encryptForReader "storage" = Right EncryptForStorage
encryptForReader "communications" = Right EncryptForCommunications
encryptForReader _ =
    Left
        "encryption purpose must be one of: any, storage, communications"

doSign :: POSIXTime -> SignOptions -> IO ()
doSign pt SignOptions {..} = do
    forM_ sMicalgOut (ensureOutputPathAvailable "sign")
    mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
    when (sAs == AsText) $
        ensureUTF8TextInput "sign" (BL.fromChunks mbs)
    forM_
        sMicalgOut
        (\_ -> ensureCanonicalMIMETextInput (BL.fromChunks mbs))
    signingPasswordsRaw <-
        loadPasswordFiles "sign" "--with-key-password" sKeyPasswords
    let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw
    ks <- loadSigningKeys "sign" sKeyFiles signingPasswords
    let ts = ThirtyTwoBitTimeStamp (floor pt)
        payload' = BL.fromChunks mbs
        payload = payload'
    processedKeys <- mapM (normalizeSigningKey pt) ks
    let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys
        signingHash =
            selectSigningHash
                (concat perTransferKeySigners)
                []
                legacySigningHashFallbackOrder
    when (any null perTransferKeySigners) $
        failWith
            KeyCannotSign
            "sign: supplied key cannot produce detached signatures"
    signatures <-
        mapM
            (signData sAs ts signingHash payload)
            (concat perTransferKeySigners)
    let output = runPut (mapM_ (Bin.put . SignaturePkt) signatures)
    case sMicalgOut of
        Just outPath ->
            writeFileWithOutputExistsCheck
                "sign"
                outPath
                (renderMicalg signatures)
        Nothing -> pure ()
    BL.putStr $
        if not sNoArmor
            then AA.encodeLazy [Armor ArmorSignature [] output]
            else output
  where
    signData
        :: AsBinaryText
        -> ThirtyTwoBitTimeStamp
        -> HashAlgorithm
        -> BL.ByteString
        -> FunKey
        -> IO SignaturePayload
    signData mode t signHash d k = do
        let st = case mode of
                AsBinary -> BinarySig
                AsText -> CanonicalTextSig
            payload = d
        issuerPackets <- unhashed (fpkp k)
        signWithKey
            "sign"
            (fpkp k)
            st
            signHash
            (hashed (fpkp k) t)
            issuerPackets
            payload
            (fmska k)
    hashed pkp ct =
        [ SigSubPacket False (SigCreationTime ct)
        , SigSubPacket
            False
            ( IssuerFingerprint
                (issuerFingerprintVersionFor pkp)
                (fingerprint pkp)
            )
        ]
    unhashed pkp = issuerSubpacketsFor "sign" pkp
loadSigningKeys
    :: String -> [String] -> [BL.ByteString] -> IO [SomeTK]
loadSigningKeys context keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles
  where
    loadFromFile path = do
        lbs <- loadInputFromFile context "file" path
        packets <- decodeOpenPGPInput path lbs
        tks <-
            runConduitRes $
                CL.sourceList packets
                    .| conduitToSomeTKsDroppingEither
                    .| conduitDropErrorsAndNothings
                    .| CC.sinkList
        let fallbackTks = signingFallbackTKs packets
        when (null tks && null fallbackTks) $
            failWith
                MissingInput
                ("sign: no secret key material found in " ++ path)
        mapM
            (decryptSigningKeyMaterial path keyPasswords)
            (if null tks then fallbackTks else tks)

decryptSigningKeyMaterial
    :: FilePath -> [BL.ByteString] -> SomeTK -> IO SomeTK
decryptSigningKeyMaterial path keyPasswords =
    unlockTransferableSecretKeyMaterial
        "sign failed"
        path
        "--with-key-password"
        keyPasswords

unlockTransferableSecretKeyMaterial
    :: String
    -> FilePath
    -> String
    -> [BL.ByteString]
    -> SomeTK
    -> IO SomeTK
-- Upstream could expose a TK-wide secret-key rewrite helper so SOP
-- subcommands do not need to walk primary and subkey packets separately.
unlockTransferableSecretKeyMaterial context path passwordOption keyPasswords stk = do
    case stk of
        SomePublicTK _ -> pure stk
        SomeSecretTK tk -> do
            let pkp = keyPktPKPayload (_tkPrimaryKey tk)
            ska' <-
                unlockSecretAddendum
                    context
                    path
                    passwordOption
                    keyPasswords
                    pkp
                    ( case _tkPrimaryKey tk of
                        KeyPktSecretPrimary _ ska -> ska
                        _ ->
                            error
                                "unlockTransferableSecretKeyMaterial: expected secret primary key"
                    )
            let primaryKey = KeyPktSecretPrimary pkp ska'
            subs' <- mapM decryptSub (_tkSubs tk)
            pure $
                SomeSecretTK tk {_tkPrimaryKey = primaryKey, _tkSubs = subs'}
  where
    decryptSub :: MonadIO m => (KeyPkt k, b) -> m (KeyPkt k, b)
    decryptSub (KeyPktSecretSubkey pkp ska, sigs) = do
        ska' <-
            unlockSecretAddendum
                context
                path
                passwordOption
                keyPasswords
                pkp
                ska
        pure (KeyPktSecretSubkey pkp ska', sigs)
    decryptSub other = pure other

unlockSecretAddendum
    :: MonadIO m
    => String
    -> FilePath
    -> String
    -> [BL.ByteString]
    -> SomePKPayload
    -> SKAddendum
    -> m SKAddendum
unlockSecretAddendum _ _ _ _ _ sk@(SUUnencrypted _ _) = pure sk
unlockSecretAddendum context path passwordOption [] _ _ =
    failWith
        KeyIsProtected
        ( context
            ++ ": encrypted key material in "
            ++ path
            ++ " requires "
            ++ passwordOption
        )
unlockSecretAddendum context path passwordOption keyPasswords pkp sk =
    case tryDecrypt keyPasswords of
        Right decrypted -> pure decrypted
        Left _ ->
            failWith
                KeyIsProtected
                ( context
                    ++ ": could not unlock key material in "
                    ++ path
                    ++ " with provided "
                    ++ passwordOption
                    ++ " values"
                )
  where
    tryDecrypt [] = Left ()
    tryDecrypt (password : rest) =
        case decryptPrivateKey (pkp, sk) password of
            Left _ -> tryDecrypt rest
            Right decrypted -> Right decrypted

normalizeSigningKey :: POSIXTime -> SomeTK -> IO SomeTK
normalizeSigningKey pt tk =
    case processTK (Just pt) tk of
        Left err ->
            failWith
                BadData
                ("sign: invalid signing key material: " ++ show err)
        Right normalized -> pure normalized

signPayloadWithKeys
    :: POSIXTime
    -> AsBinaryText
    -> BL.ByteString
    -> [SomeTK]
    -> [HashAlgorithm]
    -> [HashAlgorithm]
    -> IO [SignaturePayload]
signPayloadWithKeys pt asMode payload keys recipientHashPrefs fallbackOrder = do
    processedKeys <- mapM (normalizeSigningKey pt) keys
    let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys
        signingHash =
            selectSigningHash
                (concat perTransferKeySigners)
                recipientHashPrefs
                fallbackOrder
    when (any null perTransferKeySigners) $
        failWith
            KeyCannotSign
            "encrypt: supplied key cannot produce signatures"
    mapM
        (signData asMode ts signingHash payload)
        (concat perTransferKeySigners)
  where
    ts = ThirtyTwoBitTimeStamp (floor pt)
    signData
        :: AsBinaryText
        -> ThirtyTwoBitTimeStamp
        -> HashAlgorithm
        -> BL.ByteString
        -> FunKey
        -> IO SignaturePayload
    signData mode t signHash d' k = do
        let st = case mode of
                AsBinary -> BinarySig
                AsText -> CanonicalTextSig
            payload' = d'
        issuerPackets <- unhashed (fpkp k)
        signWithKey
            "encrypt"
            (fpkp k)
            st
            signHash
            (hashed (fpkp k) t)
            issuerPackets
            payload'
            (fmska k)
    hashed pkp ct =
        [ SigSubPacket False (SigCreationTime ct)
        , SigSubPacket
            False
            ( IssuerFingerprint
                (issuerFingerprintVersionFor pkp)
                (fingerprint pkp)
            )
        ]
    unhashed pkp = issuerSubpacketsFor "encrypt" pkp

signingCapableFunKeys :: POSIXTime -> SomeTK -> [FunKey]
signingCapableFunKeys pt =
    filter canSign . tkToFunKeysAt pt
  where
    canSign k =
        canSignDataUsage (fkufs k)
            && case fmska k of
                Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True
                Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True
                Just (SUUnencrypted (UnknownSKey _) _) ->
                    isEd25519PKA (_pkalgo (fpkp k))
                        || isEdDSAPKA (_pkalgo (fpkp k))
                        || isEd448PKA (_pkalgo (fpkp k))
                _ -> False
    canSignDataUsage keyFlags = S.null keyFlags || S.member SignDataKey keyFlags

-- Legacy alias kept for internal call sites that have not been updated.
signingCapableRSAFunKeys :: POSIXTime -> SomeTK -> [FunKey]
signingCapableRSAFunKeys = signingCapableFunKeys

{- | Algorithm-dispatching signature helper used by all sign paths.
Supports RSA (v4), Ed25519 (v4), and Ed448 (v4).
-}
signWithKey
    :: String
    -- ^ context for error messages
    -> SomePKPayload
    -> SigType
    -> HashAlgorithm
    -> [SigSubPacket]
    -- ^ hashed subpackets
    -> [SigSubPacket]
    -- ^ unhashed subpackets
    -> BL.ByteString
    -- ^ payload to sign
    -> Maybe SKAddendum
    -> IO SignaturePayload
signWithKey ctx signerPKP st signHash hsd usd payload mska =
    case mska of
        Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) ->
            validateRSASigningKeySize ctx signerPKP
                >> if _keyVersion signerPKP == V6
                    then signRSAWithV6Salt (k {RSA.private_p = 0, RSA.private_q = 0})
                    else
                        signWithRSABuilder
                            signHash
                            (k {RSA.private_p = 0, RSA.private_q = 0})
        Just
            (SUUnencrypted (EdDSAPrivateKey EdSigningCurve25519 rawBytes) _) ->
                case eitherCryptoError (Ed25519.secretKey rawBytes) of
                    Left err ->
                        failWith
                            BadData
                            (ctx ++ " failed: bad Ed25519 secret key: " ++ show err)
                    Right sk
                        | _keyVersion signerPKP == V6 -> signEd25519 sk
                        | isEdDSAPKA (_pkalgo signerPKP) ->
                            case signDataWithEd25519Legacy st sk hsd usd payload of
                                Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
                                Right sig -> pure sig
                        | otherwise ->
                            case signDataWithEd25519 st sk hsd usd payload of
                                Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
                                Right sig -> pure sig
        Just
            (SUUnencrypted (EdDSAPrivateKey EdSigningCurve448 rawBytes) _) ->
                case eitherCryptoError (Ed448.secretKey rawBytes) of
                    Left err ->
                        failWith
                            BadData
                            (ctx ++ " failed: bad Ed448 secret key: " ++ show err)
                    Right sk
                        | _keyVersion signerPKP == V6 -> signEd448 sk
                        | otherwise ->
                            case signDataWithEd448 st sk hsd usd payload of
                                Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
                                Right sig -> pure sig
        Just (SUUnencrypted (UnknownSKey rawBytes) _) ->
            case () of
                _
                    | isEd25519PKA (_pkalgo signerPKP) ->
                        do
                            normalized <- normalizeUnknownSecretForEdDSA ctx 32 rawBytes
                            case eitherCryptoError (Ed25519.secretKey normalized) of
                                Left err ->
                                    failWith
                                        BadData
                                        (ctx ++ " failed: bad Ed25519 secret key: " ++ show err)
                                Right sk
                                    | _keyVersion signerPKP == V6 -> signEd25519 sk
                                    | isEdDSAPKA (_pkalgo signerPKP) ->
                                        case signDataWithEd25519Legacy st sk hsd usd payload of
                                            Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
                                            Right sig -> pure sig
                                    | otherwise ->
                                        case signDataWithEd25519 st sk hsd usd payload of
                                            Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
                                            Right sig -> pure sig
                    | isEd448PKA (_pkalgo signerPKP) ->
                        do
                            normalized <- normalizeUnknownSecretForEdDSA ctx 57 rawBytes
                            case eitherCryptoError (Ed448.secretKey normalized) of
                                Left err ->
                                    failWith
                                        BadData
                                        (ctx ++ " failed: bad Ed448 secret key: " ++ show err)
                                Right sk
                                    | _keyVersion signerPKP == V6 -> signEd448 sk
                                    | otherwise ->
                                        case signDataWithEd448 st sk hsd usd payload of
                                            Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
                                            Right sig -> pure sig
                _ ->
                    failWith
                        UnsupportedAsymmetricAlgo
                        ( ctx
                            ++ " failed: unsupported unknown signing key for algorithm "
                            ++ show (_pkalgo signerPKP)
                        )
        _ ->
            failWith
                BadData
                (ctx ++ " failed: unsupported or encrypted signing key")
  where
    signEd25519 sk =
        signWithV6Salt
            (\salt -> signDataWithEd25519V6 st salt sk hsd usd payload)
    signEd448 sk =
        signWithV6Salt
            (\salt -> signDataWithEd448V6 st salt sk hsd usd payload)
    signRSAWithV6Salt privateKey =
        signWithV6Salt
            (\salt -> signDataWithRSAV6 st salt privateKey hsd usd payload)
    signWithV6Salt signer = go [32, 64, 16, 20, 28, 48] []
      where
        go [] _ =
            failWith
                BadData
                (ctx ++ " failed: unable to construct a valid v6 signature salt")
        go (n : rest) tried = do
            bytes <- getRandomBytes n
            case signer (SignatureSalt (BL.fromStrict bytes)) of
                Right sig -> pure sig
                Left (SignV6SaltSizeMismatch _ expected _) ->
                    let expectedLen = fromIntegral expected
                     in if expectedLen `elem` tried
                            then
                                failWith
                                    BadData
                                    (ctx ++ " failed: unable to resolve v6 signature salt size")
                            else go (expectedLen : rest) (expectedLen : tried)
                Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)
    signWithRSABuilder hashToUse privateKey =
        let builder =
                SP.addUnhashedSubs
                    (SubpacketList usd)
                    ( SP.addHashedSubs
                        (SubpacketList hsd)
                        (SP.sigBuilderInit st hashToUse)
                    )
         in case signDataWithRSABuilder builder privateKey payload of
                Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)
                Right sig -> pure sig

normalizeUnknownSecretForEdDSA
    :: String -> Int -> BL.ByteString -> IO B.ByteString
normalizeUnknownSecretForEdDSA ctx expectedLen rawLbs
    | B.length raw == expectedLen = pure raw
    | B.length raw >= 2 =
        let bits =
                (fromIntegral (B.index raw 0) `shiftL` 8)
                    .|. fromIntegral (B.index raw 1)
            mpiBytes = (bits + 7) `div` 8
            payload = B.drop 2 raw
         in if B.length payload == mpiBytes && mpiBytes <= expectedLen
                then pure (i2ospOf_ expectedLen (os2ip payload))
                else bad
    | otherwise = bad
  where
    raw = BL.toStrict rawLbs
    bad =
        failWith
            BadData
            ( ctx
                ++ " failed: unsupported EdDSA secret key encoding (length="
                ++ show (B.length raw)
                ++ ")"
            )

validateRSASigningKeySize :: String -> SomePKPayload -> IO ()
validateRSASigningKeySize ctx signerPKP =
    case pubkeySize (_pubkey signerPKP) of
        Right bits
            | bits < 2048 ->
                failWith
                    KeyCannotSign
                    ( ctx
                        ++ " failed: RSA signing keys smaller than 2048 bits are not supported"
                    )
            | otherwise -> pure ()
        Left err ->
            failWith
                BadData
                (ctx ++ " failed: unable to determine RSA key size: " ++ err)

-- FIXME: clean this up
isEd25519PKA, isEd448PKA, isEdDSAPKA :: PubKeyAlgorithm -> Bool
isEd25519PKA pka = fromFVal pka == 27
isEdDSAPKA pka = fromFVal pka == 22
isEd448PKA pka = fromFVal pka == 28

selectSigningHash
    :: [FunKey] -> [HashAlgorithm] -> [HashAlgorithm] -> HashAlgorithm
selectSigningHash signerKeys recipientHashPrefs fallbackOrder =
    fromMaybe
        SHA512
        (find (hashSupportedByAllSigners signerKeys) candidateOrder)
  where
    requestedPrefs =
        if null recipientHashPrefs
            then signerPrefs
            else recipientHashPrefs
    signerPrefs = concatMap fpreferredHashes signerKeys
    filteredRequested = filter (hashSupportedByAllSigners signerKeys) requestedPrefs
    filteredSignerPrefs = filter (hashSupportedByAllSigners signerKeys) signerPrefs
    candidateOrder = filteredRequested ++ filteredSignerPrefs ++ fallbackOrder

legacySigningHashFallbackOrder :: [HashAlgorithm]
legacySigningHashFallbackOrder = [SHA512, SHA384, SHA256, SHA224]

rfc9580SigningHashFallbackOrder :: [HashAlgorithm]
rfc9580SigningHashFallbackOrder = [SHA3_512, SHA3_256, SHA512, SHA384, SHA256, SHA224]

hashSupportedByAllSigners :: [FunKey] -> HashAlgorithm -> Bool
hashSupportedByAllSigners signers ha =
    not (isDeprecatedHashAlgorithm ha)
        && all (`signerSupportsHashAlgorithm` ha) signers

signerSupportsHashAlgorithm :: FunKey -> HashAlgorithm -> Bool
signerSupportsHashAlgorithm signer ha =
    not (isDeprecatedHashAlgorithm ha)
        && case _pkalgo (fpkp signer) of
            RSA -> rsaPKCS15SupportedHash ha
            DeprecatedRSASignOnly -> rsaPKCS15SupportedHash ha
            DeprecatedRSAEncryptOnly -> rsaPKCS15SupportedHash ha
            _ -> not (isOtherHashAlgorithm ha)

rsaPKCS15SupportedHash :: HashAlgorithm -> Bool
rsaPKCS15SupportedHash SHA224 = True
rsaPKCS15SupportedHash SHA256 = True
rsaPKCS15SupportedHash SHA384 = True
rsaPKCS15SupportedHash SHA512 = True
rsaPKCS15SupportedHash _ = False

isDeprecatedHashAlgorithm :: HashAlgorithm -> Bool
isDeprecatedHashAlgorithm DeprecatedMD5 = True
isDeprecatedHashAlgorithm SHA1 = True
isDeprecatedHashAlgorithm RIPEMD160 = True
isDeprecatedHashAlgorithm _ = False

isOtherHashAlgorithm :: HashAlgorithm -> Bool
isOtherHashAlgorithm (OtherHA _) = True
isOtherHashAlgorithm _ = False

hashAlgorithmHeaderName :: HashAlgorithm -> String
hashAlgorithmHeaderName DeprecatedMD5 = "MD5"
hashAlgorithmHeaderName SHA1 = "SHA1"
hashAlgorithmHeaderName RIPEMD160 = "RIPEMD160"
hashAlgorithmHeaderName SHA224 = "SHA224"
hashAlgorithmHeaderName SHA256 = "SHA256"
hashAlgorithmHeaderName SHA384 = "SHA384"
hashAlgorithmHeaderName SHA512 = "SHA512"
hashAlgorithmHeaderName SHA3_256 = "SHA3-256"
hashAlgorithmHeaderName SHA3_512 = "SHA3-512"
hashAlgorithmHeaderName (OtherHA _) = "SHA512"

ensureCanonicalMIMETextInput :: BL.ByteString -> IO ()
ensureCanonicalMIMETextInput lbs = do
    let bs = BL.toStrict lbs
    when (B.any (> 0x7f) bs) $
        failWith
            ExpectedText
            "sign: --micalg-out requires canonical 7-bit text data on standard input"
    case TE.decodeUtf8' bs of
        Left _ ->
            failWith
                ExpectedText
                "sign: --micalg-out requires UTF-8 text data on standard input"
        Right _ -> pure ()
    when (not (canonicalCRLFLineEndings bs)) $
        failWith
            ExpectedText
            "sign: --micalg-out requires CRLF line endings on standard input"
    when (hasTrailingLineWhitespace bs) $
        failWith
            ExpectedText
            "sign: --micalg-out requires no trailing line whitespace on standard input"
  where
    canonicalCRLFLineEndings bytes = go (B.unpack bytes)
      where
        go [] = True
        go [13] = False
        go (13 : 10 : rest) = go rest
        go (13 : _) = False
        go (10 : _) = False
        go (_ : rest) = go rest
    hasTrailingLineWhitespace bytes =
        endsWithWhitespace bytes
            || trailingWhitespaceBeforeCRLF (B.unpack bytes)
    endsWithWhitespace bytes =
        case B.unsnoc bytes of
            Just (_, c) -> c == 32 || c == 9
            Nothing -> False
    trailingWhitespaceBeforeCRLF (a : 13 : 10 : rest)
        | a == 32 || a == 9 = True
        | otherwise = trailingWhitespaceBeforeCRLF (13 : 10 : rest)
    trailingWhitespaceBeforeCRLF (_ : rest) = trailingWhitespaceBeforeCRLF rest
    trailingWhitespaceBeforeCRLF _ = False

ensureUTF8TextInput :: String -> BL.ByteString -> IO ()
ensureUTF8TextInput subcommand lbs =
    case TE.decodeUtf8' (BL.toStrict lbs) of
        Left _ ->
            failWith
                ExpectedText
                (subcommand ++ ": --as=text requires UTF-8 text on standard input")
        Right _ -> pure ()

renderMicalg :: [SignaturePayload] -> String
renderMicalg signatures =
    case nub (mapMaybe signatureMicalg signatures) of
        [micalg] -> micalg
        _ -> ""
  where
    signatureMicalg (SigV4 _ _ ha _ _ _ _) = hashAlgorithmMicalg ha
    signatureMicalg _ = Nothing
    hashAlgorithmMicalg DeprecatedMD5 = Just "pgp-md5"
    hashAlgorithmMicalg SHA1 = Just "pgp-sha1"
    hashAlgorithmMicalg RIPEMD160 = Just "pgp-ripemd160"
    hashAlgorithmMicalg SHA224 = Just "pgp-sha224"
    hashAlgorithmMicalg SHA256 = Just "pgp-sha256"
    hashAlgorithmMicalg SHA384 = Just "pgp-sha384"
    hashAlgorithmMicalg SHA512 = Just "pgp-sha512"
    hashAlgorithmMicalg SHA3_256 = Just "pgp-sha3-256"
    hashAlgorithmMicalg SHA3_512 = Just "pgp-sha3-512"
    hashAlgorithmMicalg (OtherHA _) = Nothing

signingFallbackTKs :: [Pkt] -> [SomeTK]
signingFallbackTKs packets =
    [ SomeSecretTK
        TK
            { _tkPrimaryKey = KeyPktSecretPrimary pkp ska
            , _tkRevs = []
            , _tkUIDs = []
            , _tkUAts = []
            , _tkSubs = []
            }
    | SecretKeyPkt pkp ska <- packets
    ]

data FunKey
    = FunKey
    { fpkp :: SomePKPayload
    , fmska :: Maybe SKAddendum
    , fkufs :: S.Set KeyFlag
    , fpreferredHashes :: [HashAlgorithm]
    , fpreferredSymmetricAlgorithms :: [SymmetricAlgorithm]
    , fsupportsSEIPDv2 :: Bool
    }
    deriving (Show)

tkToFunKeysAt :: POSIXTime -> SomeTK -> [FunKey]
tkToFunKeysAt pt stk =
    catMaybes
        ( mainKey : case stk of
            SomePublicTK _ -> map extractPublic (_tkSubs publicView)
            SomeSecretTK secretTk -> map extractSecret (_tkSubs secretTk)
        )
  where
    publicView = someTKToPublicViewTK stk
    pkp = keyPktPKPayload (_tkPrimaryKey publicView)
    mska = case stk of
        SomeSecretTK secretTk -> case _tkPrimaryKey secretTk of
            KeyPktSecretPrimary _ ska -> Just ska
            _ -> Nothing
        SomePublicTK _ -> Nothing
    uids = _tkUIDs publicView
    mainPreferredHashes = effectiveHashPreferencesAt pt stk
    mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt stk
    mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt stk
    mainKey =
        Just
            ( FunKey
                pkp
                mska
                (fromMaybe S.empty (grabASig uids >>= sig2KUFs))
                mainPreferredHashes
                mainPreferredSymmetricAlgorithms
                mainSupportsSEIPDv2
            )
    sig2KUFs = getHasheds >=> find isKUF >=> getKUFs
    grabASig :: [(a, [b])] -> Maybe b
    grabASig = (listToMaybe >=> listToMaybe) . map snd -- FIXME: this should grab the "best" sig
    getHasheds :: SignaturePayload -> Maybe [SigSubPacket]
    getHasheds (SigV4 _ _ _ hasheds _ _ _) = Just hasheds
    getHasheds (SigV6 _ _ _ _ hasheds _ _ _) = Just hasheds
    getHasheds _ = Nothing
    getKUFs :: SigSubPacket -> Maybe (S.Set KeyFlag)
    getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs
    getKUFs _ = Nothing
    extractPublic :: (KeyPkt k, [SignaturePayload]) -> Maybe FunKey
    extractPublic (KeyPktPublicSubkey spkp, sigs) =
        return
            ( FunKey
                spkp
                Nothing
                (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
                mainPreferredHashes
                mainPreferredSymmetricAlgorithms
                mainSupportsSEIPDv2
            )
    extractPublic _ = Nothing
    extractSecret :: (KeyPkt k, [SignaturePayload]) -> Maybe FunKey
    extractSecret (KeyPktSecretSubkey spkp sska, sigs) =
        return
            ( FunKey
                spkp
                (Just sska)
                (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
                mainPreferredHashes
                mainPreferredSymmetricAlgorithms
                mainSupportsSEIPDv2
            )
    extractSecret _ = Nothing

effectiveHashPreferencesAt
    :: POSIXTime -> SomeTK -> [HashAlgorithm]
effectiveHashPreferencesAt pt tk =
    concatMap toHashes $
        fromMaybe
            []
            ( effectiveKeyPreferencesAt
                (posixSecondsToUTCTime (realToFrac pt))
                (someTKToPublicViewTK tk)
            )
  where
    toHashes (PreferredHashAlgorithms hashes) = hashes
    toHashes _ = []

effectiveSymmetricPreferencesAt
    :: POSIXTime -> SomeTK -> [SymmetricAlgorithm]
effectiveSymmetricPreferencesAt pt tk =
    concatMap toSymmetricAlgorithms $
        fromMaybe
            []
            ( effectiveKeyPreferencesAt
                (posixSecondsToUTCTime (realToFrac pt))
                (someTKToPublicViewTK tk)
            )
  where
    toSymmetricAlgorithms (PreferredSymmetricAlgorithms algorithms) = algorithms
    toSymmetricAlgorithms _ = []

effectiveSEIPDv2SupportAt :: POSIXTime -> SomeTK -> Bool
effectiveSEIPDv2SupportAt pt tk =
    any supportsSEIPDv2Flag $
        concatMap toFeatureFlags $
            fromMaybe
                []
                ( effectiveKeyPreferencesAt
                    (posixSecondsToUTCTime (realToFrac pt))
                    (someTKToPublicViewTK tk)
                )
  where
    toFeatureFlags (Features flags) = S.toList flags
    toFeatureFlags _ = []
    supportsSEIPDv2Flag FeatureSEIPDv2 = True
    supportsSEIPDv2Flag _ = False

-- SOP Handler Stubs
-- These implement the stateless OpenPGP CLI commands per draft-16

doVerify :: POSIXTime -> VerifyOptions -> IO ()
doVerify cpt VerifyOptions {..} = do
    (krs, verifyTks) <- loadVerifyContext cpt verifyCertFiles
    signatureInput <-
        runConduitRes $ CC.sourceFile verifySigFile .| CC.sinkLazy
    sigPkts <- decodeLikeSignaturePackets signatureInput
    let sigs = V.fromList (filter isDetachedVerificationSignaturePkt sigPkts)
    blob <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
    upperBound <- verificationUpperBound cpt verifyNotAfter
    lowerBound <- verificationLowerBound cpt verifyNotBefore
    let sigsWithoutUnsupportedCritical =
            V.filter
                (not . detachedSignatureHasUnsupportedCriticalSubpackets)
                sigs
    binaryVerifications <-
        verifyWithLiteralData
            BinaryData
            blob
            sigsWithoutUnsupportedCritical
            krs
            upperBound
    verifications <-
        if any isRight binaryVerifications
            then pure binaryVerifications
            else
                verifyWithLiteralData
                    TextData
                    blob
                    sigsWithoutUnsupportedCritical
                    krs
                    upperBound
    let decodedVerifications = map (first show) verifications
        signerPolicyAdjusted =
            map
                (enforceVerificationSignerPolicy cpt verifyTks)
                decodedVerifications
    let filtered =
            filterByVerificationBounds
                lowerBound
                upperBound
                signerPolicyAdjusted
        policyFiltered =
            filter (not . verificationResultUsesDeprecatedHash) filtered
    mapM_
        (putStrLn . renderSOPVerificationLine verifyTks)
        (rights policyFiltered)
    case any isRight policyFiltered of
        True -> exitSuccess
        _ -> failWith NoSignature "No acceptable signatures found"
  where
    decodeLikeSignaturePackets lbs = do
        decodedArmors <-
            decodeAsciiArmorInput
                ("signature input in " ++ verifySigFile)
                lbs
        case decodedArmors of
            Just armors ->
                case firstBy isDetachedSignatureArmor armors of
                    Just (Armor ArmorSignature _ bs) ->
                        parseOpenPGPPackets
                            ("signature input in " ++ verifySigFile)
                            (BL.fromStrict (BLC8.toStrict bs))
                    _ ->
                        case firstBy isDetachedSignatureUnsupportedArmor armors of
                            Just (ClearSigned _ _ _) ->
                                failWith
                                    BadData
                                    ("verify: expected detached signatures in " ++ verifySigFile)
                            Just (Armor _ _ _) ->
                                failWith
                                    BadData
                                    ("verify: expected signature armor in " ++ verifySigFile)
                            _ ->
                                parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs
            Nothing ->
                parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs
    verifyWithLiteralData format payload sigs keyring upperBound =
        runConduitRes $
            CC.yieldMany
                (V.cons (LiteralDataPkt format mempty 0 payload) sigs)
                .| conduitVerify keyring upperBound
                .| CC.sinkList

detachedSignatureHasUnsupportedCriticalSubpackets :: Pkt -> Bool
detachedSignatureHasUnsupportedCriticalSubpackets (SignaturePkt sig) =
    any criticalUnsupported (signatureHashedSubpackets sig)
  where
    criticalUnsupported (SigSubPacket True (OtherSigSub _ _)) = True
    criticalUnsupported (SigSubPacket True (UserDefinedSigSub _ _)) = True
    criticalUnsupported (SigSubPacket True (NotationData _ _ _)) = True
    criticalUnsupported _ = False
detachedSignatureHasUnsupportedCriticalSubpackets _ = False

signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]
signatureHashedSubpackets (SigV4 _ _ _ hashed _ _ _) = hashed
signatureHashedSubpackets (SigV6 _ _ _ _ hashed _ _ _) = hashed
signatureHashedSubpackets _ = []

verificationResultUsesDeprecatedHash
    :: Either String Verification -> Bool
verificationResultUsesDeprecatedHash (Right verification) =
    verificationUsesDeprecatedHash verification
verificationResultUsesDeprecatedHash _ = False

verificationUsesDeprecatedHash :: Verification -> Bool
verificationUsesDeprecatedHash (Verification _ sigPayload _) =
    isDeprecatedHashAlgorithm (signatureHashAlgorithm sigPayload)

signatureHashAlgorithm :: SignaturePayload -> HashAlgorithm
signatureHashAlgorithm (SigV3 _ _ _ _ ha _ _) = ha
signatureHashAlgorithm (SigV4 _ _ ha _ _ _ _) = ha
signatureHashAlgorithm (SigV6 _ _ ha _ _ _ _ _) = ha
signatureHashAlgorithm (SigVOther _ _) = OtherHA 0

enforceVerificationSignerPolicy
    :: POSIXTime
    -> [SomeTK]
    -> Either String Verification
    -> Either String Verification
enforceVerificationSignerPolicy _ _ result@(Left _) = result
enforceVerificationSignerPolicy cpt verifyTks result@(Right verification)
    | signerAllowed = result
    | otherwise =
        Left
            "verification failed: signer key is not valid for signing at signature creation time"
  where
    signerAllowed = any signerMatchesProcessed verifyTks
    signerFp = fingerprint (_verificationSigner verification)
    verificationTimePosix =
        maybe
            cpt
            (realToFrac . utcTimeToPOSIXSeconds)
            (signatureCreationTime (_verificationSignature verification))
    verificationTime = posixSecondsToUTCTime verificationTimePosix
    signerMatchesProcessed tk
        | not (keyMatchesFingerprint True tk signerFp) = False
        | keyMatchesFingerprint False tk signerFp = True
        | otherwise =
            any
                (subkeyAllowsSigning verificationTime signerFp)
                ( map
                    (\(kp, sigs) -> (keyPktToPkt kp, sigs))
                    (_tkSubs (someTKToPublicViewTK tk))
                )

subkeyAllowsSigning
    :: UTCTime -> Fingerprint -> (Pkt, [SignaturePayload]) -> Bool
subkeyAllowsSigning t signerFp (pkt, sigs) =
    case subkeyPayload pkt of
        Just pkp
            | fingerprint pkp == signerFp ->
                any
                    (bindingSignatureAllowsSigning t)
                    (filter isSKBindingSig sigs)
        _ -> False
  where
    subkeyPayload (PublicSubkeyPkt pkp) = Just pkp
    subkeyPayload (SecretSubkeyPkt pkp _) = Just pkp
    subkeyPayload _ = Nothing

bindingSignatureAllowsSigning
    :: UTCTime -> SignaturePayload -> Bool
bindingSignatureAllowsSigning t sig =
    allowsSigning && hasValidBacksig
  where
    allowsSigning =
        let flagSets = signatureKeyFlagSets sig
         in null flagSets || any (S.member SignDataKey) flagSets
    hasValidBacksig =
        any
            ( \embedded ->
                isPKBindingSig embedded
                    && not (signatureExpiredAt t embedded)
            )
            (signatureEmbeddedSignatures sig)

signatureEmbeddedSignatures
    :: SignaturePayload -> [SignaturePayload]
signatureEmbeddedSignatures sig =
    [ embedded
    | SigSubPacket _ (EmbeddedSignature embedded) <-
        signatureSubpackets sig
    ]

signatureKeyFlagSets :: SignaturePayload -> [S.Set KeyFlag]
signatureKeyFlagSets sig =
    [ flags
    | SigSubPacket _ (KeyFlags flags) <- signatureSubpackets sig
    ]

signatureExpiredAt :: UTCTime -> SignaturePayload -> Bool
signatureExpiredAt t sig =
    case (signatureCreationTime sig, signatureValiditySeconds sig) of
        (Just created, Just validitySeconds) ->
            utcTimeToPOSIXSeconds t
                >= utcTimeToPOSIXSeconds created + fromIntegral validitySeconds
        _ -> False

signatureValiditySeconds :: SignaturePayload -> Maybe Integer
signatureValiditySeconds sig =
    listToMaybe
        [ fromIntegral secs
        | SigSubPacket _ (SigExpirationTime (ThirtyTwoBitDuration secs)) <-
            signatureSubpackets sig
        ]
verificationUpperBound
    :: POSIXTime -> Maybe String -> IO (Maybe UTCTime)
verificationUpperBound cpt Nothing = return (Just (posixSecondsToUTCTime cpt))
verificationUpperBound _ (Just "-") = return Nothing
verificationUpperBound cpt (Just "now") =
    return (Just (posixSecondsToUTCTime cpt))
verificationUpperBound _ (Just s) = do
    let m = iso8601ParseM s :: Maybe UTCTime
    case m of
        Just t -> return (Just t)
        Nothing -> failWith BadData ("Invalid DATE value: " ++ s)

verificationLowerBound
    :: POSIXTime -> Maybe String -> IO (Maybe UTCTime)
verificationLowerBound _ Nothing = return Nothing
verificationLowerBound _ (Just "-") = return Nothing
verificationLowerBound cpt (Just "now") =
    return (Just (posixSecondsToUTCTime cpt))
verificationLowerBound _ (Just s) = do
    let m = iso8601ParseM s :: Maybe UTCTime
    case m of
        Just t -> return (Just t)
        Nothing -> failWith BadData ("Invalid DATE value: " ++ s)

filterByVerificationBounds
    :: Maybe UTCTime
    -> Maybe UTCTime
    -> [Either String Verification]
    -> [Either String Verification]
filterByVerificationBounds lower upper = map (>>= ensureBounds)
  where
    ensureBounds v =
        case signatureCreationTime (_verificationSignature v) of
            Nothing ->
                Left "verification failed: signature is missing creation time"
            Just sigTime
                | Just upperBound <- upper
                , sigTime > upperBound ->
                    Left
                        "verification failed: signature created after --not-after bound"
                | Just lowerBound <- lower
                , sigTime < lowerBound ->
                    Left
                        "verification failed: signature created before --not-before bound"
                | otherwise -> Right v

signatureCreationTime :: SignaturePayload -> Maybe UTCTime
signatureCreationTime (SigV4 _ _ _ hashed _ _ _) =
    firstCreationTime hashed
signatureCreationTime (SigV6 _ _ _ _ hashed _ _ _) =
    firstCreationTime hashed
signatureCreationTime _ = Nothing

firstCreationTime :: [SigSubPacket] -> Maybe UTCTime
firstCreationTime = listToMaybe . mapMaybe getCreation
  where
    getCreation (SigSubPacket _ (SigCreationTime (ThirtyTwoBitTimeStamp ts))) =
        Just (posixSecondsToUTCTime (fromIntegral ts))
    getCreation _ = Nothing

isDetachedVerificationSignaturePkt :: Pkt -> Bool
isDetachedVerificationSignaturePkt (SignaturePkt (SigV4 sigType _ _ _ _ _ _)) =
    sigType == BinarySig || sigType == CanonicalTextSig
isDetachedVerificationSignaturePkt (SignaturePkt (SigV6 sigType _ _ _ _ _ _ _)) =
    sigType == BinarySig || sigType == CanonicalTextSig
isDetachedVerificationSignaturePkt _ = False

doInlineVerify :: POSIXTime -> InlineVerifyOptions -> IO ()
doInlineVerify cpt InlineVerifyOptions {..} = do
    (krs, verifyTks) <- loadVerifyContext cpt inlineCertFiles
    signedInput <-
        runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
    upperBound <- verificationUpperBound cpt inlineNotAfter
    lowerBound <- verificationLowerBound cpt inlineNotBefore
    (allowTrailingSignatures, parsedPackets) <-
        inlineVerifyPackets signedInput
    packets <-
        normalizeInlineVerifyPackets
            allowTrailingSignatures
            parsedPackets
    let verifications =
            map (first show) (verifyPacketsBatch krs upperBound packets)
        filtered = filterByVerificationBounds lowerBound upperBound verifications
        successLines = map (renderSOPVerificationLine verifyTks) (rights filtered)
        renderedOut =
            if null successLines
                then ""
                else unlines successLines
    case verificationsOut of
        Just outPath ->
            writeFileWithOutputExistsCheck
                "inline-verify"
                outPath
                renderedOut
        Nothing -> pure ()
    case any isRight filtered of
        True ->
            extractSingleLiteralPayload packets >>= BL.putStr >> exitSuccess
        _ -> failWith NoSignature "No acceptable signatures found"
  where
    inlineVerifyPackets :: BL.ByteString -> IO (Bool, [Pkt])
    inlineVerifyPackets lbs = do
        decodedArmors <- decodeAsciiArmorInput "inline-verify input" lbs
        case decodedArmors of
            Just armors ->
                case listToMaybe (filter isInlineVerifyCandidateArmor armors) of
                    Just (Armor ArmorMessage _ bs) -> do
                        let packetBytes = BL.fromStrict (BLC8.toStrict bs)
                        packets <-
                            parseInlineVerifyMessagePackets
                                "inline-verify armored message"
                                packetBytes
                        pure (False, packets)
                    Just (ClearSigned headers cleartext signatureArmor) -> do
                        validateClearSignedEnvelopeBounds lbs
                        validateClearSignedHeaders headers
                        sigPkts <- clearSignedSignaturePackets signatureArmor
                        pure
                            ( True
                            , LiteralDataPkt
                                TextData
                                BL.empty
                                0
                                (BL.fromStrict (BLC8.toStrict cleartext))
                                : sigPkts
                            )
                    Just (Armor _ _ _) ->
                        failWith
                            BadData
                            "inline-verify expects an armored OpenPGP message or cleartext signed message"
                    Nothing -> do
                        packets <-
                            parseInlineVerifyMessagePackets "inline-verify input" lbs
                        pure (False, packets)
            Nothing -> do
                packets <-
                    parseInlineVerifyMessagePackets "inline-verify input" lbs
                pure (False, packets)

    parseInlineVerifyMessagePackets
        :: String -> BL.ByteString -> IO [Pkt]
    parseInlineVerifyMessagePackets context packetBytes = do
        rawPkts <- parseRawOpenPGPPackets context packetBytes
        when (any compressedPacketParseFailed rawPkts) $
            failWith
                BadData
                "inline-verify input has malformed compressed packet data"
        when (any compressedPacketIsEmpty rawPkts) $
            failWith
                BadData
                "inline-verify input has empty compressed packet data"
        expanded <- expandPacketsStrict context rawPkts
        when
            (any isMarkerPacket expanded && any isCompressedPacket rawPkts)
            $ failWith
                BadData
                "inline-verify input has malformed compressed packet sequence"
        pure expanded

    expandPacketsStrict :: String -> [Pkt] -> IO [Pkt]
    expandPacketsStrict context =
        fmap concat . mapM expandPacket
      where
        expandPacket pkt =
            case decompressPkt pkt of
                Left err ->
                    failWith
                        BadData
                        ( context
                            ++ ": failed to parse compressed packet: "
                            ++ renderCompressionError err
                        )
                Right packets -> pure packets

isInlineVerifyCandidateArmor :: Armor -> Bool
isInlineVerifyCandidateArmor (Armor ArmorMessage _ _) = True
isInlineVerifyCandidateArmor ClearSigned {} = True
isInlineVerifyCandidateArmor _ = False

clearSignedSignaturePackets :: Armor -> IO [Pkt]
clearSignedSignaturePackets (Armor ArmorSignature _ sigbs) =
    let sigPktsSource =
            parseOpenPGPPackets
                "cleartext signature block"
                (BL.fromStrict (BLC8.toStrict sigbs))
     in do
            parsed <- sigPktsSource
            let sigPkts = filter isSignaturePkt parsed
            if null sigPkts
                then
                    failWith
                        BadData
                        "cleartext signature block has no signature packets"
                else return sigPkts
clearSignedSignaturePackets (Armor _ _ _) =
    failWith
        BadData
        "cleartext signed message does not contain an armored signature block"
clearSignedSignaturePackets (ClearSigned _ _ inner) =
    clearSignedSignaturePackets inner

isSignaturePkt :: Pkt -> Bool
isSignaturePkt SignaturePkt {} = True
isSignaturePkt _ = False

normalizeInlineVerifyPackets :: Bool -> [Pkt] -> IO [Pkt]
normalizeInlineVerifyPackets allowTrailingSignatures pkts
    | any isBrokenPacket relevantPkts =
        failWith
            BadData
            "inline-verify input contains malformed packet encoding"
    | any (not . isInlineVerificationPacket) filteredPkts =
        failWith
            BadData
            "inline-verify input contains unsupported packet types"
    | otherwise =
        case ( [pkt | pkt@LiteralDataPkt {} <- filteredPkts]
             , [pkt | pkt@SignaturePkt {} <- filteredPkts]
             ) of
            ([], _) ->
                failWith
                    BadData
                    "inline-verify input has no literal message payload"
            ([_], []) ->
                failWith
                    BadData
                    "inline-verify input has no signatures"
            ([lit], sigs)
                | not hasOnePass
                    && ( null signaturePositions
                            || not (all (< literalIndex) signaturePositions)
                       )
                    && ( not allowTrailingSignatures
                            || not (all (> literalIndex) signaturePositions)
                       ) ->
                    failWith
                        BadData
                        "inline-verify input has malformed signed-message packet order"
                | otherwise -> pure (lit : sigs)
            (_, _) ->
                failWith
                    BadData
                    "inline-verify input contains multiple literal payloads"
  where
    relevantPkts = filter (not . isMarkerPacket) pkts
    filteredPkts = filter (not . isIgnorableInlineVerifyPacket) relevantPkts
    packetPositions = zip [0 :: Int ..] filteredPkts
    signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]
    onePassPositions = [i | (i, OnePassSignaturePkt {}) <- packetPositions]
    literalPositions = [i | (i, LiteralDataPkt {}) <- packetPositions]
    hasOnePass = not (null onePassPositions)
    literalIndex =
        case literalPositions of
            (i : _) -> i
            [] -> -1
    isBrokenPacket BrokenPacketPkt {} = True
    isBrokenPacket _ = False

isIgnorableInlineVerifyPacket :: Pkt -> Bool
isIgnorableInlineVerifyPacket (OtherPacketPkt tag _) = tag >= 40
isIgnorableInlineVerifyPacket _ = False

isInlineVerificationPacket :: Pkt -> Bool
isInlineVerificationPacket LiteralDataPkt {} = True
isInlineVerificationPacket SignaturePkt {} = True
isInlineVerificationPacket OnePassSignaturePkt {} = True
isInlineVerificationPacket (OtherPacketPkt tag _) = tag >= 40
isInlineVerificationPacket BrokenPacketPkt {} = False
isInlineVerificationPacket _ = False

doEncrypt :: POSIXTime -> EncryptOptions -> IO ()
doEncrypt cpt EncryptOptions {..} = do
    payload <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
    when (encAs == AsText) $
        ensureUTF8TextInput "encrypt" payload
    symmetricPasswordsRaw <-
        loadPasswordFiles "encrypt" "--with-password" encPasswords
    symmetricPasswords <-
        mapM
            (normalizeHumanReadablePassword "encrypt" "--with-password")
            symmetricPasswordsRaw
    signingKeyPasswordsRaw <-
        loadPasswordFiles
            "encrypt"
            "--with-key-password"
            encSignWithKeyPasswords
    let signingKeyPasswords = concatMap passwordRetryCandidates signingKeyPasswordsRaw
    encryptProfile <- parseEncryptProfile encProfile
    when
        (not (null encRecipientCerts) && not (null symmetricPasswords))
        $ failWith
            UnsupportedOption
            "encrypt: combining recipient certificates with --with-password is not yet supported"
    recipientKeys <-
        if null encRecipientCerts
            then pure []
            else loadEncryptRecipients cpt encFor encRecipientCerts
    recipientHashPrefs <-
        if null encRecipientCerts
            then pure []
            else loadRecipientPreferredHashes cpt encRecipientCerts
    signatures <-
        if null encSignWithKeyFiles
            then pure []
            else do
                signingKeys <-
                    loadSigningKeys "encrypt" encSignWithKeyFiles signingKeyPasswords
                signPayloadWithKeys
                    cpt
                    encAs
                    payload
                    signingKeys
                    recipientHashPrefs
                    ( case encryptProfile of
                        EncryptProfileRFC9580 -> rfc9580SigningHashFallbackOrder
                        EncryptProfileRFC4880 -> legacySigningHashFallbackOrder
                    )
    out <-
        case encRecipientCerts of
            [] ->
                doEncryptWithPassword
                    encryptProfile
                    payload
                    symmetricPasswords
                    encSessionKeyOutFile
            _ ->
                doEncryptForRecipients
                    encryptProfile
                    encAs
                    payload
                    signatures
                    recipientKeys
                    encSessionKeyOutFile
    BL.putStr $
        if encNoArmor
            then out
            else AA.encodeLazy [Armor ArmorMessage [] out]

doEncryptWithPassword
    :: EncryptProfile
    -> BL.ByteString
    -> [BL.ByteString]
    -> Maybe String
    -> IO BL.ByteString
doEncryptWithPassword encryptProfile payload passwords sessionKeyOutFile = do
    password <-
        case passwords of
            [] ->
                failWith
                    MissingArg
                    "encrypt: supply at least one recipient certificate or --with-password"
            [p] -> pure p
            _ ->
                failWith
                    UnsupportedOption
                    "encrypt: multiple --with-password values are not yet supported"
    let exposure =
            if isJust sessionKeyOutFile
                then ExposeSessionMaterial
                else DoNotExposeSessionMaterial
    encrypted <-
        case encryptProfile of
            EncryptProfileRFC9580 -> do
                s2kSalt <- Salt16 <$> getRandomBytes 16
                iv <- IV <$> getRandomBytes 32
                pure $
                    encryptMessage
                        RFC9580EncryptMessageOptions
                            { rfc9580EncryptMessageExposure = exposure
                            , rfc9580EncryptMessageSymmetricAlgorithm = AES256
                            , rfc9580EncryptMessageS2K = Argon2 s2kSalt 1 4 15
                            , rfc9580EncryptMessageIV = iv
                            }
                        (Passphrase password)
                        (mkClearPayload payload)
            EncryptProfileRFC4880 -> do
                salt <- Salt8 <$> getRandomBytes 8
                iv <- IV <$> getRandomBytes 16
                pure $
                    encryptMessage
                        RFC4880EncryptMessageOptions
                            { rfc4880EncryptMessageExposure = exposure
                            , rfc4880EncryptMessageSymmetricAlgorithm = AES256
                            , rfc4880EncryptMessageS2K = IteratedSalted SHA256 salt 65536
                            , rfc4880EncryptMessageIV = iv
                            }
                        (Passphrase password)
                        (mkClearPayload payload)
    case encrypted of
        Left err -> failWith BadData ("encrypt failed: " ++ show err)
        Right (ciphertext, mRecoveredSession) -> do
            forM_ sessionKeyOutFile $ \path ->
                case mRecoveredSession of
                    Just recoveredSession ->
                        writeFileWithOutputExistsCheck
                            "encrypt"
                            path
                            ( renderSessionKeyOutLine
                                (fromFVal (recoveredSessionAlgorithm recoveredSession))
                                (unSessionKey (recoveredSessionKey recoveredSession))
                                ++ "\n"
                            )
                    Nothing ->
                        failWith
                            UnsupportedOption
                            "encrypt: --session-key-out unavailable for this password encryption mode"
            pure (encryptedPayloadBytes ciphertext)

doEncryptForRecipients
    :: EncryptProfile
    -> AsBinaryText
    -> BL.ByteString
    -> [SignaturePayload]
    -> [FunKey]
    -> Maybe String
    -> IO BL.ByteString
doEncryptForRecipients encryptProfile asMode payload signatures recipients sessionKeyOutFile = do
    let targets = map recipientTargetFor recipients
        payloadShape =
            defaultRecipientPayloadShape
                { recipientPayloadDataType = literalDataType
                , recipientPayloadUseOnePassSignatures = not (null signatures)
                , recipientPayloadSignatures = signatures
                }
    result <-
        if useStrictEncryptProfile
            then
                encryptForRecipients
                    RecipientEncryptRequest
                        { recipientEncryptRequestTargets = targets
                        , recipientEncryptRequestPayloadShape = payloadShape
                        , recipientEncryptRequestPayload = BL.toStrict payload
                        , recipientEncryptRequestSymmetricOverride = symmetricOverride
                        , recipientEncryptRequestOverrides =
                            RecipientEncryptRequestSEIPDv2Overrides
                                { recipientEncryptRequestAEADOverride = Nothing
                                , recipientEncryptRequestChunkSizeOverride = Nothing
                                , recipientEncryptRequestSaltOverride = Nothing
                                }
                        }
            else
                encryptForRecipients
                    RecipientEncryptRequest
                        { recipientEncryptRequestTargets = targets
                        , recipientEncryptRequestPayloadShape = payloadShape
                        , recipientEncryptRequestPayload = BL.toStrict payload
                        , recipientEncryptRequestSymmetricOverride = symmetricOverride
                        , recipientEncryptRequestOverrides =
                            RecipientEncryptRequestSEIPDv1Overrides
                                { recipientEncryptRequestIVOverride = Nothing
                                }
                        }
    RecipientEncryptResult {..} <-
        case result of
            Left err ->
                failWith
                    (sopFailureForPKESKEncryptError err)
                    ("encrypt failed: " ++ renderPKESKEncryptError err)
            Right val -> pure val
    forM_ sessionKeyOutFile $ \path ->
        writeFileWithOutputExistsCheck
            "encrypt"
            path
            ( renderSessionKeyOutLine
                (fromFVal (pkeskSessionAlgorithm recipientEncryptSessionMaterial))
                (unSessionKey (pkeskSessionKey recipientEncryptSessionMaterial))
                ++ "\n"
            )
    pure (runPut (Bin.put (Block recipientEncryptPackets)))
  where
    literalDataType =
        case asMode of
            AsBinary -> BinaryData
            AsText -> UTF8Data
    anyRecipientSupportsSEIPDv2 = any fsupportsSEIPDv2 recipients
    symmetricOverride
        | useStrictEncryptProfile =
            preferredStrictSymmetric <|> Just AES256
        | otherwise = preferredLegacySymmetric
    isV6Recipient pkp = _keyVersion pkp == V6
    useStrictEncryptProfile =
        case encryptProfile of
            EncryptProfileRFC9580 ->
                anyRecipientSupportsSEIPDv2
                    || any (isV6Recipient . fpkp) recipients
            EncryptProfileRFC4880 ->
                anyRecipientSupportsSEIPDv2
                    || any (isV6Recipient . fpkp) recipients
    preferredStrictSymmetric =
        preferredRecipientSymmetric isSupportedStrictEncryptSymmetric
    preferredLegacySymmetric =
        preferredRecipientSymmetric isSupportedLegacyEncryptSymmetric
    preferredRecipientSymmetric isSupported =
        case filter
            (not . null)
            (map fpreferredSymmetricAlgorithms recipients) of
            [] -> Nothing
            (prefList : prefLists) ->
                listToMaybe
                    [ candidate
                    | candidate <- filter isSupported prefList
                    , all (candidate `elem`) prefLists
                    ]
    isSupportedStrictEncryptSymmetric algo =
        algo `elem` [AES128, AES192, AES256]
    -- Legacy profile fallback should not hard-fail on deprecated/unsupported
    -- recipient preferences (e.g. IDEA in AEADED interop fixtures).
    isSupportedLegacyEncryptSymmetric algo =
        algo `elem` [AES128, AES192, AES256]
    recipientTargetFor funkey =
        let recipient = fpkp funkey
            recipientNeedsV6PKESK =
                useStrictEncryptProfile
                    && (fsupportsSEIPDv2 funkey || _keyVersion recipient == V6)
         in if _keyVersion recipient == V6
                then
                    recipientEncryptionTargetWithStrategyTyped
                        recipient
                        RecipientPreferV6W
                else case _pkalgo recipient of
                    ECDH ->
                        -- Under strict (SEIPDv2) mode, keep Curve25519-compatible v4 ECDH keys on
                        -- the X25519/v6 path so ESK/payload versions stay aligned.
                        if recipientNeedsV6PKESK
                            then case normalizeX25519CompatibleECDHRecipient recipient of
                                Just x25519Recipient ->
                                    recipientEncryptionTargetWithStrategyTyped
                                        x25519Recipient
                                        RecipientPreferV6W
                                Nothing ->
                                    recipientEncryptionTargetWithStrategyTyped
                                        recipient
                                        RecipientPreferV6W
                            else
                                recipientEncryptionTargetWithStrategyTyped
                                    recipient
                                    RecipientForceV3InteropW
                    DeprecatedRSAEncryptOnly ->
                        if recipientNeedsV6PKESK
                            then
                                recipientEncryptionTargetWithStrategyTyped
                                    recipient
                                    RecipientPreferV6W
                            else
                                recipientEncryptionTargetWithStrategyTyped
                                    recipient
                                    RecipientForceV3InteropW
                    RSA ->
                        if recipientNeedsV6PKESK
                            then
                                recipientEncryptionTargetWithStrategyTyped
                                    recipient
                                    RecipientPreferV6W
                            else
                                recipientEncryptionTargetWithStrategyTyped
                                    recipient
                                    RecipientForceV3InteropW
                    _ ->
                        if recipientNeedsV6PKESK
                            then
                                recipientEncryptionTargetWithStrategyTyped
                                    recipient
                                    RecipientPreferV6W
                            else recipientEncryptionTarget recipient

    normalizeX25519CompatibleECDHRecipient pkp =
        case _pubkey pkp of
            ECDHPubKey (EdDSAPubKey EdSigningCurve25519 _) _ _ ->
                Just
                    ( PKPayload
                        (_keyVersion pkp)
                        (_timestamp pkp)
                        (_v3exp pkp)
                        X25519
                        (_pubkey pkp)
                    )
            _ -> Nothing

parseEncryptProfile :: Maybe String -> IO EncryptProfile
parseEncryptProfile Nothing = pure EncryptProfileRFC9580
parseEncryptProfile (Just name) =
    case resolveProfile name encryptProfiles of
        Just p -> pure p
        Nothing ->
            failWith
                UnsupportedProfile
                ("encrypt: unsupported profile " ++ name)

doDecrypt :: POSIXTime -> DecryptOptions -> IO ()
doDecrypt cpt DecryptOptions {..} = do
    sessionKeys <- parseDecryptSessionKeys decSessionKeys
    verificationOutputPath <-
        resolveDecryptVerificationsOut decVerificationsOutFile
    let hasVerifyWith = not (null decVerifyCerts)
        hasVerifyOut = isJust verificationOutputPath
        hasVerifyBounds = isJust decVerifyNotBefore || isJust decVerifyNotAfter
        doingVerification = hasVerifyWith && hasVerifyOut
    when (hasVerifyWith /= hasVerifyOut) $
        failWith
            IncompleteVerification
            "decrypt: verification requires both --verify-with and --verifications-out"
    when (hasVerifyBounds && not doingVerification) $
        failWith
            IncompleteVerification
            "decrypt: --verify-not-before/--verify-not-after require both --verify-with and --verifications-out"
    passwords <-
        loadPasswordFiles "decrypt" "--with-password" decPasswords
    keyPasswordsRaw <-
        loadPasswordFiles "decrypt" "--with-key-password" decKeyPasswords
    let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
    when (null passwords && null sessionKeys && null decKeyFiles) $
        failWith
            MissingArg
            "decrypt: supply KEYS, --with-password, or --with-session-key"
    ciphertextInput <-
        runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
    ciphertext <- decodeCiphertextInput ciphertextInput
    validateDecryptPartialBodyEncoding ciphertext
    ciphertextPktsRaw <-
        parseRawOpenPGPPackets "decrypt input" ciphertext
    let ciphertextPkts =
            filter
                ( \pkt ->
                    not
                        ( isForwardCompatUnknownESKPacket pkt
                            || isUnsupportedSKESKPacket pkt
                        )
                )
                ciphertextPktsRaw
    -- Pre-flight: reject messages with no encrypted payload at all (upstream
    -- won't produce a useful DecryptMalformedStructure for the empty case).
    when (not (any isEncryptedPayloadPacket ciphertextPkts)) $
        failWith BadData "decrypt input: no encrypted data packet found"
    validateCiphertextPacketLayout ciphertextPkts
    recipientKeys <-
        loadDecryptRecipientKeys cpt "decrypt" decKeyFiles keyPasswords
    when
        ( null recipientKeys
            && not (null decKeyFiles)
            && null passwords
            && null sessionKeys
        )
        $ failWith
            CannotDecrypt
            "decrypt failed: no usable secret key material found in provided KEYS"
    let passwordAttempts =
            case passwords of
                [] -> [[]]
                _ ->
                    map
                        (\password -> [password])
                        (concatMap passwordRetryCandidates passwords)
        runDecryptAttemptWithPolicy decryptPolicy keyCandidates passwordBytes = do
            passwordQueue <- newIORef passwordBytes
            sessionKeyQueue <-
                newIORef (map decryptSessionKeyMaterial sessionKeys)
            let decryptInputPkts = prioritizeDecryptablePKESKs keyCandidates ciphertextPkts
            let keyResolutionResolver =
                    selectRecipientKeyInfosByRecipientIdentifier keyCandidates
            let opts =
                    Decrypt.DecryptOptions
                        { Decrypt.decryptOptionsKeyResolution =
                            DecryptWithUnwrapCandidatesCallback keyResolutionResolver
                        , Decrypt.decryptOptionsPolicy = decryptPolicy
                        , Decrypt.decryptOptionsPassphraseCallback =
                            decryptInputCallback passwordQueue sessionKeyQueue
                        }
            (outcome, pkts) <-
                runConduitRes $
                    CL.sourceList decryptInputPkts
                        .| fuseBoth (Decrypt.conduitDecrypt opts) CL.consume
            case outcome of
                DecryptMalformedStructure reason ->
                    pure (Left reason)
                DecryptTruncated ->
                    failWith BadData "decrypt failed: encrypted message is truncated"
                _ -> pure (Right pkts)
        tryDecryptWithPasswords [passwordBytes] =
            runDecryptAttempt recipientKeys passwordBytes
                `catch` decryptIOFailureToSOP
        tryDecryptWithPasswords (passwordBytes : rest) =
            runDecryptAttempt recipientKeys passwordBytes `catch` retryNext
          where
            retryNext :: ExitCode -> IO [Pkt]
            retryNext exitCode
                | exitCode == ExitFailure (failureCode CannotDecrypt) =
                    tryDecryptWithPasswords rest
                | otherwise = throwIO exitCode
        tryDecryptWithPasswords [] =
            failWith
                CannotDecrypt
                "decrypt failed: passphrase required but not provided"
        decryptIOFailureToSOP :: IOException -> IO [Pkt]
        decryptIOFailureToSOP err =
            failWith
                CannotDecrypt
                ("decrypt failed: " ++ displayException err)
        runDecryptAttempt keyCandidates passwordBytes = do
            strictOutcome <-
                runDecryptAttemptWithPolicy
                    defaultDecryptPolicy
                    keyCandidates
                    passwordBytes
            case strictOutcome of
                Right pkts -> pure pkts
                Left reason
                    | shouldRetryLenientDecrypt reason keyCandidates passwordBytes -> do
                        lenientOutcome <-
                            runDecryptAttemptWithPolicy
                                lenientDecryptPolicy
                                keyCandidates
                                passwordBytes
                        case lenientOutcome of
                            Right pkts -> pure pkts
                            Left lenientReason ->
                                failWith
                                    BadData
                                    ( "decrypt failed: malformed encrypted message structure ("
                                        ++ lenientReason
                                        ++ ")"
                                    )
                    | otherwise ->
                        failWith
                            BadData
                            ( "decrypt failed: malformed encrypted message structure ("
                                ++ reason
                                ++ ")"
                            )
        shouldRetryLenientDecrypt reason keyCandidates passwordBytes
            | "ESK packets must immediately precede encrypted data"
                `isInfixOf` reason =
                True
            | "ESK packets present but none are version-aligned with SEIPDv2 payload"
                `isInfixOf` reason =
                null passwordBytes
                    && not (null keyCandidates)
                    && any isLegacyRSAPKESK ciphertextPkts
            | otherwise = False
        isLegacyRSAPKESK (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) =
            pka == RSA || pka == DeprecatedRSAEncryptOnly
        isLegacyRSAPKESK _ = False
    decryptedPktsRaw <- tryDecryptWithPasswords passwordAttempts
    sessionKeyOutLine <-
        resolveSessionKeyOut
            decSessionKeyOutFile
            sessionKeys
            ciphertextPkts
            recipientKeys
            (concatMap passwordRetryCandidates passwords)
    decryptedPkts <- do
        decompressed <-
            mapM
                ( either (\e -> failWith BadData (renderCompressionError e)) pure
                    . recursivelyDecompressPacket
                )
                decryptedPktsRaw
        pure (concat decompressed)
    validateDecryptedMessageStructure decryptedPktsRaw decryptedPkts
    payload <- extractSingleLiteralPayload decryptedPkts
    BL.putStr payload
    case (decSessionKeyOutFile, sessionKeyOutLine) of
        (Just path, Just line) -> writeFileWithOutputExistsCheck "decrypt" path (line ++ "\n")
        _ -> pure ()
    when doingVerification $
        doDecryptVerifyOutput
            cpt
            decVerifyCerts
            verificationOutputPath
            decVerifyNotBefore
            decVerifyNotAfter
            decryptedPkts

data DecryptSessionKey
    = DecryptSessionKey
    { decryptSessionKeyMaterial :: BL.ByteString
    , decryptSessionKeyOutLine :: Maybe String
    }

decryptInputCallback
    :: IORef [BL.ByteString]
    -> IORef [BL.ByteString]
    -> String
    -> IO BL.ByteString
decryptInputCallback _passwordQueue sessionKeyQueue prompt
    | "PKESK session key material" `isInfixOf` prompt = do
        mSessionKeyMaterial <-
            atomicModifyIORef' sessionKeyQueue $ \keys ->
                case keys of
                    [] -> ([], Nothing)
                    (k : rest) -> (rest, Just k)
        case mSessionKeyMaterial of
            Just sessionKeyMaterial -> pure sessionKeyMaterial
            Nothing ->
                failWith
                    CannotDecrypt
                    "decrypt failed: PKESK session key material required but not provided"
decryptInputCallback passwordQueue _ _ = do
    mPassword <-
        atomicModifyIORef' passwordQueue $ \passwords ->
            case passwords of
                [] -> ([], Nothing)
                (p : rest) -> (rest, Just p)
    case mPassword of
        Just password -> pure password
        Nothing ->
            failWith
                CannotDecrypt
                "decrypt failed: passphrase required but not provided"

parseDecryptSessionKeys :: [String] -> IO [DecryptSessionKey]
parseDecryptSessionKeys = mapM parseSessionKeySpec

parseSessionKeySpec :: String -> IO DecryptSessionKey
parseSessionKeySpec spec =
    case break (== ':') spec of
        (_, "") -> do
            material <- decodeHexBytes spec
            pure
                DecryptSessionKey
                    { decryptSessionKeyMaterial = BL.fromStrict material
                    , decryptSessionKeyOutLine = sessionKeyOutLineFromMaterial material
                    }
        (algoSpec, ':' : keyHex) -> do
            algo <- parseAlgorithmOctet algoSpec
            keyBytes <- decodeHexBytes keyHex
            when (B.null keyBytes) $
                failWith
                    BadData
                    "decrypt: --with-session-key key material cannot be empty"
            pure
                DecryptSessionKey
                    { decryptSessionKeyMaterial =
                        BL.fromStrict (encodeOpenPGPSessionKey algo keyBytes)
                    , decryptSessionKeyOutLine =
                        Just (renderSessionKeyOutLine algo keyBytes)
                    }
        _ -> failWith BadData "decrypt: invalid --with-session-key format"

resolveSessionKeyOut
    :: Maybe String
    -> [DecryptSessionKey]
    -> [Pkt]
    -> [PKESKRecipientKey]
    -> [BL.ByteString]
    -> IO (Maybe String)
resolveSessionKeyOut Nothing _ _ _ _ = pure Nothing
resolveSessionKeyOut (Just _) sessionKeys ciphertextPkts recipientKeys passwordCandidates =
    case mapMaybe decryptSessionKeyOutLine sessionKeys of
        (line : _) -> pure (Just line)
        [] -> do
            discoveredLine <-
                recoverSessionKeyOutFromCiphertext
                    ciphertextPkts
                    recipientKeys
                    passwordCandidates
            case discoveredLine of
                Just line -> pure (Just line)
                Nothing -> pure Nothing

recoverSessionKeyOutFromCiphertext
    :: [Pkt]
    -> [PKESKRecipientKey]
    -> [BL.ByteString]
    -> IO (Maybe String)
recoverSessionKeyOutFromCiphertext ciphertextPkts recipientKeys passwordCandidates =
    case recoverFromSKESK of
        Just line -> pure (Just line)
        Nothing -> recoverFromLegacyRSAPKESK
  where
    recoverFromSKESK =
        listToMaybe $
            mapMaybe
                ( \(SKESKPayloadV4 sa s2k maybeEsk, passphrase) ->
                    case maybeEsk of
                        Nothing ->
                            case skesk2Key (SKESK4Packet sa s2k Nothing) passphrase of
                                Left _ -> Nothing
                                Right sessionKey ->
                                    Just (renderSessionKeyOutLine (fromFVal sa) sessionKey)
                        Just esk ->
                            case skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase of
                                Left _ -> Nothing
                                Right (algo, sessionKey) ->
                                    Just (renderSessionKeyOutLine (fromFVal algo) sessionKey)
                )
                [ (payload, passphrase)
                | payload <- skeskPayloadsV4
                , passphrase <- passwordCandidates
                ]
    skeskPayloadsV4 =
        mapMaybe
            ( \pkt ->
                case pkt of
                    SKESKPkt (SKESKPayloadV4Packet payload) -> Just payload
                    _ -> Nothing
            )
            ciphertextPkts
    recoverFromLegacyRSAPKESK =
        recoverRSACombos
            [(mpi, rsaKey) | mpi <- rsaPKESKMPIs, rsaKey <- rsaRecipientKeys]
    recoverRSACombos [] = pure Nothing
    recoverRSACombos ((mpi, rsaKey) : rest) = do
        encodedResult <- decryptLegacyRSAPKESK rsaKey mpi
        case encodedResult of
            Left _ -> recoverRSACombos rest
            Right encoded ->
                case decodeOpenPGPEncodedSessionKey encoded of
                    Right (algo, keyBytes) ->
                        pure (Just (renderSessionKeyOutLine (fromFVal algo) keyBytes))
                    Left _ -> recoverRSACombos rest
    rsaPKESKMPIs =
        mapMaybe
            ( \pkt ->
                case pkt of
                    PKESKPkt
                        (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka (mpi :| [])))
                            | pka == RSA || pka == DeprecatedRSAEncryptOnly ->
                                Just mpi
                    _ -> Nothing
            )
            ciphertextPkts
    rsaRecipientKeys =
        mapMaybe
            ( \keyInfo ->
                case pkeskRecipientSKey keyInfo of
                    RSAPrivateKey (RSA_PrivateKey privateKey) -> Just privateKey
                    _ -> Nothing
            )
            recipientKeys

decryptLegacyRSAPKESK
    :: RSA.PrivateKey -> MPI -> IO (Either String B.ByteString)
decryptLegacyRSAPKESK privateKey mpi = do
    attempted <-
        P15.decryptSafer privateKey (mpiToCiphertext privateKey mpi)
    pure (first show attempted)
  where
    mpiToCiphertext rsaKey (MPI encodedMPI) =
        let modulusBytes = rsaModulusOctets rsaKey
         in i2ospOf_ modulusBytes encodedMPI
    rsaModulusOctets rsaKey =
        let modulusBits = integerBitLength (RSA.public_n (RSA.private_pub rsaKey))
         in max 1 ((modulusBits + 7) `div` 8)
    integerBitLength n
        | n <= 0 = 0
        | otherwise = go n 0
      where
        go 0 bits = bits
        go val bits = go (val `div` 2) (bits + 1)

parseAlgorithmOctet :: String -> IO Word8
parseAlgorithmOctet algoSpec =
    case readMaybe algoSpec :: Maybe Int of
        Just octet
            | octet >= 0 && octet <= 255 ->
                case toFVal (fromIntegral octet) :: SymmetricAlgorithm of
                    OtherSA _ ->
                        failWith
                            BadData
                            ("decrypt: unsupported --with-session-key algorithm: " ++ algoSpec)
                    _ -> pure (fromIntegral octet)
        _ ->
            failWith
                BadData
                ("decrypt: invalid --with-session-key algorithm: " ++ algoSpec)

decodeHexBytes :: String -> IO B.ByteString
decodeHexBytes hex =
    if odd (length hex)
        then
            failWith
                BadData
                "decrypt: hex key material must have an even number of digits"
        else B.pack <$> go hex
  where
    go [] = pure []
    go (a : b : rest) = do
        hi <- nibble a
        lo <- nibble b
        (fromIntegral (hi * 16 + lo) :) <$> go rest
    go _ = failWith BadData "decrypt: malformed hex key material"
    nibble c =
        if isHexDigit c
            then pure (digitToInt c)
            else failWith BadData "decrypt: key material must be hexadecimal"

isEncryptedPayloadPacket :: Pkt -> Bool
isEncryptedPayloadPacket SymEncIntegrityProtectedDataPkt {} = True
isEncryptedPayloadPacket SymEncDataPkt {} = True
isEncryptedPayloadPacket _ = False

isForwardCompatUnknownESKPacket :: Pkt -> Bool
isForwardCompatUnknownESKPacket (OtherPacketPkt tag _) = tag == 1 || tag == 3
isForwardCompatUnknownESKPacket (BrokenPacketPkt _ tag _) = tag == 1 || tag == 3
isForwardCompatUnknownESKPacket _ = False

isUnsupportedSKESKPacket :: Pkt -> Bool
isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ s2k _))) = isUnknownS2K s2k
isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ s2k _ _ _))) = isUnknownS2K s2k
isUnsupportedSKESKPacket _ = False

isUnknownS2K :: S2K -> Bool
isUnknownS2K OtherS2K {} = True
isUnknownS2K _ = False

validateCiphertextPacketLayout :: [Pkt] -> IO ()
validateCiphertextPacketLayout pkts =
    case findIndex isEncryptedPayloadPacket pkts of
        Nothing -> pure ()
        Just payloadIndex ->
            let trailing =
                    filter
                        (not . isMarkerPacketPacket)
                        (drop (payloadIndex + 1) pkts)
             in when (not (null trailing)) $
                    failWith
                        BadData
                        "decrypt input: malformed encrypted message structure (unexpected packets after encrypted data)"

isMarkerPacketPacket :: Pkt -> Bool
isMarkerPacketPacket MarkerPkt {} = True
isMarkerPacketPacket _ = False

validateDecryptedMessageStructure :: [Pkt] -> [Pkt] -> IO ()
validateDecryptedMessageStructure rawPkts pkts = do
    let literalCount = length [() | LiteralDataPkt {} <- pkts]
        signatureCount = length [() | SignaturePkt {} <- pkts]
        onePassCount = length [() | OnePassSignaturePkt {} <- pkts]
        hasCompressedRaw = any isCompressedPacket rawPkts
        hasUnknownPackets = any isUnknownPacket rawPkts || any isUnknownPacket pkts
        maxCompressionDepth = maximum (0 : map compressionDepth rawPkts)
    when (any compressedPacketParseFailed rawPkts) $
        failWith
            BadData
            "decrypt failed: malformed compressed data stream"
    when (maxCompressionDepth > 2) $
        failWith
            BadData
            "decrypt failed: malformed encrypted message structure (excessive compression nesting)"
    when (hasCompressedRaw && any isMarkerPacket pkts) $
        failWith
            BadData
            "decrypt failed: malformed encrypted message structure (compressed marker packet)"
    when (any isDisallowedDecryptedPacketType pkts) $
        failWith
            BadData
            "decrypt failed: malformed encrypted message structure (unexpected packet type in plaintext)"
    when (literalCount == 0) $
        failWith
            BadData
            "decrypt failed: malformed encrypted message structure (no literal data payload found)"
    when (literalCount > 1) $
        failWith
            BadData
            "decrypt failed: malformed encrypted message structure (multiple literal payloads)"
    when
        (not hasUnknownPackets && onePassCount > 0 && signatureCount == 0)
        $ failWith
            BadData
            "decrypt failed: malformed signed message structure (one-pass signature without trailing signature)"
    when
        ( not hasUnknownPackets
            && signatureCount > 0
            && onePassCount == 0
            && not isOldStyleSignedMessage
        )
        $ failWith
            BadData
            "decrypt failed: malformed signed message structure (trailing signature without one-pass signature)"
  where
    isOldStyleSignedMessage =
        case [i | (i, LiteralDataPkt {}) <- packetPositions] of
            [literalIndex] ->
                not (null signaturePositions)
                    && all (< literalIndex) signaturePositions
            _ -> False
    packetPositions = zip [0 :: Int ..] (filter (not . isMarkerPacket) pkts)
    signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]

compressedPacketParseFailed :: Pkt -> Bool
compressedPacketParseFailed pkt@CompressedDataPkt {} = isLeft (decompressPkt pkt)
compressedPacketParseFailed _ = False

recursivelyDecompressPacket
    :: Pkt -> Either CompressionError [Pkt]
recursivelyDecompressPacket pkt@CompressedDataPkt {} = do
    inner <- decompressPkt pkt
    concat <$> mapM recursivelyDecompressPacket inner
recursivelyDecompressPacket pkt = Right [pkt]

compressedPacketIsEmpty :: Pkt -> Bool
compressedPacketIsEmpty pkt@CompressedDataPkt {} =
    case decompressPkt pkt of
        Right [] -> True
        _ -> False
compressedPacketIsEmpty _ = False

isCompressedPacket :: Pkt -> Bool
isCompressedPacket CompressedDataPkt {} = True
isCompressedPacket _ = False

compressionDepth :: Pkt -> Int
compressionDepth pkt@CompressedDataPkt {} =
    let inner = either (const []) id (decompressPkt pkt)
     in if null inner
            then 1
            else 1 + maximum (0 : map compressionDepth inner)
compressionDepth _ = 0

isMarkerPacket :: Pkt -> Bool
isMarkerPacket MarkerPkt {} = True
isMarkerPacket _ = False

isUnknownPacket :: Pkt -> Bool
isUnknownPacket OtherPacketPkt {} = True
isUnknownPacket BrokenPacketPkt {} = True
isUnknownPacket _ = False

isDisallowedDecryptedPacketType :: Pkt -> Bool
isDisallowedDecryptedPacketType PKESKPkt {} = True
isDisallowedDecryptedPacketType SKESKPkt {} = True
isDisallowedDecryptedPacketType PublicKeyPkt {} = True
isDisallowedDecryptedPacketType PublicSubkeyPkt {} = True
isDisallowedDecryptedPacketType SecretKeyPkt {} = True
isDisallowedDecryptedPacketType SecretSubkeyPkt {} = True
isDisallowedDecryptedPacketType SymEncDataPkt {} = True
isDisallowedDecryptedPacketType SymEncIntegrityProtectedDataPkt {} = True
isDisallowedDecryptedPacketType _ = False

encodeOpenPGPSessionKey :: Word8 -> B.ByteString -> B.ByteString
encodeOpenPGPSessionKey algo keyBytes =
    B.cons
        algo
        ( keyBytes
            <> B.pack [fromIntegral (checksum `div` 256), fromIntegral checksum]
        )
  where
    checksum :: Int
    checksum =
        B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536

sessionKeyOutLineFromMaterial :: B.ByteString -> Maybe String
sessionKeyOutLineFromMaterial raw = do
    (algo, keyBytes) <- decodeOpenPGPSessionKeyMaterial raw
    pure (renderSessionKeyOutLine algo keyBytes)

decodeOpenPGPSessionKeyMaterial
    :: B.ByteString -> Maybe (Word8, B.ByteString)
decodeOpenPGPSessionKeyMaterial raw = do
    (algo, body) <- B.uncons raw
    case toFVal (fromIntegral algo) :: SymmetricAlgorithm of
        OtherSA _ -> Nothing
        _ -> do
            let bodyLen = B.length body
            if bodyLen < 3
                then Nothing
                else do
                    let keyBytes = B.take (bodyLen - 2) body
                        checksumHi = fromIntegral (B.index body (bodyLen - 2)) :: Int
                        checksumLo = fromIntegral (B.index body (bodyLen - 1)) :: Int
                        checksumExpected = checksumHi * 256 + checksumLo
                        checksumActual =
                            B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536
                    if B.null keyBytes || checksumActual /= checksumExpected
                        then Nothing
                        else Just (algo, keyBytes)

renderSessionKeyOutLine :: Word8 -> B.ByteString -> String
renderSessionKeyOutLine algo keyBytes =
    show algo ++ ":" ++ hexEncodeBytes keyBytes

hexEncodeBytes :: B.ByteString -> String
hexEncodeBytes = concatMap encodeByte . B.unpack
  where
    encodeByte w =
        [ nibble (w `shiftR` 4)
        , nibble (w .&. 0x0f)
        ]
    nibble n = "0123456789abcdef" !! fromIntegral n

extractSingleLiteralPayload :: [Pkt] -> IO BL.ByteString
extractSingleLiteralPayload pkts =
    case [p | LiteralDataPkt _ _ _ p <- pkts] of
        [payload] -> pure payload
        [] ->
            failWith
                BadData
                "decrypt failed: malformed encrypted message structure (no literal data payload found)"
        _ ->
            failWith
                BadData
                "decrypt failed: malformed encrypted message structure (multiple literal data payloads found)"

doDecryptVerifyOutput
    :: POSIXTime
    -> [String]
    -> Maybe String
    -> Maybe String
    -> Maybe String
    -> [Pkt]
    -> IO ()
doDecryptVerifyOutput cpt certFiles outFile notBeforeArg notAfterArg decryptedPkts = do
    when (null certFiles) $
        failWith
            IncompleteVerification
            "decrypt: verification requires at least one --verify-with cert"
    (krs, verifyTks) <- loadVerifyContext cpt certFiles
    upperBound <- verificationUpperBound cpt notAfterArg
    lowerBound <- verificationLowerBound cpt notBeforeArg
    verificationPkts <-
        normalizeDecryptVerificationPackets decryptedPkts
    let verifications =
            map
                (first show)
                (verifyPacketsBatch krs upperBound verificationPkts)
        filtered = filterByVerificationBounds lowerBound upperBound verifications
        successLines =
            map (renderSOPVerificationLine verifyTks) (rights filtered)
        renderedOut =
            if null successLines
                then ""
                else unlines successLines
    case outFile of
        Just path -> writeFileWithOutputExistsCheck "decrypt" path renderedOut
        Nothing -> pure ()

normalizeDecryptVerificationPackets :: [Pkt] -> IO [Pkt]
normalizeDecryptVerificationPackets pkts =
    case ( [pkt | pkt@LiteralDataPkt {} <- pkts]
         , [pkt | pkt@SignaturePkt {} <- pkts]
         ) of
        ([], _) ->
            failWith
                CannotDecrypt
                "decrypt failed: no literal data payload found"
        ([lit], []) -> pure [lit]
        ([lit], sigs) -> pure (lit : sigs)
        (_, _) ->
            failWith
                BadData
                "decrypt failed: malformed signed message structure (multiple literal payloads)"

resolveDecryptVerificationsOut
    :: Maybe String -> IO (Maybe String)
resolveDecryptVerificationsOut newPath =
    pure $ case newPath of
        Just p -> Just p
        Nothing -> Nothing

renderSOPVerificationLine
    :: [SomeTK] -> Verification -> String
renderSOPVerificationLine verifyTks v =
    ts
        ++ " "
        ++ signerFp
        ++ " "
        ++ certFp
        ++ " "
        ++ modeLabel
        ++ " "
        ++ jsonTrailer
  where
    sig = _verificationSignature v
    ts = renderSOPVerificationTimestamp sig
    signer = fingerprint (_verificationSigner v)
    signerFp = hexEncodeBytes (BL.toStrict (unFingerprint signer))
    modeLabel = signatureModeField sig
    certFp =
        case find (\tk -> keyMatchesFingerprint True tk signer) verifyTks of
            Just tk ->
                hexEncodeBytes
                    ( BL.toStrict
                        ( unFingerprint
                            ( fingerprint
                                (keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk)))
                            )
                        )
                    )
            Nothing -> signerFp
    jsonTrailer = "{\"signers\":[{\"fingerprint\":\"" ++ signerFp ++ "\"}]}"

signatureModeField :: SignaturePayload -> String
signatureModeField sig =
    case sig of
        SigV4 CanonicalTextSig _ _ _ _ _ _ -> "mode:text"
        SigV6 CanonicalTextSig _ _ _ _ _ _ _ -> "mode:text"
        _ -> "mode:binary"

renderSOPVerificationTimestamp :: SignaturePayload -> String
renderSOPVerificationTimestamp sig =
    formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" $
        case signatureCreationTime sig of
            Just t -> t
            Nothing -> posixSecondsToUTCTime 0

writeFileWithOutputExistsCheck
    :: String -> FilePath -> String -> IO ()
writeFileWithOutputExistsCheck subcommand path content = do
    ensureOutputPathAvailable subcommand path
    writeFile path content

parseOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]
parseOpenPGPPackets context bytes =
    ( do
        let packets =
                concatMap
                    (either (const []) id . decompressPkt)
                    (parsePkts bytes)
        _ <- evaluate (length packets)
        pure packets
    )
        `catch` parseFailure
  where
    parseFailure :: SomeException -> IO [Pkt]
    parseFailure err =
        failWith
            BadData
            ( context
                ++ ": failed to parse OpenPGP packets: "
                ++ displayException err
            )

parseRawOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]
parseRawOpenPGPPackets context bytes =
    ( do
        let packets = parsePkts bytes
        _ <- evaluate (length packets)
        pure packets
    )
        `catch` parseFailure
  where
    parseFailure :: SomeException -> IO [Pkt]
    parseFailure err =
        failWith
            BadData
            ( context
                ++ ": failed to parse OpenPGP packets: "
                ++ displayException err
            )

validateDecryptPartialBodyEncoding :: BL.ByteString -> IO ()
validateDecryptPartialBodyEncoding ciphertext =
    case ensureNoShortFirstPartialBodyChunk (BL.toStrict ciphertext) of
        Left err ->
            failWith
                BadData
                ("decrypt input: invalid partial body encoding (" ++ err ++ ")")
        Right () -> pure ()

ensureNoShortFirstPartialBodyChunk
    :: B.ByteString -> Either String ()
ensureNoShortFirstPartialBodyChunk = parsePackets
  where
    parsePackets bs
        | B.null bs = Right ()
        | otherwise = do
            (header, rest) <-
                noteLeft "truncated packet header" (B.uncons bs)
            if header .&. 0x80 /= 0x80
                then Left "invalid packet header octet"
                else do
                    remaining <-
                        if header .&. 0x40 == 0x40
                            then parseNewPacketBody rest
                            else parseOldPacketBody (header .&. 0x03) rest
                    parsePackets remaining

    parseOldPacketBody lengthType bs =
        case lengthType of
            0 -> do
                (lenOctet, rest) <-
                    noteLeft "truncated old-format one-octet length" (B.uncons bs)
                dropExact
                    "truncated old-format packet body"
                    (fromIntegral lenOctet)
                    rest
            1 -> do
                (hi, afterHi) <-
                    noteLeft "truncated old-format two-octet length" (B.uncons bs)
                (lo, rest) <-
                    noteLeft
                        "truncated old-format two-octet length"
                        (B.uncons afterHi)
                let len = fromIntegral hi * 256 + fromIntegral lo
                dropExact "truncated old-format packet body" len rest
            2 -> do
                (b1, afterB1) <-
                    noteLeft "truncated old-format four-octet length" (B.uncons bs)
                (b2, afterB2) <-
                    noteLeft
                        "truncated old-format four-octet length"
                        (B.uncons afterB1)
                (b3, afterB3) <-
                    noteLeft
                        "truncated old-format four-octet length"
                        (B.uncons afterB2)
                (b4, rest) <-
                    noteLeft
                        "truncated old-format four-octet length"
                        (B.uncons afterB3)
                let len =
                        (fromIntegral b1 `shiftL` 24)
                            + (fromIntegral b2 `shiftL` 16)
                            + (fromIntegral b3 `shiftL` 8)
                            + fromIntegral b4
                dropExact "truncated old-format packet body" len rest
            3 -> Right B.empty
            _ -> Left "invalid old-format length type"

    parseNewPacketBody = parseNewLengthChunks True

    parseNewLengthChunks isFirstChunk bs = do
        (chunkLength, isPartial, afterLength) <- parseNewLength bs
        when (isFirstChunk && isPartial && chunkLength < 512) $
            Left
                ( "first partial chunk is too short ("
                    ++ show chunkLength
                    ++ " octets, minimum is 512)"
                )
        afterChunk <-
            dropExact
                "truncated new-format packet body chunk"
                chunkLength
                afterLength
        if isPartial
            then parseNewLengthChunks False afterChunk
            else Right afterChunk

    parseNewLength bs = do
        (lengthOctet, rest) <-
            noteLeft "truncated new-format length" (B.uncons bs)
        case lengthOctet of
            _
                | lengthOctet < 192 ->
                    Right (fromIntegral lengthOctet, False, rest)
                | lengthOctet < 224 -> do
                    (nextOctet, afterNext) <-
                        noteLeft "truncated new-format two-octet length" (B.uncons rest)
                    let len =
                            ((fromIntegral lengthOctet - 192) `shiftL` 8)
                                + fromIntegral nextOctet
                                + 192
                    Right (len, False, afterNext)
                | lengthOctet < 255 ->
                    Right
                        ( 1 `shiftL` fromIntegral (lengthOctet .&. 0x1f)
                        , True
                        , rest
                        )
                | otherwise -> do
                    (b1, afterB1) <-
                        noteLeft "truncated new-format five-octet length" (B.uncons rest)
                    (b2, afterB2) <-
                        noteLeft
                            "truncated new-format five-octet length"
                            (B.uncons afterB1)
                    (b3, afterB3) <-
                        noteLeft
                            "truncated new-format five-octet length"
                            (B.uncons afterB2)
                    (b4, afterB4) <-
                        noteLeft
                            "truncated new-format five-octet length"
                            (B.uncons afterB3)
                    let len =
                            (fromIntegral b1 `shiftL` 24)
                                + (fromIntegral b2 `shiftL` 16)
                                + (fromIntegral b3 `shiftL` 8)
                                + fromIntegral b4
                    Right (len, False, afterB4)

    dropExact context n bs
        | B.length bs < n = Left context
        | otherwise = Right (B.drop n bs)

    noteLeft err = maybe (Left err) Right

ensureOutputPathAvailable :: String -> FilePath -> IO ()
ensureOutputPathAvailable subcommand path = do
    exists <- doesFileExist path
    when exists $
        failWith
            OutputExists
            (subcommand ++ ": output path already exists: " ++ path)

loadVerifyContext
    :: POSIXTime -> [String] -> IO (PublicKeyring, [SomeTK])
loadVerifyContext _ certFiles = do
    allTks <-
        mapMaybe enforceVerifyPrimaryKeyPolicy
            . map sanitizeVerifyTK
            . concat
            <$> mapM (loadCertTKsFromFile "verify") certFiles
    let publicTks =
            mapMaybe
                ( \tk ->
                    case tk of
                        SomePublicTK publicTk -> Just publicTk
                        SomeSecretTK secretTk -> Just (publicViewTK secretTk)
                )
                allTks
    keyring <-
        runConduitRes $ CL.sourceList publicTks .| sinkPublicKeyringMap
    pure (keyring, allTks)

loadVerifyTKsFromFile :: String -> String -> IO [SomeTK]
loadVerifyTKsFromFile context path = do
    lbs <- loadInputFromFile context "file" path
    certPkts <- decodeOpenPGPInput path lbs
    runConduitRes $
        CL.sourceList certPkts
            .| conduitToSomeTKsDroppingEither
            .| conduitDropErrorsAndNothings
            .| CC.sinkList

loadCertTKsFromFile :: String -> String -> IO [SomeTK]
loadCertTKsFromFile context path = do
    lbs <- loadInputFromFile context "file" path
    certPkts <- decodeOpenPGPInput path lbs
    rejectSecretKeyPackets context path certPkts
    runConduitRes $
        CL.sourceList certPkts
            .| conduitToSomeTKsDroppingEither
            .| conduitDropErrorsAndNothings
            .| CC.sinkList

rejectSecretKeyPackets :: String -> String -> [Pkt] -> IO ()
rejectSecretKeyPackets context path packets =
    when (any isSecretKeyPacket packets) $
        failWith
            BadData
            ( context
                ++ ": certificate input contains secret key material in "
                ++ path
            )
  where
    isSecretKeyPacket SecretKeyPkt {} = True
    isSecretKeyPacket SecretSubkeyPkt {} = True
    isSecretKeyPacket _ = False

sanitizeVerifyTK :: SomeTK -> SomeTK
sanitizeVerifyTK stk =
    case primaryKeyIdentity stk of
        Nothing -> stk
        Just _ ->
            case stk of
                SomePublicTK tk -> SomePublicTK tk {_tkSubs = map sanitize (_tkSubs tk)}
                SomeSecretTK tk -> SomeSecretTK tk {_tkSubs = map sanitize (_tkSubs tk)}
  where
    publicView = someTKToPublicViewTK stk
    pkp = keyPktPKPayload (_tkPrimaryKey publicView)
    primaryFp = fingerprint pkp
    primaryKeyId =
        either
            (error "sanitizeVerifyTK: no key ID")
            id
            (eightOctetKeyID pkp)
    sanitize
        :: (KeyPkt k, [SignaturePayload]) -> (KeyPkt k, [SignaturePayload])
    sanitize (kp, sigs) =
        let sanitized =
                mapMaybe (sanitizeBindingSignature primaryFp primaryKeyId) sigs
         in if isSubkeyPacket (keyPktToPkt kp)
                then (kp, sanitized)
                else (kp, sigs)
    isSubkeyPacket (PublicSubkeyPkt {}) = True
    isSubkeyPacket (SecretSubkeyPkt {}) = True
    isSubkeyPacket _ = False

enforceVerifyPrimaryKeyPolicy :: SomeTK -> Maybe SomeTK
enforceVerifyPrimaryKeyPolicy tk =
    if primaryKeyTooSmallForVerification tk
        then Nothing
        else Just tk

primaryKeyTooSmallForVerification :: SomeTK -> Bool
primaryKeyTooSmallForVerification stk =
    case _pkalgo pkp of
        RSA -> rsaTooSmall
        DeprecatedRSASignOnly -> rsaTooSmall
        DeprecatedRSAEncryptOnly -> rsaTooSmall
        _ -> False
  where
    pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk))
    rsaTooSmall =
        case pubkeySize (_pubkey pkp) of
            Right bits -> bits < 2048
            Left _ -> False

primaryKeyIdentity
    :: SomeTK -> Maybe (Fingerprint, EightOctetKeyId)
primaryKeyIdentity stk = do
    let pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk))
    keyId <- either (const Nothing) Just (eightOctetKeyID pkp)
    pure (fingerprint pkp, keyId)

sanitizeBindingSignature
    :: Fingerprint
    -> EightOctetKeyId
    -> SignaturePayload
    -> Maybe SignaturePayload
sanitizeBindingSignature _ _ sig
    | hasUnsupportedCriticalSubpacket sig = Nothing
    | hasUnsupportedCriticalEmbeddedBacksig sig = Nothing
    | otherwise = Just sig
  where
    hasUnsupportedCriticalSubpacket sp =
        any isUnsupportedCriticalSubpacket (signatureHashedSubpackets sp)
    hasUnsupportedCriticalEmbeddedBacksig sp =
        any
            ( \ssp ->
                case _sspPayload ssp of
                    EmbeddedSignature embedded ->
                        any
                            isUnsupportedCriticalSubpacket
                            (signatureHashedSubpackets embedded)
                    _ -> False
            )
            (signatureHashedSubpackets sp)
    isUnsupportedCriticalSubpacket (SigSubPacket isCritical payload) =
        isCritical
            && case payload of
                UserDefinedSigSub {} -> True
                OtherSigSub {} -> True
                NotationData {} -> True
                _ -> False

loadDecryptRecipientKeys
    :: POSIXTime
    -> String
    -> [String]
    -> [BL.ByteString]
    -> IO [PKESKRecipientKey]
loadDecryptRecipientKeys _ _ [] _ = pure []
loadDecryptRecipientKeys cpt context keyFiles passwords = concat <$> mapM loadFromFile keyFiles
  where
    loadFromFile path = do
        lbs <- loadInputFromFile context "file" path
        packets <- decodeOpenPGPInput path lbs
        -- Build the set of fingerprints that are explicitly non-encryption-capable.
        -- Keys not resolvable via TK (processTK failure, bare material) are allowed.
        nonEncFps <- buildNonEncryptionFingerprintSet packets
        keys <-
            mapM (packetRecipientKey path nonEncFps) packets
                >>= pure . catMaybes
        let brokenSecretKeyErrors =
                nub
                    [ err
                    | BrokenPacketPkt err tag _ <- packets
                    , tag == 5 || tag == 7
                    ]
        when (null keys && not (null brokenSecretKeyErrors)) $
            failWith
                CannotDecrypt
                ( "decrypt failed: could not load usable secret key material from "
                    ++ path
                    ++ " ("
                    ++ intercalate "; " brokenSecretKeyErrors
                    ++ ")"
                )
        pure keys
    -- Build a set of fingerprints that are EXPLICITLY non-encryption-capable.
    -- Only keys whose binding signature carries a KeyFlags subpacket that does
    -- NOT include any encryption bit are added.  Keys with no binding-sig TK
    -- (processTK failed, bare secret material, etc.) are NOT blocked — we fall
    -- back to allowing them so that newly-generated or unusual keys still work.
    buildNonEncryptionFingerprintSet packets = do
        tks <-
            runConduitRes $
                CL.sourceList packets
                    .| conduitToSomeTKsDroppingEither
                    .| conduitDropErrorsAndNothings
                    .| CC.sinkList
        let normTks = rights (map (processTK (Just cpt)) tks)
        let tkDerived = S.fromList (concatMap nonEncryptionFingerprints normTks)
            rawDerived = S.fromList (explicitNonEncryptionSubkeyFingerprints packets)
        return (S.union tkDerived rawDerived)
    nonEncryptionFingerprints tk =
        -- Primary key: add to blocklist only if explicit key-flags are present
        -- and all of them exclude encryption usage.
        let primaryPkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk))
            primaryFp = unFingerprint (fingerprint primaryPkp)
            publicView = someTKToPublicViewTK tk
            primarySigs =
                concatMap snd (_tkUIDs publicView)
                    ++ concatMap snd (_tkUAts publicView)
                    ++ _tkRevs publicView
            primaryEntry = [primaryFp | not (sigsAllowEncryption primarySigs)]
            -- Subkeys: same rule as primary.
            subEntries =
                [ unFingerprint (fingerprint pkp)
                | (kp, sigs) <- _tkSubs publicView
                , let pkp = keyPktPKPayload kp
                , not (sigsAllowEncryption sigs)
                ]
            blocked = primaryEntry ++ subEntries
         in if tkHasAnyEncryptionCapableKey tk
                then blocked
                else []
    explicitNonEncryptionSubkeyFingerprints packets =
        let (mPending, blocked) = foldl' step (Nothing, []) packets
         in maybe
                blocked
                ( \(fp, hasEnc, sawKeyFlags) -> finalize fp hasEnc sawKeyFlags blocked
                )
                mPending
      where
        step (mPending, blocked) pkt =
            case pkt of
                PublicSubkeyPkt pkp ->
                    ( Just (unFingerprint (fingerprint pkp), False, False)
                    , finalizePending mPending blocked
                    )
                SecretSubkeyPkt pkp _ ->
                    ( Just (unFingerprint (fingerprint pkp), False, False)
                    , finalizePending mPending blocked
                    )
                SignaturePkt sig ->
                    case mPending of
                        Nothing -> (Nothing, blocked)
                        Just (fp, hasEnc, sawKeyFlags) ->
                            let usableSig =
                                    if signatureHasUnsupportedCriticalSubpackets sig
                                        then []
                                        else keyFlagsFromSig sig
                                hasEnc' = hasEnc || any hasEncryptionFlag usableSig
                                sawKeyFlags' = sawKeyFlags || not (null usableSig)
                             in (Just (fp, hasEnc', sawKeyFlags'), blocked)
                _ -> (Nothing, finalizePending mPending blocked)
        finalizePending Nothing blocked = blocked
        finalizePending (Just (fp, hasEnc, sawKeyFlags)) blocked =
            finalize fp hasEnc sawKeyFlags blocked
        finalize fp hasEnc sawKeyFlags blocked
            | sawKeyFlags && not hasEnc = fp : blocked
            | otherwise = blocked
    tkHasAnyEncryptionCapableKey tk =
        let primaryPkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk))
            publicView = someTKToPublicViewTK tk
            primarySigs =
                concatMap snd (_tkUIDs publicView)
                    ++ concatMap snd (_tkUAts publicView)
                    ++ _tkRevs publicView
            primaryAllows =
                supportsRecipientPKESKAlgorithm primaryPkp
                    && sigsAllowEncryption primarySigs
            subAllows =
                any
                    ( \(kp, sigs) ->
                        supportsRecipientPKESKAlgorithm (keyPktPKPayload kp)
                            && sigsAllowEncryption sigs
                    )
                    (_tkSubs publicView)
         in primaryAllows || subAllows
    sigsAllowEncryption [] = True
    sigsAllowEncryption sigs =
        let usableSigs = filter (not . signatureHasUnsupportedCriticalSubpackets) sigs
            flagSets = concatMap keyFlagsFromSig usableSigs
         in if null usableSigs
                then False
                else null flagSets || any hasEncryptionFlag flagSets
    hasEncryptionFlag flags =
        S.member EncryptCommunicationsKey flags
            || S.member EncryptStorageKey flags
    keyFlagsFromSig sig =
        case sig of
            SigV4 _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds
            SigV6 _ _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds
            _ -> []
    signatureHasUnsupportedCriticalSubpackets sig =
        let hasheds =
                case sig of
                    SigV4 _ _ _ hs _ _ _ -> hs
                    SigV6 _ _ _ _ hs _ _ _ -> hs
                    _ -> []
         in any isUnsupportedCritical hasheds
    isUnsupportedCritical (SigSubPacket isCritical payload) =
        isCritical
            && case payload of
                OtherSigSub {} -> True
                UserDefinedSigSub {} -> True
                NotationData {} -> True
                _ -> False
    keyFlagsFromSubpackets subpackets =
        [ flags
        | SigSubPacket _ (KeyFlags flags) <- subpackets
        ]
    packetRecipientKey path nonEncFps (SecretKeyPkt pkp ska) =
        let fp = unFingerprint (fingerprint pkp)
         in if S.member fp nonEncFps
                then pure Nothing
                else decryptRecipientKey path pkp ska
    packetRecipientKey path nonEncFps (SecretSubkeyPkt pkp ska) =
        let fp = unFingerprint (fingerprint pkp)
         in if S.member fp nonEncFps
                then pure Nothing
                else decryptRecipientKey path pkp ska
    packetRecipientKey _ _ _ = pure Nothing
    decryptRecipientKey path pkp ska =
        case secretKeyProtectionPolicyViolation pkp ska of
            Just violation ->
                failWith
                    KeyIsProtected
                    ( "decrypt failed: unsupported secret key protection in "
                        ++ path
                        ++ " ("
                        ++ violation
                        ++ ")"
                    )
            Nothing ->
                case ska of
                    SUUnencrypted skey _ ->
                        pure
                            ( Just
                                ( PKESKRecipientKey
                                    { pkeskRecipientPKPayload = Just pkp
                                    , pkeskRecipientSKey = skey
                                    }
                                )
                            )
                    _ ->
                        case passwords of
                            [] ->
                                failWith
                                    KeyIsProtected
                                    ( "decrypt failed: encrypted key in "
                                        ++ path
                                        ++ " requires --with-key-password"
                                    )
                            _ ->
                                case tryDecryptKey passwords of
                                    Left _ ->
                                        failWith
                                            KeyIsProtected
                                            ( "decrypt failed: could not decrypt key in "
                                                ++ path
                                                ++ " with provided --with-key-password values"
                                            )
                                    Right (SUUnencrypted skey _) ->
                                        pure
                                            ( Just
                                                ( PKESKRecipientKey
                                                    { pkeskRecipientPKPayload = Just pkp
                                                    , pkeskRecipientSKey = skey
                                                    }
                                                )
                                            )
                                    Right _ ->
                                        failWith
                                            KeyIsProtected
                                            ("decrypt failed: unsupported secret key protection in " ++ path)
      where
        secretKeyProtectionPolicyViolation recipientPkp addendum =
            let rejectArgon2WithoutAEAD s2k
                    | isArgon2S2K s2k =
                        Just "Argon2 S2K is only allowed with AEAD-protected secret keys"
                    | otherwise = Nothing
                rejectSimpleForV6 s2k
                    | isSimpleS2K s2k =
                        Just "v6 secret key packets MUST NOT use simple S2K"
                    | otherwise = Nothing
             in case addendum of
                    SUS16bit _ s2k _ _ ->
                        case _keyVersion recipientPkp of
                            V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k
                            _ -> rejectArgon2WithoutAEAD s2k
                    SUSSHA1 _ s2k _ _ ->
                        case _keyVersion recipientPkp of
                            V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k
                            _ -> rejectArgon2WithoutAEAD s2k
                    SUSym {} ->
                        if _keyVersion recipientPkp == V6
                            then
                                Just
                                    "v6 secret key packets MUST NOT use legacy CFB secret-key protection"
                            else Nothing
                    _ -> Nothing
        isArgon2S2K Argon2 {} = True
        isArgon2S2K _ = False
        isSimpleS2K (Simple _) = True
        isSimpleS2K _ = False
        tryDecryptKey [] = Left ()
        tryDecryptKey (password : rest) =
            case decryptPrivateKey (pkp, ska) password of
                Left _ -> tryDecryptKey rest
                Right decrypted -> Right decrypted

decodeOpenPGPInput :: String -> BL.ByteString -> IO [Pkt]
decodeOpenPGPInput path input = do
    decodedArmors <-
        decodeAsciiArmorInput ("OpenPGP input in " ++ path) input
    case decodedArmors of
        Just armors ->
            case firstBy isOpenPGPArmorBlock armors of
                Just (Armor _ _ bs) ->
                    parseOpenPGPPackets
                        ("armored OpenPGP input in " ++ path)
                        (BL.fromStrict (BLC8.toStrict bs))
                _ ->
                    case firstBy isClearSignedArmor armors of
                        Just _ ->
                            failWith
                                BadData
                                ("Expected key data in " ++ path ++ ", got cleartext signature")
                        _ -> parseOpenPGPPackets "OpenPGP input" input
        Nothing -> parseOpenPGPPackets "OpenPGP input" input

loadRecipientPreferredHashes
    :: POSIXTime -> [String] -> IO [HashAlgorithm]
loadRecipientPreferredHashes cpt certFiles =
    concat <$> mapM loadFromFile certFiles
  where
    loadFromFile path = do
        lbs <- loadInputFromFile "encrypt" "file" path
        pkts <- decodeOpenPGPInput path lbs
        rejectSecretKeyPackets "encrypt" path pkts
        tks <-
            runConduitRes $
                CL.sourceList pkts
                    .| conduitToSomeTKsDroppingEither
                    .| conduitDropErrorsAndNothings
                    .| CC.sinkList
        normalized <- mapM (normalizeRecipient path) tks
        pure
            (concatMap (effectiveHashPreferencesAt cpt) normalized)
    normalizeRecipient path tk =
        case processTK (Just cpt) tk of
            Left err ->
                failWith
                    BadData
                    ( "encrypt: invalid recipient certificate in "
                        ++ path
                        ++ ": "
                        ++ show err
                    )
            Right normalized -> pure normalized

loadEncryptRecipients
    :: POSIXTime -> EncryptFor -> [String] -> IO [FunKey]
loadEncryptRecipients cpt encPurpose certFiles = do
    recipients <- concat <$> mapM loadRecipientsFromFile certFiles
    if null recipients
        then
            failWith
                CertCannotEncrypt
                "encrypt: no supported recipient encryption keys found in provided certificates"
        else pure recipients
  where
    loadRecipientsFromFile path = do
        lbs <- loadInputFromFile "encrypt" "file" path
        pkts <- decodeOpenPGPInput path lbs
        rejectSecretKeyPackets "encrypt" path pkts
        rejectCriticalUnknownRecipientPackets path pkts
        tks <-
            runConduitRes $
                CL.sourceList pkts
                    .| conduitToSomeTKsDroppingEither
                    .| conduitDropErrorsAndNothings
                    .| CC.sinkList
        normalized <- mapM (normalizeEncryptRecipientTK path) tks
        let selected =
                selectEncryptRecipients
                    encPurpose
                    (concatMap (tkToFunKeysAt cpt) normalized)
            packetFallback =
                nub
                    ( concatMap tkToEncryptPayloads normalized
                        ++ mapMaybe extractEncryptRecipientPayload pkts
                    )
        pure $
            case encPurpose of
                EncryptForAny
                    | null selected -> map payloadToFunKey packetFallback
                _ -> selected
    normalizeEncryptRecipientTK path tk =
        case processTK (Just cpt) tk of
            Left err ->
                failWith
                    BadData
                    ( "encrypt: invalid recipient certificate in "
                        ++ path
                        ++ ": "
                        ++ show err
                    )
            Right normalized ->
                if not
                    ( isTKTimeValid
                        (posixSecondsToUTCTime (realToFrac cpt))
                        (someTKToPublicViewTK normalized)
                    )
                    then
                        failWith
                            CertCannotEncrypt
                            ("encrypt: recipient certificate in " ++ path ++ " is expired")
                    else
                        if not (primaryUserIDExpirationAllowsAt cpt normalized)
                            then
                                failWith
                                    CertCannotEncrypt
                                    ("encrypt: recipient certificate in " ++ path ++ " is expired")
                            else pure normalized
    rejectCriticalUnknownRecipientPackets path =
        mapM_
            ( \pkt ->
                case pkt of
                    OtherPacketPkt tag _
                        | tag < 40 ->
                            if isForwardCompatRecipientPacketTag tag
                                then pure ()
                                else
                                    failWith
                                        BadData
                                        ( "encrypt: invalid recipient certificate in "
                                            ++ path
                                            ++ ": critical unknown packet tag "
                                            ++ show tag
                                        )
                    BrokenPacketPkt _ tag _
                        | tag < 40 ->
                            if isForwardCompatRecipientPacketTag tag
                                then pure ()
                                else
                                    failWith
                                        BadData
                                        ( "encrypt: invalid recipient certificate in "
                                            ++ path
                                            ++ ": critical unknown packet tag "
                                            ++ show tag
                                        )
                    _ -> pure ()
            )
    isForwardCompatRecipientPacketTag tag = tag `elem` [5, 6, 7, 14]
    payloadToFunKey pkp = FunKey pkp Nothing S.empty [] [] False

primaryUserIDExpirationAllowsAt :: POSIXTime -> SomeTK -> Bool
primaryUserIDExpirationAllowsAt now tk =
    case primaryUidSigs of
        [] -> True
        _ ->
            any
                (signatureKeyExpirationAllowsAt now primaryCreatedAt)
                primaryUidSigs
  where
    publicView = someTKToPublicViewTK tk
    primaryCreatedAt =
        fromIntegral
            (_timestamp (keyPktPKPayload (_tkPrimaryKey publicView)))
    primaryUidSigs =
        [ sig
        | (_, sigs) <- _tkUIDs publicView
        , sig <- sigs
        , signatureMarksPrimaryUserId sig
        ]

signatureMarksPrimaryUserId :: SignaturePayload -> Bool
signatureMarksPrimaryUserId sig =
    any isPrimaryUIDSubpacket (signatureSubpackets sig)
  where
    isPrimaryUIDSubpacket (SigSubPacket _ (PrimaryUserId True)) = True
    isPrimaryUIDSubpacket _ = False

signatureKeyExpirationAllowsAt
    :: POSIXTime -> POSIXTime -> SignaturePayload -> Bool
signatureKeyExpirationAllowsAt now createdAt sig =
    case signatureKeyValiditySeconds sig of
        Nothing -> True
        Just 0 -> True
        Just validitySeconds -> now < createdAt + fromIntegral validitySeconds

signatureKeyValiditySeconds :: SignaturePayload -> Maybe Integer
signatureKeyValiditySeconds sig =
    listToMaybe
        [ fromIntegral secs
        | SigSubPacket _ (KeyExpirationTime (ThirtyTwoBitDuration secs)) <-
            signatureSubpackets sig
        ]

selectEncryptRecipients :: EncryptFor -> [FunKey] -> [FunKey]
selectEncryptRecipients encPurpose keys =
    chosen
  where
    supported = filter (supportsRecipientPKESKAlgorithm . fpkp) keys
    (matchingPurpose, unrestrictedPurpose) =
        partition (keyMatchesEncryptPurpose encPurpose . fkufs) supported
    chosen =
        case encPurpose of
            EncryptForAny
                | null matchingPurpose -> unrestrictedPurpose
            _ -> matchingPurpose

tkToEncryptPayloads :: SomeTK -> [SomePKPayload]
tkToEncryptPayloads stk =
    filter
        supportsRecipientPKESKAlgorithm
        (someTKToUnknown stk ^.. biplate :: [SomePKPayload])

extractEncryptRecipientPayload :: Pkt -> Maybe SomePKPayload
extractEncryptRecipientPayload pkt =
    case pkt of
        PublicKeyPkt pkp
            | supportsRecipientPKESKAlgorithm pkp -> Just pkp
        PublicSubkeyPkt pkp
            | supportsRecipientPKESKAlgorithm pkp -> Just pkp
        SecretKeyPkt pkp _
            | supportsRecipientPKESKAlgorithm pkp -> Just pkp
        SecretSubkeyPkt pkp _
            | supportsRecipientPKESKAlgorithm pkp -> Just pkp
        _ -> Nothing

keyMatchesEncryptPurpose :: EncryptFor -> S.Set KeyFlag -> Bool
keyMatchesEncryptPurpose encPurpose keyFlags =
    not (S.null (keyFlags `S.intersection` encryptUsageFlags))
  where
    encryptUsageFlags =
        case encPurpose of
            EncryptForAny -> S.fromList [EncryptStorageKey, EncryptCommunicationsKey]
            EncryptForStorage -> S.singleton EncryptStorageKey
            EncryptForCommunications -> S.singleton EncryptCommunicationsKey

supportsRecipientPKESKAlgorithm :: SomePKPayload -> Bool
supportsRecipientPKESKAlgorithm pkp =
    _pkalgo pkp
        `elem` [ RSA
               , DeprecatedRSAEncryptOnly
               , ElgamalEncryptOnly
               , ECDH
               , X25519
               , X448
               ]
        && hasSupportedRecipientIdentifierLength pkp

hasSupportedRecipientIdentifierLength :: SomePKPayload -> Bool
hasSupportedRecipientIdentifierLength pkp =
    let keyIdentifierLen = BL.length (unFingerprint (fingerprint pkp))
     in keyIdentifierLen == 16
            || keyIdentifierLen == 20
            || keyIdentifierLen == 32

renderPKESKEncryptError :: PKESKEncryptError -> String
renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm symAlgo err) =
    "unsupported session-key algorithm "
        ++ show symAlgo
        ++ ": "
        ++ err
renderPKESKEncryptError (InvalidSessionKeyLength symAlgo expected got) =
    "invalid session-key length for "
        ++ show symAlgo
        ++ " (expected "
        ++ show expected
        ++ ", got "
        ++ show got
        ++ ")"
renderPKESKEncryptError (UnsupportedRecipientAlgorithm pka) =
    "unsupported recipient public-key algorithm: " ++ show pka
renderPKESKEncryptError (InvalidRecipientKeyMaterial pka err) =
    "invalid recipient key material for " ++ show pka ++ ": " ++ err
renderPKESKEncryptError (RecipientKdfFailure pka err) =
    "recipient KDF failure for " ++ show pka ++ ": " ++ err
renderPKESKEncryptError (RecipientKeyWrapFailure pka err) =
    "recipient key-wrap failure for " ++ show pka ++ ": " ++ err
renderPKESKEncryptError (PayloadBuildFailure err) = "payload build failure: " ++ err
renderPKESKEncryptError NoRecipientsProvided = "no recipients were provided"
renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) =
    "recipient capability selection failure: " ++ show err
renderPKESKEncryptError (InvalidRecipientIdentifier err) =
    "invalid recipient identifier: " ++ err

sopFailureForPKESKEncryptError :: PKESKEncryptError -> SopFailure
sopFailureForPKESKEncryptError err =
    case err of
        UnsupportedRecipientAlgorithm _ -> UnsupportedAsymmetricAlgo
        RecipientCapabilitySelectionFailure _ -> CertCannotEncrypt
        NoRecipientsProvided -> CertCannotEncrypt
        _ -> BadData

{- | Resolve a PKESK recipient key using two strategies depending on whether
the probe carries a wildcard recipient ID (eight zero bytes) or a real key
ID / fingerprint.

* Non-wildcard probes: the callback is invoked once for each PKESK attempt,
  so we do an idempotent lookup by recipient identifier from the full
  candidate list to avoid consuming keys needed by later PKESKs.

* Wildcard probes (all-zero legacy recipient ID): hOpenPGP retries the
  callback after failed unwrap attempts. We therefore pop one candidate from
  a shared queue on each callback invocation.
-}
selectRecipientKeyInfosByRecipientIdentifier
    :: [PKESKRecipientKey]
    -> KeyIdentifier
    -> PubKeyAlgorithm
    -> IO [PKESKRecipientKey]
selectRecipientKeyInfosByRecipientIdentifier keyInfos keyIdentifier pka =
    pure $
        case keyIdentifier of
            KeyIdentifierWildcard -> compatible
            KeyIdentifierEightOctet recipientKeyId ->
                filter (matchesLegacyRecipientKeyId recipientKeyId) compatible
            KeyIdentifierFingerprint recipientFingerprint ->
                filter
                    (matchesRecipientIdentifier (unFingerprint recipientFingerprint))
                    compatible
  where
    compatible =
        [ keyInfo
        | keyInfo <- keyInfos
        , supportsPKESKAlgorithm pka keyInfo
        ]

prioritizeDecryptablePKESKs
    :: [PKESKRecipientKey] -> [Pkt] -> [Pkt]
prioritizeDecryptablePKESKs keyInfos pkts =
    nonMatchingPrefix ++ matchingPrefix ++ suffix
  where
    (prefix, suffix) = break isEncryptedPayloadPacket pkts
    (matchingPrefix, nonMatchingPrefix) =
        partition
            ( \pkt ->
                case pkt of
                    PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)) ->
                        any (matchesRecipientIdentifier rid) keyInfos
                    PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ eoki _ _)) ->
                        any (matchesLegacyRecipientKeyId eoki) keyInfos
                    _ -> False
            )
            prefix

supportsPKESKAlgorithm
    :: PubKeyAlgorithm -> PKESKRecipientKey -> Bool
supportsPKESKAlgorithm pka keyInfo =
    case pkeskRecipientSKey keyInfo of
        RSAPrivateKey {} -> pka == RSA || pka == DeprecatedRSAEncryptOnly
        ElGamalPrivateKey {} -> pka == ElgamalEncryptOnly
        ECDHPrivateKey {} -> pka == ECDH || pka == X25519
        X25519PrivateKey {} -> pka == X25519
        X448PrivateKey {} -> pka == X448
        UnknownSKey {} ->
            (pka == X25519 || pka == X448)
                && case pkeskRecipientPKPayload keyInfo of
                    Just pkp -> _pkalgo pkp == pka
                    Nothing -> False
        _ -> False

matchesRecipientIdentifier
    :: BL.ByteString -> PKESKRecipientKey -> Bool
matchesRecipientIdentifier rid keyInfo =
    case pkeskRecipientPKPayload keyInfo of
        Nothing -> False
        Just pkp ->
            let identifier = BL.toStrict rid
                fps = recipientFingerprintsForMatch pkp
             in any (identifier `elem`) (map recipientIdMatchVariants fps)

recipientFingerprintsForMatch :: SomePKPayload -> [B.ByteString]
recipientFingerprintsForMatch pkp =
    baseFp : maybeToList normalizedX25519Fp
  where
    baseFp = BL.toStrict (unFingerprint (fingerprint pkp))
    normalizedX25519Fp =
        BL.toStrict . unFingerprint . fingerprint
            <$> normalizeX25519CompatiblePKP pkp

normalizeX25519CompatiblePKP
    :: SomePKPayload -> Maybe SomePKPayload
normalizeX25519CompatiblePKP pkp =
    case _pubkey pkp of
        ECDHPubKey (EdDSAPubKey EdSigningCurve25519 _) _ _ ->
            Just
                ( PKPayload
                    (_keyVersion pkp)
                    (_timestamp pkp)
                    (_v3exp pkp)
                    X25519
                    (_pubkey pkp)
                )
        _ -> Nothing

recipientIdMatchVariants :: B.ByteString -> [B.ByteString]
recipientIdMatchVariants fp =
    [ fp
    , B.cons 0x04 fp
    , B.cons 0x06 fp
    , B.cons 0xFE fp
    ]

matchesLegacyRecipientKeyId
    :: EightOctetKeyId -> PKESKRecipientKey -> Bool
matchesLegacyRecipientKeyId eoki keyInfo =
    case pkeskRecipientPKPayload keyInfo of
        Nothing -> False
        Just pkp ->
            case eightOctetKeyID pkp of
                Right keyId -> keyId == eoki
                Left _ -> False

decodeCiphertextInput :: BL.ByteString -> IO BL.ByteString
decodeCiphertextInput input = do
    decodedArmors <- decodeAsciiArmorInput "decrypt input" input
    case decodedArmors of
        Just armors ->
            case firstBy isArmorMessageBlock armors of
                Just (Armor ArmorMessage _ bs) -> return (BL.fromStrict (BLC8.toStrict bs))
                _ ->
                    case firstBy isOpenPGPArmorBlock armors of
                        Just _ ->
                            failWith
                                BadData
                                "decrypt expects an armored OpenPGP message"
                        _ -> return input
        Nothing -> return input

doInlineSign :: POSIXTime -> InlineSignOptions -> IO ()
doInlineSign pt InlineSignOptions {..} = do
    let inlineMode = fromMaybe InlineSignAsBinary inlineSignAs
    mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
    when (inlineMode /= InlineSignAsBinary) $
        ensureUTF8TextInput "inline-sign" (BL.fromChunks mbs)
    signingPasswordsRaw <-
        loadPasswordFiles
            "inline-sign"
            "--with-key-password"
            inlineSignKeyPasswords
    let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw
    ks <-
        loadSigningKeys "inline-sign" inlineSignKeyFiles signingPasswords
    processedKeys <- mapM (normalizeSigningKey pt) ks
    let ts = ThirtyTwoBitTimeStamp (floor pt)
        payloadRaw = BL.fromChunks mbs
        funkeys = concatMap (tkToFunKeysAt pt) processedKeys
        signingKeys = filter isInlineRSASigner funkeys
        inlineSignHash =
            selectSigningHash signingKeys [] legacySigningHashFallbackOrder
    when (null signingKeys) $
        failWith MissingInput "inline-sign: no signing-capable key found"
    sigs <-
        mapM
            ( signInlineData
                ts
                (inlineSignSignatureMode inlineMode)
                inlineSignHash
                payloadRaw
            )
            signingKeys
    case inlineMode of
        InlineSignAsClearSigned -> doInlineSignCleartext inlineSignHash payloadRaw sigs
        InlineSignAsText -> doInlineSignText payloadRaw sigs
        InlineSignAsBinary -> doInlineSignBinary payloadRaw sigs
  where
    inlineSignSignatureMode mode =
        case mode of
            InlineSignAsBinary -> AsBinary
            InlineSignAsText -> AsText
            InlineSignAsClearSigned -> AsText
    doInlineSignCleartext inlineSignHash payloadRaw sigs = do
        when inlineSignNoArmor $
            failWith
                IncompatibleOptions
                "inline-sign --as=clearsigned requires armored output"
        let cleartextPayload =
                if not (BL.null payloadRaw) && BL.last payloadRaw == 0x0a
                    then payloadRaw <> BL.singleton 0x0a
                    else payloadRaw
            sigBytes = runPut $ mapM_ (Bin.put . SignaturePkt) sigs
            hashHeader = ("Hash", hashAlgorithmHeaderName inlineSignHash)
            clearSigned =
                ClearSigned
                    [hashHeader]
                    (BLC8.fromStrict (BL.toStrict cleartextPayload))
                    (Armor ArmorSignature [] (BLC8.fromStrict (BL.toStrict sigBytes)))
        BLC8.putStr (AA.encodeLazy [clearSigned])
    doInlineSignText payloadRaw sigs =
        doInlineSignMessage UTF8Data payloadRaw sigs
    doInlineSignBinary payloadRaw sigs = do
        doInlineSignMessage BinaryData payloadRaw sigs
    doInlineSignMessage literalDataType payloadRaw sigs = do
        let pktBytes =
                runPut $
                    Bin.put
                        ( Block
                            ( map SignaturePkt sigs
                                ++ [LiteralDataPkt literalDataType BL.empty 0 payloadRaw]
                            )
                        )
        BL.putStr $
            if not inlineSignNoArmor
                then AA.encodeLazy [Armor ArmorMessage [] pktBytes]
                else pktBytes

inlineSignModeReader :: String -> Either String InlineSignMode
inlineSignModeReader "binary" = Right InlineSignAsBinary
inlineSignModeReader "text" = Right InlineSignAsText
inlineSignModeReader "clearsigned" = Right InlineSignAsClearSigned
inlineSignModeReader _ =
    Left "signature mode must be one of: binary, text, clearsigned"

isInlineSigningCapable :: FunKey -> Bool
isInlineSigningCapable k =
    (S.null (fkufs k) || S.member SignDataKey (fkufs k))
        && case fmska k of
            Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True
            Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True
            Just (SUUnencrypted (UnknownSKey _) _) ->
                isEd25519PKA (_pkalgo (fpkp k))
                    || isEdDSAPKA (_pkalgo (fpkp k))
                    || isEd448PKA (_pkalgo (fpkp k))
            _ -> False

-- Legacy alias.
isInlineRSASigner :: FunKey -> Bool
isInlineRSASigner = isInlineSigningCapable

signInlineData
    :: ThirtyTwoBitTimeStamp
    -> AsBinaryText
    -> HashAlgorithm
    -> BL.ByteString
    -> FunKey
    -> IO SignaturePayload
signInlineData ts mode signHash payload k =
    do
        issuerPackets <- inlineUnhashed (fpkp k)
        signWithKey
            "inline-sign"
            (fpkp k)
            sigType
            signHash
            (inlineHashed (fpkp k) ts)
            issuerPackets
            payload
            (fmska k)
  where
    sigType =
        case mode of
            AsBinary -> BinarySig
            AsText -> CanonicalTextSig

inlineHashed
    :: SomePKPayload -> ThirtyTwoBitTimeStamp -> [SigSubPacket]
inlineHashed pkp ts =
    [ SigSubPacket False (SigCreationTime ts)
    , SigSubPacket
        False
        ( IssuerFingerprint
            (issuerFingerprintVersionFor pkp)
            (fingerprint pkp)
        )
    ]

inlineUnhashed :: SomePKPayload -> IO [SigSubPacket]
inlineUnhashed pkp =
    issuerSubpacketsFor "inline-sign" pkp

doInlineDetach :: POSIXTime -> InlineDetachOptions -> IO ()
doInlineDetach _ InlineDetachOptions {..} = do
    ensureOutputPathAvailable "inline-detach" inlineDetachOutputSigs
    input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
    (msgData, sigPkts) <- splitInlineSigned input
    writeDetachedSignatures
        inlineDetachNoArmor
        inlineDetachOutputSigs
        sigPkts
    BL.putStr msgData

splitInlineSigned :: BL.ByteString -> IO (BL.ByteString, [Pkt])
splitInlineSigned lbs = do
    decodedArmors <- decodeAsciiArmorInput "inline-detach input" lbs
    case decodedArmors of
        Just armors ->
            case firstBy isInlineSignedArmorCandidate armors of
                Just (Armor ArmorMessage _ bs) ->
                    parseOpenPGPPackets
                        "inline-detach armored message"
                        (BL.fromStrict (BLC8.toStrict bs))
                        >>= splitInlineSignedPackets
                Just (ClearSigned headers cleartext signatureArmor) -> do
                    validateClearSignedHeaders headers
                    sigPkts <- clearSignedSignaturePackets signatureArmor
                    return (BL.fromStrict (BLC8.toStrict cleartext), sigPkts)
                _ ->
                    parseOpenPGPPackets "inline-detach input" lbs
                        >>= splitInlineSignedPackets
        Nothing ->
            parseOpenPGPPackets "inline-detach input" lbs
                >>= splitInlineSignedPackets

firstBy :: (a -> Bool) -> [a] -> Maybe a
firstBy predicate = find predicate

decodeAsciiArmorInput
    :: String -> BL.ByteString -> IO (Maybe [Armor])
decodeAsciiArmorInput context input =
    case validateAsciiArmorEnvelope input of
        Just err ->
            failWith BadData (context ++ ": malformed ASCII armor: " ++ err)
        Nothing -> do
            let primaryDecode = AA.decodeLazy input :: Either String [Armor]
            case primaryDecode of
                Right (_ : _) -> pure (Just (fromRight [] primaryDecode))
                _ -> do
                    let normalizedInput = normalizeAsciiArmorForLenientDecode input
                        fallbackDecode =
                            if normalizedInput /= input
                                then AA.decodeLazy normalizedInput :: Either String [Armor]
                                else primaryDecode
                    case fallbackDecode of
                        Right []
                            | looksLikeAsciiArmor input ->
                                failWith
                                    BadData
                                    (context ++ ": malformed ASCII armor: no armor blocks found")
                        Right [] -> pure Nothing
                        Right armors -> pure (Just armors)
                        Left err
                            | looksLikeAsciiArmor input ->
                                failWith BadData (context ++ ": malformed ASCII armor: " ++ err)
                            | otherwise -> pure Nothing

normalizeAsciiArmorForLenientDecode
    :: BL.ByteString -> BL.ByteString
normalizeAsciiArmorForLenientDecode input
    | not (looksLikeAsciiArmor input) = input
    | otherwise =
        BL.fromStrict
            . TE.encodeUtf8
            . T.unlines
            . normalizeAsciiArmorLines
            $ T.lines normalizedLineEndings
  where
    normalizedLineEndings =
        T.replace
            (T.pack "\r")
            (T.pack "\n")
            ( T.replace
                (T.pack "\r\n")
                (T.pack "\n")
                (TE.decodeUtf8 (BL.toStrict input))
            )

data LenientArmorDecodeState
    = LenientOutsideArmor
    | LenientArmorHeaders Bool Bool
    | LenientArmorBody Bool

normalizeAsciiArmorLines :: [Text] -> [Text]
normalizeAsciiArmorLines = go LenientOutsideArmor
  where
    go _ [] = []
    go state (line : rest) =
        let trimmedLine = T.dropWhileEnd isSpace line
            whitespaceOnly = T.all isSpace line
            beginLabel = beginArmorLabelText trimmedLine
            isBegin = isJust beginLabel
            isEnd = T.isPrefixOf (T.pack "-----END PGP ") trimmedLine
            hasHeaderSeparator = T.any (== ':') trimmedLine
         in case state of
                LenientOutsideArmor
                    | isBegin ->
                        let isClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")
                            shouldStripHeaders = not isClearSigned
                         in trimmedLine
                                : go (LenientArmorHeaders shouldStripHeaders isClearSigned) rest
                    | otherwise -> trimmedLine : go LenientOutsideArmor rest
                LenientArmorHeaders stripHeaders isClearSigned
                    | whitespaceOnly ->
                        T.empty : go (LenientArmorBody isClearSigned) rest
                    | isEnd -> T.empty : trimmedLine : go LenientOutsideArmor rest
                    | stripHeaders && hasHeaderSeparator ->
                        go (LenientArmorHeaders stripHeaders isClearSigned) rest
                    | otherwise ->
                        trimmedLine : go (LenientArmorBody isClearSigned) rest
                LenientArmorBody isClearSigned
                    | isEnd -> trimmedLine : go LenientOutsideArmor rest
                    | isBegin ->
                        let nestedClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")
                            shouldStripHeaders = not nestedClearSigned
                         in trimmedLine
                                : go
                                    (LenientArmorHeaders shouldStripHeaders nestedClearSigned)
                                    rest
                    | otherwise ->
                        let bodyLine =
                                if isClearSigned
                                    then line
                                    else trimmedLine
                         in bodyLine : go (LenientArmorBody isClearSigned) rest

beginArmorLabelText :: Text -> Maybe Text
beginArmorLabelText line = do
    rest <- T.stripPrefix (T.pack "-----BEGIN PGP ") line
    T.stripSuffix (T.pack "-----") rest

validateClearSignedHeaders :: [(String, String)] -> IO ()
validateClearSignedHeaders headers =
    unless (all (isAllowedHeaderKey . fst) headers) $
        failWith
            BadData
            "cleartext signed message contains unsupported armor headers"
  where
    isAllowedHeaderKey hkey =
        map toLower hkey `elem` ["hash"]

validateClearSignedEnvelopeBounds :: BL.ByteString -> IO ()
validateClearSignedEnvelopeBounds input = do
    let text = TE.decodeUtf8With lenientDecode (BL.toStrict input)
        normalized = T.replace (T.pack "\r") (T.pack "") text
        ls = T.lines normalized
        beginMarker = T.pack "-----BEGIN PGP SIGNED MESSAGE-----"
        endMarker = T.pack "-----END PGP SIGNATURE-----"
        firstBegin = findIndex ((== beginMarker) . T.strip) ls
        hasVisibleText line = not (T.all isSpace line)
        findIndexFrom start predicate =
            fmap (+ start) (findIndex predicate (drop start ls))
    case firstBegin of
        Nothing -> pure ()
        Just beginIx -> do
            when (any hasVisibleText (take beginIx ls)) $
                failWith
                    BadData
                    "cleartext signed message has non-whitespace text before armor header"
            case findIndexFrom beginIx ((== endMarker) . T.strip) of
                Nothing -> pure ()
                Just endIx ->
                    when (any hasVisibleText (drop (endIx + 1) ls)) $
                        failWith
                            BadData
                            "cleartext signed message has non-whitespace text after signature block"

looksLikeAsciiArmor :: BL.ByteString -> Bool
looksLikeAsciiArmor input =
    BLC8.pack "-----BEGIN PGP "
        `BL.isPrefixOf` BLC8.dropWhile isAsciiArmorLeadingWhitespace input

isAsciiArmorLeadingWhitespace :: Char -> Bool
isAsciiArmorLeadingWhitespace c = c `elem` [' ', '\t', '\r', '\n']

validateAsciiArmorEnvelope :: BL.ByteString -> Maybe String
validateAsciiArmorEnvelope input
    | not (looksLikeAsciiArmor input) = Nothing
    | otherwise =
        validateArmorBlocks
            (BLC8.lines (BLC8.dropWhile isAsciiArmorLeadingWhitespace input))

validateArmorBlocks :: [BL.ByteString] -> Maybe String
validateArmorBlocks [] = Nothing
validateArmorBlocks (line : rest) =
    case beginArmorLabel line of
        -- UPSTREAM: openpgp-asciiarmor should export detectCleartextSignedBlock helper
        -- to encapsulate this RFC 4880 cleartext signature framework detection
        Just "SIGNED MESSAGE" -> validateClearSignedBlock rest
        Just label -> validateBinaryArmorBlock label rest
        Nothing -> Nothing

validateClearSignedBlock :: [BL.ByteString] -> Maybe String
validateClearSignedBlock ls =
    case break hasBeginArmorLabel ls of
        (_, []) ->
            Just
                "cleartext signed message is missing an armored signature block"
        (_, beginLine : rest) ->
            case beginArmorLabel beginLine of
                Just "SIGNATURE" -> validateBinaryArmorBlock "SIGNATURE" rest
                Just label ->
                    Just
                        ( "cleartext signed message must be followed by a PGP SIGNATURE block, found PGP "
                            ++ label
                        )
                Nothing ->
                    Just
                        "cleartext signed message has an invalid armored signature header"

validateBinaryArmorBlock
    :: String -> [BL.ByteString] -> Maybe String
validateBinaryArmorBlock label ls =
    case break hasEndArmorLabel ls of
        (_, []) -> Just ("missing END PGP " ++ label ++ " footer")
        (_, endLine : rest) ->
            case endArmorLabel endLine of
                Just endLabel
                    | endLabel == label -> validateArmorBlocks rest
                    | otherwise ->
                        Just
                            ( "mismatched footer: expected END PGP "
                                ++ label
                                ++ ", found END PGP "
                                ++ endLabel
                            )
                Nothing -> Just ("invalid END PGP " ++ label ++ " footer")

hasBeginArmorLabel :: BL.ByteString -> Bool
hasBeginArmorLabel = isJust . beginArmorLabel

hasEndArmorLabel :: BL.ByteString -> Bool
hasEndArmorLabel = isJust . endArmorLabel

beginArmorLabel :: BL.ByteString -> Maybe String
beginArmorLabel = armorBoundaryLabel "-----BEGIN PGP " "-----"

endArmorLabel :: BL.ByteString -> Maybe String
endArmorLabel = armorBoundaryLabel "-----END PGP " "-----"

armorBoundaryLabel
    :: String -> String -> BL.ByteString -> Maybe String
armorBoundaryLabel prefix suffix line = do
    rest <- stripPrefix prefix (BLC8.unpack line)
    if suffix `isSuffixOf` rest
        then pure (take (length rest - length suffix) rest)
        else Nothing

isOpenPGPArmorBlock :: Armor -> Bool
isOpenPGPArmorBlock (Armor _ _ _) = True
isOpenPGPArmorBlock _ = False

isArmorMessageBlock :: Armor -> Bool
isArmorMessageBlock (Armor ArmorMessage _ _) = True
isArmorMessageBlock _ = False

isDetachedSignatureArmor :: Armor -> Bool
isDetachedSignatureArmor (Armor ArmorSignature _ _) = True
isDetachedSignatureArmor _ = False

isDetachedSignatureUnsupportedArmor :: Armor -> Bool
isDetachedSignatureUnsupportedArmor (Armor _ _ _) = True
isDetachedSignatureUnsupportedArmor ClearSigned {} = True

isClearSignedArmor :: Armor -> Bool
isClearSignedArmor ClearSigned {} = True
isClearSignedArmor _ = False

isInlineSignedArmorCandidate :: Armor -> Bool
isInlineSignedArmorCandidate (Armor ArmorMessage _ _) = True
isInlineSignedArmorCandidate ClearSigned {} = True
isInlineSignedArmorCandidate _ = False

splitInlineSignedPackets :: [Pkt] -> IO (BL.ByteString, [Pkt])
splitInlineSignedPackets pkts = do
    let msgPkts = [p | p@LiteralDataPkt {} <- pkts]
        sigPkts = [p | p@SignaturePkt {} <- pkts]
    case msgPkts of
        [LiteralDataPkt _ _ _ payload]
            | null sigPkts ->
                failWith BadData "inline-detach input has no signatures"
            | otherwise -> return (payload, sigPkts)
        [] ->
            failWith
                BadData
                "inline-detach input has no literal message payload"
        _ ->
            failWith
                BadData
                "inline-detach input contains multiple literal payloads"

writeDetachedSignatures :: Bool -> String -> [Pkt] -> IO ()
writeDetachedSignatures noArmor outPath sigPkts = do
    let sigBytes = runPut $ mapM_ Bin.put sigPkts
        out =
            if noArmor
                then sigBytes
                else
                    BL.fromStrict
                        (BLC8.toStrict (AA.encodeLazy [Armor ArmorSignature [] sigBytes]))
    BL.writeFile outPath out

doListProfiles :: ListProfilesOptions -> IO ()
doListProfiles lpos =
    ( case profileSubcommand lpos of
        "generate-key" ->
            mapM_
                ( \p ->
                    putStrLn $
                        profileName p ++ ": " ++ profileDescription p ++ aliasesSuffix p
                )
                keyGenProfiles
        "encrypt" ->
            mapM_
                ( \p ->
                    putStrLn $
                        profileName p ++ ": " ++ profileDescription p ++ aliasesSuffix p
                )
                encryptProfiles
        _ ->
            failWith
                UnsupportedProfile
                "Subcommand does not support profiles"
    )
  where
    aliasesSuffix p = case profileAliases p of
        [] -> ""
        s : [] -> " (alias: " ++ s ++ ")"
        as -> " (aliases: " ++ intercalate ", " as ++ ")"
