-- 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 DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}

import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..))
import Codec.Encryption.OpenPGP.Compression (decompressPkt, renderCompressionError)
import Codec.Encryption.OpenPGP.Expirations (effectiveKeyPreferencesAt, isTKTimeValid)
import Codec.Encryption.OpenPGP.Encrypt
  ( EncryptCompatibilityProfile(..)
  , PKESKEncryptError(..)
  , PKESKSessionMaterial(..)
  , RecipientEncryptRequest(..)
  , RecipientEncryptRequestOverrides(..)
  , RecipientEncryptResult(..)
  , RecipientPKESKVersionStrategy(..)
  , RecipientPayloadShape(..)
  , defaultRecipientPayloadShape
  , encryptForRecipients
  , recipientEncryptionTarget
  , recipientEncryptionTargetWithStrategy
  )
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
import Codec.Encryption.OpenPGP.Message
  ( EncryptMessageOptions(..)
  , encryptedPayloadBytes
  , RecoveredSessionMaterial(..)
  , SessionMaterialExposure(..)
  , encryptMessage
  , mkClearPayload
  , mkPassphrase
  )
import Codec.Encryption.OpenPGP.Ontology (isKUF, isPKBindingSig, isSKBindingSig)
import Codec.Encryption.OpenPGP.Policy
  ( PKESKVersionPolicy(..)
  , defaultDecryptPolicy
  , defaultPolicy
  , lenientDecryptPolicy
  )
import Codec.Encryption.OpenPGP.S2K
  ( decodeOpenPGPEncodedSessionKey
  , skesk2Key
  , skesk2SessionKey
  )
import Codec.Encryption.OpenPGP.Serialize (parsePkts)
import Codec.Encryption.OpenPGP.SecretKey
  ( decryptPrivateKey
  , encryptPrivateKey
  )
import qualified Codec.Encryption.OpenPGP.Subpackets as SP
import Codec.Encryption.OpenPGP.Signatures
  ( SignError(..)
  , renderSignError
  , signCertRevocationWithRSA
  , signDataWithEd25519
  , signDataWithEd25519Legacy
  , signDataWithEd25519V6
  , signDataWithEd448
  , signDataWithEd448V6
  , signDataWithRSABuilder
  , signKeyRevocationWithRSA
  , signDataWithRSAV6
  , signUserIDwithRSA
  , verifyAgainstKeys
  , verifyAgainstKeyring
  , verifySigWith
  , verifyUnknownTKWith
  )
import Codec.Encryption.OpenPGP.Types
import Control.Applicative ((<|>), optional, some, many)
import Control.Error.Util (note)
import Control.Monad ((>=>), forM, forM_, unless, when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State.Lazy (StateT, evalStateT, get, modify)
import Control.Monad.Trans.Resource (MonadResource, MonadThrow)
import Control.Exception
  ( IOException
  , SomeException
  , catch
  , displayException
  , evaluate
  , throwIO
  )
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.Curve25519 as Curve25519
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import Crypto.Number.Serialize (i2ospOf_, os2ip)
import Crypto.Random.Types (getRandomBytes)
import Crypto.Error (eitherCryptoError)
import qualified Data.Aeson as A
import qualified Data.Binary as Bin
import Data.Binary.Get (runGet)
import Data.Binary.Put (runPut, putByteString, putLazyByteString, putWord8, putWord16be, putWord32be)
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.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 qualified Data.Conduit.OpenPGP.Decrypt as Decrypt
import Data.Conduit.OpenPGP.Decrypt
  ( DecryptKeyResolution(..)
  , DecryptOutcome(..)
  , PKESKRecipientKey(..)
  )
import Data.Conduit.OpenPGP.Keyring
  ( conduitToTKsDropping
  , sinkPublicKeyringMap
  )
import Data.Conduit.OpenPGP.Verify (conduitVerify, verifyPacketsBatch)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Either (fromRight, isLeft, isRight, rights)
import Data.Bifunctor (first)
import Data.Char (digitToInt, isHexDigit, isSpace, toLower)
import Data.List (find, findIndex, foldl', intercalate, isInfixOf, isPrefixOf, isSuffixOf, nub, partition, stripPrefix)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)
import Data.Monoid ((<>))
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 Data.IORef (IORef, newIORef, atomicModifyIORef')
import qualified Data.Vector as V
import Data.Version (showVersion)
import Data.Word (Word8)
import qualified Data.Yaml as Y
import GHC.Generics
import HOpenPGP.Tools.Common.Armor (doDeArmor)
import HOpenPGP.Tools.Common.Common
  ( banner
  , keyMatchesEightOctetKeyId
  , keyMatchesFingerprint
  , keyMatchesUIDSubString
  , versioner
  , warranty
  )
import HOpenPGP.Tools.Common.Parser (parseTKExp)
import HOpenPGP.Tools.Common.TKUtils (processTK)
import Paths_hopenpgp_tools (version)
import System.Exit (exitFailure, exitSuccess, exitWith, ExitCode(..))

import Options.Applicative.Builder
  ( argument
  , auto
  , command
  , eitherReader
  , footerDoc
  , headerDoc
  , help
  , helpDoc
  , info
  , long
  , metavar
  , option
  , prefs
  , progDesc
  , short
  , showDefault
  , showHelpOnError
  , str
  , strArgument
  , strOption
  , switch
  , value
  )
import Options.Applicative.Extra (customExecParser, helper, hsubparser)
import Options.Applicative.Types (Parser)
import Text.Read (readMaybe)

import Prettyprinter
  ( (<+>)
  , fillSep
  , hardline
  , list
  , pretty
  , softline
  )
import Prettyprinter.Render.Text (hPutDoc)
import System.IO (BufferMode(..), Handle, hFlush, hPutStrLn, hSetBuffering, stderr, stdin)
import System.Directory (doesFileExist)
import System.Environment (getArgs, lookupEnv)

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

data Options =
  Options
    { keyrings :: [String]
    , outputFormat :: OutputFormat
    , sigFilter :: String
    , sigFile :: String
    , blobFile :: String
    }

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
    , encArmor :: Bool
    , encProfile :: Maybe String
    , encAs :: AsBinaryText
    , encSignWithKeyFiles :: [String]
    , encSignWithKeyPasswords :: [String]
    , encSessionKeyOutFile :: Maybe String
    , encFor :: EncryptFor
    , encWithoutIntegrityCheck :: Bool
    , encPasswords :: [String]
    , encRecipientCerts :: [String]
    }

data EncryptProfile
  = EncryptProfileRFC9580
  | EncryptProfileRFC4880
  deriving (Eq)

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

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

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

data ChangeKeyPasswordOptions =
  ChangeKeyPasswordOptions
    { changeKeyPasswordNoArmor :: Bool
    , changeKeyPasswordOldPasswords :: [String]
    , changeKeyPasswordNewPasswords :: [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]
    , certifyUserIdOutputFormat :: Maybe String
    , certifyUserIdNoRequireSelfSig :: Bool
    , certifyUserIdKeyPasswordFiles :: [String]
    , certifyUserIdSignerFiles :: [String]
    }

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

data RevokeUserIdOptions =
  RevokeUserIdOptions
    { revokeUserIdString :: String
    , revokeUserIdNoArmor :: Bool
    }

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
  | 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 CertUserIdNoMatch = 107
failureCode KeyCannotCertify = 109

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

o :: Parser Options
o =
  Options <$>
  some
    (strOption
       (long "keyring" <>
        short 'k' <> metavar "FILE" <> help "file containing keyring")) <*>
  option
    auto
    (long "output-format" <>
     metavar "FORMAT" <>
     value Unstructured <> showDefault <> help "output format") <*>
  option
    auto
    (long "signature-filter" <>
     metavar "SIGFILTER" <>
     value "sigcreationtime < now" <>
     showDefault <> help "verify only signatures which match filter spec") <*>
  argument str (metavar "SIGNATURE" <> sigHelp) <*>
  argument str (metavar "BLOB" <> blobHelp)
  where
    sigHelp =
      helpDoc . Just $
      pretty "file containing OpenPGP binary signatures"
    blobHelp =
      helpDoc . Just $
      pretty "file containing binary blob to be validated"

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") <*>
  switch (long "armor" <> help "output ASCII Armor") <*>
  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) <*>
  switch (long "without-integrity-check" <> help "disable integrity protection") <*>
  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") <*>
  switch (long "armor" <> help "output ASCII Armor") <*>
  switch (long "without-integrity-check" <> help "disable integrity verification") <*>
  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")) <*>
  optional
    (strOption
       (long "verify-out" <>
        help "deprecated alias for --verifications-out"))

inlineSignP :: Parser InlineSignOptions
inlineSignP =
  InlineSignOptions <$>
  switch (long "no-armor" <> help "output binary") <*>
  switch (long "armor" <> help "output ASCII Armor") <*>
  optional (strOption (long "profile" <> help "signature profile")) <*>
  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)")) <*>
  optional
    (strOption
       (long "output-format" <>
        metavar "FORMAT" <>
        help "output format (text or 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"))

revokeUserIdP :: Parser RevokeUserIdOptions
revokeUserIdP =
  RevokeUserIdOptions <$>
  argument str (metavar "USERID" <> help "user ID to revoke") <*>
  switch (long "no-armor" <> help "output binary")

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")) <*>
  many
    (strOption
       (long "new-key-password" <>
        help "password used to protect rewritten secret key material"))

dispatch :: POSIXTime -> Command -> IO ()
dispatch cpt o = banner' stderr >> hFlush stderr >> dispatch' cpt o
  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 (RevokeUserIdC o) = doRevokeUserId 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 o) = doArmor o

main :: IO ()
main = do
  hSetBuffering stderr LineBuffering
  args <- getArgs
  ensureKnownSubcommand knownSopSubcommands args
  cpt <- getPOSIXTime
  CliOptions {..} <-
    customExecParser
      (prefs showHelpOnError)
      (info
         (helper <*> versioner "hop" <*> cliP)
         (headerDoc (Just (banner "hop")) <>
          progDesc "hOpenPGP Validator Tool" <>
          footerDoc (Just (warranty "hop"))))
  let _ = cliDebug
  dispatch cpt cliCommand

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"
  , "revoke-userid"
  , "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

doV :: POSIXTime -> Options -> IO ()
doV cpt o = do
  krs <- loadVerifyKeyringMap cpt (keyrings o)
  sigs <-
    runConduitRes $
    CC.sourceFile (sigFile o) .| conduitGet Bin.get .| CC.filter v4b .|
    CC.sinkVector
  blob <- runConduitRes $ CC.sourceFile (blobFile o) .| CC.sinkLazy
  verifications <-
    runConduitRes $
    CC.yieldMany (V.cons (LiteralDataPkt BinaryData mempty 0 blob) sigs) .|
    conduitVerify krs Nothing .|
    CC.sinkList
  let verifications' = map v2v verifications
  case outputFormat o of
    Unstructured -> mapM_ print verifications'
    JSON -> BL.putStr . A.encode $ verifications'
    YAML -> B.putStr . Y.encode $ verifications'
  putStrLn ""
  case any isRight verifications of
    True -> exitSuccess
    _ -> exitFailure
  where
    v4b (SignaturePkt s@(SigV4 BinarySig _ _ _ _ _ _)) = sf s
    v4b _ = False
    v2v (Left l) = Vrf (show l) Nothing
    v2v (Right v) =
      Vrf "verified signature" (Just (fingerprint (_verificationSigner v)))
    sf = const True

cmd :: Parser Command
cmd =
  hsubparser
    (command "armor" (info (ArmorC <$> aoP) (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
       "revoke-userid"
       (info (RevokeUserIdC <$> revokeUserIdP) (progDesc "Revoke a user ID")) <>
     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")))

armorTypes :: [(String, Maybe ArmorType)]
armorTypes =
  [ ("auto", Nothing)
  , ("sig", Just ArmorSignature)
  , ("key", Just ArmorPrivateKeyBlock)
  , ("cert", Just ArmorPublicKeyBlock)
  , ("message", Just ArmorMessage)
  ]

armorTypeReader :: String -> Either String (Maybe ArmorType)
armorTypeReader = note "unknown armor type" . flip lookup armorTypes

aoP :: Parser ArmoringOptions
aoP =
  ArmoringOptions <$>
  option
    (eitherReader armorTypeReader)
    (long "label" <> metavar "LABEL" <> armortypeHelp) <*>
  switch
    (long "allow-nested" <>
     help "do the sane thing and unconditionally armor the output")
  where
    armortypeHelp =
      helpDoc . Just $
      pretty "ASCII armor type" <>
      softline <> list (map (pretty . fst) armorTypes)

data ArmoringOptions =
  ArmoringOptions
    { label :: Maybe ArmorType
    , allowNested :: Bool
    }

doArmor :: ArmoringOptions -> IO ()
doArmor ArmoringOptions {..} = do
  m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
  let lbs = BL.fromChunks m
      armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs
      label' = guessLabel label (decodeFirstPacket lbs)
      a = Armor label' [] lbs
  BL.putStr $
    if armoredAlready && not allowNested
      then lbs
      else AA.encodeLazy [a]
  where
    decodeFirstPacket = runGet Bin.get
    -- UPSTREAM: openpgp-asciiarmor should export selectArmorType helper
    -- to eliminate this pattern-matching boilerplate
    guessLabel (Just l) _ = l
    guessLabel Nothing (SignaturePkt _) = ArmorSignature
    guessLabel Nothing (SecretKeyPkt _ _) = ArmorPrivateKeyBlock
    guessLabel Nothing (PublicKeyPkt _) = ArmorPublicKeyBlock
    guessLabel Nothing _ = ArmorMessage

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"
  putStrLn $ "hop " ++ showVersion version
  when vBackend $ putStrLn "backend: hOpenPGP"
  when vExtended $ putStrLn "extended: yes"
  when vSopSpec $ putStrLn "spec: draft-dkg-openpgp-stateless-cli-16"
  when vSopv $ putStrLn "sopv: 1.0"

gkoP :: Parser KeyGenOptions
gkoP =
  KeyGenOptions <$> switch (long "armor" <> help "armor the output") <*>
  switch (long "no-armor" <> help "don't armor the output") <*>
  many
    (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
    { armor :: Bool
    , noArmor :: Bool
    , keyPasswords :: [String]
    , keyProfile :: Maybe String
    , keySigningOnly :: Bool
    , userIds :: [String]
    }

doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()
doGenerateKey pt KeyGenOptions {..} = do
  when (armor && noArmor) $
    failWith
      IncompatibleOptions
      "generate-key: --armor and --no-armor are mutually exclusive"
  baseProfile <- parseKeyGenProfile keyProfile
  let profile =
        if keySigningOnly
          then KeyGenSigningOnly
          else baseProfile
  password <- parseGenerateKeyPassword keyPasswords
  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
      newkey <- get
      return newkey
  s <- maybe (pure baseKey) (`encryptTransferableSecretKey` baseKey) password
  let lbs = runPut $ Bin.put s
  BL.putStr $
    if not armor && not noArmor
      then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs]
      else lbs

type KeyBuilder = StateT TKUnknown IO

buildKeyWith :: SecretKey -> KeyBuilder a -> IO a
buildKeyWith sk a = evalStateT a (bareTK sk)
  where
    bareTK (SecretKey pkp ska) = TKUnknown (pkp, Just ska) [] [] [] []

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 Ed25519 (NativeEPoint (EPoint (os2ip pubBytes)))))
      (SUUnencrypted (EdDSAPrivateKey Ed25519 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 Ed25519 (NativeEPoint (EPoint (os2ip pubBytes)))))
      (SUUnencrypted (X25519PrivateKey privBytes) 0)

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

parseKeyGenProfile :: Maybe String -> IO KeyGenProfile
parseKeyGenProfile Nothing = pure KeyGenDefault
parseKeyGenProfile (Just "default") = pure KeyGenDefault
parseKeyGenProfile (Just "rfc4880") = pure KeyGenRFC4880
parseKeyGenProfile (Just "compatibility") = pure KeyGenRFC4880
parseKeyGenProfile (Just "security") = pure KeyGenSecurity
parseKeyGenProfile (Just "performance") = pure KeyGenPerformance
parseKeyGenProfile (Just profile) =
  failWith
    UnsupportedProfile
    ("generate-key: unsupported profile " ++ profile)

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

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

parseGenerateKeyPassword :: [String] -> IO (Maybe BL.ByteString)
parseGenerateKeyPassword [] = pure Nothing
parseGenerateKeyPassword [passwordFile] =
  Just <$>
  (loadPasswordFromFile "generate-key" "--with-key-password" passwordFile >>=
   normalizeHumanReadablePassword "generate-key" "--with-key-password")
parseGenerateKeyPassword _ =
  failWith
    UnsupportedOption
    "generate-key: multiple --with-key-password values are not supported"

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 value -> pure (BLC8.pack value)
    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)

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 -> KeyBuilder ()
addSubkeysForProfile ts keyVersion profile =
  case profile of
    KeyGenSigningOnly ->
      addSubkey ts keyVersion profile [SignDataKey]
    _ -> do
      addSubkey ts keyVersion profile [EncryptStorageKey, EncryptCommunicationsKey]
      addSubkey ts keyVersion profile [SignDataKey]
      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 -> TKUnknown -> IO TKUnknown
encryptTransferableSecretKey password tk = do
  keyPair' <- encryptKeyPair (_tkuKey tk)
  subs' <- mapM encryptSub (_tkuSubs tk)
  pure tk {_tkuKey = keyPair', _tkuSubs = subs'}
  where
    encryptKeyPair (pkp, Just ska) = do
      encrypted <- encryptSecretAddendumForOutput pkp ska
      pure (pkp, Just encrypted)
    encryptKeyPair keyPair = pure keyPair
    encryptSub (SecretSubkeyPkt pkp ska, sigs) = do
      encrypted <- encryptSecretAddendumForOutput pkp ska
      pure (SecretSubkeyPkt pkp encrypted, sigs)
    encryptSub sub = pure sub
    encryptSecretAddendumForOutput pkp ska =
      case ska of
        SUUnencrypted {} -> doEncrypt
        _ -> pure ska
      where
        doEncrypt = do
          encryptedResult <- encryptPrivateKey defaultPolicy pkp ska password
          case encryptedResult of
            Left err ->
              failWith BadData ("generate-key: failed to protect secret key material: " ++ err)
            Right value -> pure value

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)]

issuerSubpacketFor :: String -> SomePKPayload -> IO SigSubPacket
issuerSubpacketFor context pkp = do
  packets <- issuerSubpacketsFor context pkp
  case packets of
    [packet] -> pure packet
    [] ->
      failWith
        BadData
        (context ++ ": no legacy issuer key id is available for this key")
    _ -> failWith BadData (context ++ ": unexpected issuer subpacket count")

addUserId :: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder ()
addUserId ts primary userid = do
  tk <- get
  signed <- selfsign (_tkuKey tk) userid
  modify (newUID signed)
  where
    newUID signed tk = tk {_tkuUIDs = _tkuUIDs tk ++ [signed]}
    selfsign (pkp, Just 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])
    selfsign _ _ =
      liftIO $
      failWith BadData "generate-key: primary key is missing secret key material"
    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)
  (pkp, ska) <-
    case _tkuKey tk of
      (primaryPkp, Just primarySka) -> pure (primaryPkp, primarySka)
      _ ->
        liftIO $
        failWith
          BadData
          "generate-key: primary key is missing secret key material"
  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 {_tkuSubs = _tkuSubs tk ++ [(SecretSubkeyPkt 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 "armor" <> help "armor the output") <*>
  switch (long "no-armor" <> help "don't armor the output")

data ExtractCertOptions =
  ExtractCertOptions
    { ecArmor :: Bool
    , 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 .| conduitToTKsDropping .| CC.sinkList
  when (null tks) $
    failWith
      MissingInput
      "extract-cert: no transferable secret key found on standard input"
  let output = runPut $ mapM_ (Bin.put . pubToSecret) tks
  BL.putStr $
    if not ecArmor && not ecNoArmor
      then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
      else output
  where
    pubToSecret tk =
      tk {_tkuKey = pToS (_tkuKey tk), _tkuSubs = map subPToS (_tkuSubs tk)}
    pToS (pkp, _) = (pkp, Nothing)
    subPToS (SecretSubkeyPkt pkp _, sigs) = (PublicSubkeyPkt pkp, sigs)
    subPToS (PublicSubkeyPkt pkp, sigs) = (PublicSubkeyPkt pkp, sigs)
    subPToS x = x

doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO ()
doChangeKeyPassword ChangeKeyPasswordOptions {..} = do
  input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
  packets <- decodeOpenPGPInput "stdin" input
  tks <- runConduitRes $ CL.sourceList packets .| conduitToTKsDropping .| 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 changeKeyPasswordNewPasswords
  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 rewrittenTks)
  BL.putStr $
    if changeKeyPasswordNoArmor || BL.null output
      then output
      else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output]

parseChangeKeyPasswordNewPassword :: [String] -> IO (Maybe BL.ByteString)
parseChangeKeyPasswordNewPassword [] = pure Nothing
parseChangeKeyPasswordNewPassword [passwordFile] =
  Just <$>
  (loadPasswordFromFile "change-key-password" "--new-key-password" passwordFile >>=
   normalizeHumanReadablePassword "change-key-password" "--new-key-password")
parseChangeKeyPasswordNewPassword _ =
  failWith
    UnsupportedOption
    "change-key-password: multiple --new-key-password values are not supported"

hasSecretKeyMaterial :: TKUnknown -> Bool
hasSecretKeyMaterial tk =
  case _tkuKey tk of
    (_, Just _) -> True
    _ -> any isSecretSubkeyPkt (_tkuSubs tk)
  where
    isSecretSubkeyPkt (SecretSubkeyPkt _ _, _) = True
    isSecretSubkeyPkt _ = 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 .| conduitToTKsDropping .| 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 ::
     [TKUnknown] -> Maybe UTCTime -> Bool -> Text -> TKUnknown -> Bool
certificateHasMatchingValidatedUserId authorityTks validateAtTime addrSpecOnly targetUserId certTk =
  case verifyUnknownTKWith verifier validateAtTime certTk of
    Left _ -> False
    Right verifiedTk -> any matchingBoundUid (_tkuUIDs verifiedTk)
  where
    verifier = verifySigWith (verifyAgainstKeys (certTk : authorityTks))
    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 :: TKUnknown -> 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 (loadCertifySignerTKsFromFile signerPasswords) 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 .| conduitToTKsDropping .| 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 updatedTargets)
      armorOutput =
        case certifyUserIdOutputFormat of
          Just "binary" -> output
          _ -> AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
  BL.putStr armorOutput

loadCertifySignerTKsFromFile :: [BL.ByteString] -> String -> IO [TKUnknown]
loadCertifySignerTKsFromFile signerPasswords path = do
  lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
  packets <- decodeOpenPGPInput path lbs
  tks <- runConduitRes $ CL.sourceList packets .| conduitToTKsDropping .| 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 :: TKUnknown -> [Text] -> Bool -> [TKUnknown] -> IO TKUnknown
addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks = do
  forM_ targetUserIds $ \targetUserId ->
    case find ((== targetUserId) . fst) (_tkuUIDs 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 $ targetTk {_tkuUIDs = map updateUID (_tkuUIDs targetTk)}

createUIDCertification :: Text -> TKUnknown -> IO SignaturePayload
createUIDCertification targetUserId signerTk = do
  let (signerPkp, mSignerSka) = _tkuKey signerTk
  signerSka <-
    case mSignerSka of
      Just ska -> pure ska
      Nothing -> failWith KeyCannotCertify "certify-userid: signer certificate has no secret key material"
  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 .| conduitToTKsDropping .| 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
      let (pkp, mSka) = _tkuKey unlockedTk
      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)

doRevokeUserId :: POSIXTime -> RevokeUserIdOptions -> IO ()
doRevokeUserId cpt RevokeUserIdOptions {..} = do
  input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
  keyPkts <- decodeOpenPGPInput "standard input" input
  keyTks <- runConduitRes $ CL.sourceList keyPkts .| conduitToTKsDropping .| CC.sinkList
  when (null keyTks) $
    failWith MissingInput "revoke-userid: no key found on standard input"
  let keyTk = head keyTks
      (pkp, mSka) = _tkuKey keyTk
      targetUserId = T.pack revokeUserIdString
  uidExists <-
    if any ((== targetUserId) . fst) (_tkuUIDs keyTk)
      then pure True
      else failWith MissingInput ("revoke-userid: key has no user ID matching " ++ revokeUserIdString)
  ska <-
    case mSka of
      Just s -> pure s
      Nothing -> failWith KeyCannotCertify "revoke-userid: key has no secret key material"
  signingKey <- rsaSigningKey ska
  issuer <- issuerSubpacketsFor "revoke-userid" pkp
  let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]
      revocation = signCertRevocationWithRSA pkp (UserId targetUserId) hashed issuer signingKey
  case revocation of
    Left err -> failWith BadData ("revoke-userid: failed to create revocation: " ++ show err)
    Right sig -> do
      let revocationSigPkt = SignaturePkt sig
          output = runPut (Bin.put revocationSigPkt)
      BL.putStr $
        if revokeUserIdNoArmor
          then output
          else AA.encodeLazy [Armor ArmorSignature [] output]

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 .| conduitToTKsDropping .| CC.sinkList
  when (null stdinTks) $
    failWith MissingInput "update-key: no key found on standard input"
  updateSourceTks <- concat <$> mapM loadVerifyTKsFromFile updateKeyMergeCerts
  when (null updateSourceTks) $
    failWith MissingInput "update-key: no update keys found"
  stdinUnlocked <- mapM (unlockUpdateKeyMaterial "standard input" keyPasswords) stdinTks
  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 ->
             foldl'
               (<>)
               targetTk
               (selectUpdateMergeInputs cpt updateKeyNoAddedCapabilities targetTk updateTks))
          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 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 .| conduitToTKsDropping .| CC.sinkList
  mergeInTks <- concat <$> mapM loadVerifyTKsFromFile mergeCertsFiles
  let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks
      output = runPut (mapM_ Bin.put mergedTks)
  BL.putStr $
    if mergeCertsNoArmor || BL.null output
      then output
      else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]

mergeCertificatesForOutput :: [TKUnknown] -> [TKUnknown] -> [TKUnknown]
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 = foldl' (<>) base rest
          matchingMergeInputs =
            filter ((== primary) . certificatePrimaryFingerprint) mergeInTks
       in foldl' (<>) mergedStdin matchingMergeInputs

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

certificatePrimaryFingerprint :: TKUnknown -> B.ByteString
certificatePrimaryFingerprint =
  BL.toStrict . unFingerprint . fingerprint . fst . _tkuKey

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

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

selectUpdateMergeInputs ::
     POSIXTime
  -> Bool
  -> TKUnknown
  -> [TKUnknown]
  -> [TKUnknown]
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 "armor" <> help "armor the output") <*>
  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
    { sArmor :: Bool
    , 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
  when (sNoArmor && sArmor) $
    failWith IncompatibleOptions "sign: --armor and --no-armor are mutually exclusive"
  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 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 sArmor && 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] -> [BL.ByteString] -> IO [TKUnknown]
loadSigningKeys keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles
  where
    loadFromFile path = do
      lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
      packets <- decodeOpenPGPInput path lbs
      tks <- runConduitRes $ CL.sourceList packets .| conduitToTKsDropping .| 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] -> TKUnknown -> IO TKUnknown
decryptSigningKeyMaterial path keyPasswords =
  unlockTransferableSecretKeyMaterial
    "sign failed"
    path
    "--with-key-password"
    keyPasswords

unlockTransferableSecretKeyMaterial ::
     String -> FilePath -> String -> [BL.ByteString] -> TKUnknown -> IO TKUnknown
-- 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 tk = do
  keyPair' <- decryptSecretPart (_tkuKey tk)
  subs' <- mapM decryptSub (_tkuSubs tk)
  pure tk {_tkuKey = keyPair', _tkuSubs = subs'}
  where
    decryptSecretPart (pkp, Just ska) = do
      ska' <- unlockSecretAddendum context path passwordOption keyPasswords pkp ska
      pure (pkp, Just ska')
    decryptSecretPart keyPair = pure keyPair
    decryptSub (SecretSubkeyPkt pkp ska, sigs) = do
      ska' <- unlockSecretAddendum context path passwordOption keyPasswords pkp ska
      pure (SecretSubkeyPkt pkp ska', sigs)
    decryptSub sub = pure sub

unlockSecretAddendum ::
     String -> FilePath -> String -> [BL.ByteString] -> SomePKPayload -> SKAddendum -> IO 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 -> TKUnknown -> IO TKUnknown
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
  -> [TKUnknown]
  -> [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 -> TKUnknown -> [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 -> TKUnknown -> [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 Ed25519 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 Ed448 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 ()

canonicalizeUTF8Text :: BL.ByteString -> BL.ByteString
canonicalizeUTF8Text =
  BL.fromStrict .
  TE.encodeUtf8 . T.intercalate (T.pack "\r\n") . T.lines . TE.decodeUtf8 . BL.toStrict

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

grabKey :: String -> IO TKUnknown
grabKey fp = do
  kbs <- runConduitRes $ CB.sourceFile fp .| CL.consume
  let lbs = BL.fromChunks kbs
  pkts <- decodeOpenPGPInput fp lbs
  tks <- runConduitRes $ CL.sourceList pkts .| conduitToTKsDropping .| CC.sinkList
  case tks of
    (k:_) -> pure k
    [] ->
      case signingFallbackTKs pkts of
        (k:_) -> pure k
        [] -> failWith MissingInput ("no secret key material found in " ++ fp)

signingFallbackTKs :: [Pkt] -> [TKUnknown]
signingFallbackTKs packets =
  [TKUnknown (pkp, Just ska) [] [] [] [] | 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 -> TKUnknown -> [FunKey]
tkToFunKeysAt pt tk@(TKUnknown (pkp, mska) _ uids _ subs) =
  catMaybes (mainKey : map extract subs)
  where
    mainPreferredHashes = effectiveHashPreferencesAt pt tk
    mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt tk
    mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt tk
    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
    extract ((SecretSubkeyPkt spkp sska), sigs) =
      return
        (FunKey
           spkp
           (Just sska)
           (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
           mainPreferredHashes
           mainPreferredSymmetricAlgorithms
           mainSupportsSEIPDv2)
    extract ((PublicSubkeyPkt spkp), sigs) =
      return
        (FunKey
           spkp
           Nothing
           (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
           mainPreferredHashes
           mainPreferredSymmetricAlgorithms
           mainSupportsSEIPDv2)
    extract _ = Nothing

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

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

effectiveSEIPDv2SupportAt :: POSIXTime -> TKUnknown -> Bool
effectiveSEIPDv2SupportAt pt tk =
  any supportsSEIPDv2Flag $
  concatMap toFeatureFlags $
  fromMaybe [] (effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac pt)) 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
  -> [TKUnknown]
  -> 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) (_tkuSubs 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
  when (encNoArmor && encArmor) $
    failWith IncompatibleOptions "encrypt: --armor and --no-armor are mutually exclusive"
  payload <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
  when (encAs == AsText) $
    ensureUTF8TextInput "encrypt" payload
  when encWithoutIntegrityCheck $
    failWith
      UnsupportedOption
      "encrypt: --without-integrity-check is not supported by this backend"
  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 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
              }
            (mkPassphrase 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
              }
            (mkPassphrase 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 value -> pure value
  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
       prefLists ->
         listToMaybe
           [ candidate
           | candidate <- filter isSupported (head prefLists)
           , all (candidate `elem`) (tail 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 recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
        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 ->
                      recipientEncryptionTargetWithStrategy x25519Recipient RecipientPreferV6
                    Nothing ->
                      recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
                else
                  recipientEncryptionTargetWithStrategy recipient RecipientForceV3Interop
            DeprecatedRSAEncryptOnly ->
              if recipientNeedsV6PKESK
                 then recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
                 else recipientEncryptionTargetWithStrategy recipient RecipientForceV3Interop
            RSA ->
              if recipientNeedsV6PKESK
                 then recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
                 else recipientEncryptionTargetWithStrategy recipient RecipientForceV3Interop
            _ ->
              if recipientNeedsV6PKESK
                 then recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
                 else recipientEncryptionTarget recipient


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

parseEncryptProfile :: Maybe String -> IO EncryptProfile
parseEncryptProfile Nothing = pure EncryptProfileRFC9580
parseEncryptProfile (Just profileName) =
  case profileName of
    "default" -> pure EncryptProfileRFC9580
    "rfc9580" -> pure EncryptProfileRFC9580
    "security" -> pure EncryptProfileRFC9580
    "performance" -> pure EncryptProfileRFC9580
    "rfc4880" -> pure EncryptProfileRFC4880
    "compatibility" -> pure EncryptProfileRFC4880
    _ -> failWith UnsupportedProfile ("encrypt: unsupported profile " ++ profileName)

doDecrypt :: POSIXTime -> DecryptOptions -> IO ()
doDecrypt cpt DecryptOptions {..} = do
  when (decNoArmor && decArmor) $
    failWith IncompatibleOptions "decrypt: --armor and --no-armor are mutually exclusive"
  when decWithoutIntegrityCheck $
    failWith
      UnsupportedOption
      "decrypt: --without-integrity-check is not supported by this backend"
  sessionKeys <- parseDecryptSessionKeys decSessionKeys
  (verificationOutputPath, usingDeprecatedVerifyOut) <-
    resolveDecryptVerificationsOut decVerificationsOutFile decDeprecatedVerifyOutFile
  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 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
  when usingDeprecatedVerifyOut $
    hPutStrLn stderr
      "Warning: --verify-out is deprecated; use --verifications-out instead."

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 value bits = go (value `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@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 -> Maybe String -> IO (Maybe String, Bool)
resolveDecryptVerificationsOut newPath oldPath =
  case (newPath, oldPath) of
    (Just p, Nothing) -> pure (Just p, False)
    (Nothing, Just p) -> pure (Just p, True)
    (Just pNew, Just pOld)
      | pNew == pOld -> pure (Just pNew, True)
      | otherwise ->
        failWith
          IncompatibleOptions
          "decrypt: --verifications-out and --verify-out cannot target different files"
    (Nothing, Nothing) -> pure (Nothing, False)

renderSOPVerificationLine :: [TKUnknown] -> Verification -> String
renderSOPVerificationLine verifyTks v =
  ts ++ " " ++ signerFp ++ " " ++ certFp ++ " " ++ modeLabel
  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 (fst (_tkuKey tk)))))
        Nothing -> 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)

loadVerifyKeyringMap :: POSIXTime -> [String] -> IO PublicKeyring
loadVerifyKeyringMap cpt certFiles = fst <$> loadVerifyContext cpt certFiles

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

loadVerifyTKsFromFile :: String -> IO [TKUnknown]
loadVerifyTKsFromFile path = do
  lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
  certPkts <- decodeOpenPGPInput path lbs
  runConduitRes $ CL.sourceList certPkts .| conduitToTKsDropping .| CC.sinkList

loadCertTKsFromFile :: String -> String -> IO [TKUnknown]
loadCertTKsFromFile context path = do
  lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
  certPkts <- decodeOpenPGPInput path lbs
  rejectSecretKeyPackets context path certPkts
  runConduitRes $ CL.sourceList certPkts .| conduitToTKsDropping .| 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 :: TKUnknown -> TKUnknown
sanitizeVerifyTK tk =
  case primaryKeyIdentity (_tkuKey tk) of
    Nothing -> tk
    Just (primaryFp, primaryKeyId) ->
      tk
        { _tkuSubs =
            map
              (\(pkt, sigs) ->
                 let sanitized = mapMaybe (sanitizeBindingSignature primaryFp primaryKeyId) sigs
                  in if isSubkeyPacket pkt
                       then (pkt, sanitized)
                       else (pkt, sigs))
              (_tkuSubs tk)
        }
  where
    isSubkeyPacket PublicSubkeyPkt {} = True
    isSubkeyPacket SecretSubkeyPkt {} = True
    isSubkeyPacket _ = False

enforceVerifyPrimaryKeyPolicy :: TKUnknown -> Maybe TKUnknown
enforceVerifyPrimaryKeyPolicy tk =
  if primaryKeyTooSmallForVerification (_tkuKey tk)
    then Nothing
    else Just tk

primaryKeyTooSmallForVerification :: (SomePKPayload, Maybe SKAddendum) -> Bool
primaryKeyTooSmallForVerification (pkp, _) =
  case _pkalgo pkp of
    RSA -> rsaTooSmall
    DeprecatedRSASignOnly -> rsaTooSmall
    DeprecatedRSAEncryptOnly -> rsaTooSmall
    _ -> False
  where
    rsaTooSmall =
      case pubkeySize (_pubkey pkp) of
        Right bits -> bits < 2048
        Left _ -> False

primaryKeyIdentity :: (SomePKPayload, Maybe SKAddendum) -> Maybe (Fingerprint, EightOctetKeyId)
primaryKeyIdentity (pkp, _) = do
  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
    signatureHashedSubpackets (SigV4 _ _ _ hasheds _ _ _) = hasheds
    signatureHashedSubpackets (SigV6 _ _ _ _ hasheds _ _ _) = hasheds
    signatureHashedSubpackets _ = []

loadDecryptRecipientKeys ::
     POSIXTime -> [String] -> [BL.ByteString] -> IO [PKESKRecipientKey]
loadDecryptRecipientKeys _ [] _ = pure []
loadDecryptRecipientKeys cpt keyFiles passwords = concat <$> mapM loadFromFile keyFiles
  where
    loadFromFile path = do
      lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
      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 .| conduitToTKsDropping .| 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, _) = _tkuKey tk
          primaryFp = unFingerprint (fingerprint primaryPkp)
          primarySigs =
            concatMap snd (_tkuUIDs tk) ++
            concatMap snd (_tkuUAts tk) ++
            _tkuRevs tk
          primaryEntry = [ primaryFp | not (sigsAllowEncryption primarySigs) ]
          -- Subkeys: same rule as primary.
          subEntries =
            [ unFingerprint (fingerprint pkp)
            | (pkt, sigs) <- _tkuSubs tk
            , Just pkp <- [secretOrPublicSubkeyPayload pkt]
            , 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, _) = _tkuKey tk
          primarySigs =
            concatMap snd (_tkuUIDs tk) ++
            concatMap snd (_tkuUAts tk) ++
            _tkuRevs tk
          primaryAllows = supportsRecipientPKESKAlgorithm primaryPkp && sigsAllowEncryption primarySigs
          subAllows =
            any
              (\(pkt, sigs) ->
                 case secretOrPublicSubkeyPayload pkt of
                   Just pkp ->
                     supportsRecipientPKESKAlgorithm pkp && sigsAllowEncryption sigs
                   Nothing -> False)
              (_tkuSubs tk)
      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
      ]
    secretOrPublicSubkeyPayload (SecretSubkeyPkt pkp _) = Just pkp
    secretOrPublicSubkeyPayload (PublicSubkeyPkt pkp) = Just pkp
    secretOrPublicSubkeyPayload _ = Nothing
    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 <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
      pkts <- decodeOpenPGPInput path lbs
      rejectSecretKeyPackets "encrypt" path pkts
      tks <- runConduitRes $ CL.sourceList pkts .| conduitToTKsDropping .| 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 <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
      pkts <- decodeOpenPGPInput path lbs
      rejectSecretKeyPackets "encrypt" path pkts
      rejectCriticalUnknownRecipientPackets path pkts
      tks <- runConduitRes $ CL.sourceList pkts .| conduitToTKsDropping .| 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)) 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 -> TKUnknown -> Bool
primaryUserIDExpirationAllowsAt now tk =
  case primaryUidSigs of
    [] -> True
    _ -> any (signatureKeyExpirationAllowsAt now primaryCreatedAt) primaryUidSigs
  where
    primaryCreatedAt = fromIntegral (_timestamp (fst (_tkuKey tk)))
    primaryUidSigs =
      [ sig
      | (_, sigs) <- _tkuUIDs tk
      , 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 :: TKUnknown -> [SomePKPayload]
tkToEncryptPayloads (TKUnknown (pkp, _) _ _ _ subs) =
  filter supportsRecipientPKESKAlgorithm (pkp : mapMaybe extractSubkeyPayload subs)
  where
    extractSubkeyPayload (PublicSubkeyPkt subPkp, _) = Just subPkp
    extractSubkeyPayload (SecretSubkeyPkt subPkp _, _) = Just subPkp
    extractSubkeyPayload _ = Nothing

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 Ed25519 _) _ _ ->
      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
  when (inlineSignNoArmor && inlineSignArmor) $
    failWith IncompatibleOptions "inline-sign: --armor and --no-armor are mutually exclusive"
  forM_
    inlineSignProfile
    (\profile ->
       failWith UnsupportedOption
         ("inline-sign: unsupported option --profile=" ++ profile))
  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 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 && not inlineSignArmor
          then AA.encodeLazy [Armor ArmorMessage [] pktBytes]
          else if inlineSignArmor
                 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 key =
      map toLower key `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 (ListProfilesOptions sc) =
  case sc of
    "generate-key" ->
      putStr
        "default: implementation defaults\nrfc4880: RSA-4096 interoperability-focused key generation\ncompatibility: broad interoperability defaults (alias of rfc4880)\nsecurity: security-oriented key generation\nperformance: performance-oriented key generation\n"
    "encrypt" ->
      putStr
        "default: implementation defaults (alias of rfc9580, security, and performance)\nrfc9580: RFC 9580 packet format preferences\nrfc4880: RFC 4880 packet format preferences\ncompatibility: broad interoperability defaults (alias of rfc4880)\n"
    _ -> failWith UnsupportedProfile "Subcommand does not support profiles"
