hopenpgp-tools 0.25.8 → 0.25.9
raw patch · 4 files changed
+6596/−5857 lines, 4 filesdep ~hOpenPGP
Dependency ranges changed: hOpenPGP
Files
- HOpenPGP/Tools/Hokey/InjectSSHAgent.hs +6/−8
- HOpenPGP/Tools/Hokey/Lint/Policy.hs +2/−1
- hop.hs +6585/−5845
- hopenpgp-tools.cabal +3/−3
HOpenPGP/Tools/Hokey/InjectSSHAgent.hs view
@@ -245,9 +245,7 @@ "openpgp:" ++ BC8.unpack ( Base16.encode- ( BL.toStrict- (unFingerprint (fingerprint (injectableAuthSubkeyPKP candidate)))- )+ ((unFingerprint (fingerprint (injectableAuthSubkeyPKP candidate)))) ) sshAddIdentityRequest@@ -257,27 +255,27 @@ -> Either String BL.ByteString sshAddIdentityRequest comment subkeyPKP subkeySKA = case subkeySKA of- SUUnencrypted (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) _ ->+ SUSUnprotected (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) _ -> Right $ frameSSHAgentRequest (rsaAddIdentityPayload (BC8.pack comment) rsaPrivateKey)- SUUnencrypted (EdDSAPrivateKey EdSigningCurve25519 secretSeed) _ ->+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve25519 secretSeed) _ -> frameSSHAgentRequest <$> ed25519AddIdentityPayload (BC8.pack comment) subkeyPKP secretSeed- SUUnencrypted (UnknownSKey rawSecret) _+ SUSUnprotected (UnknownSKey rawSecret) _ | isEd25519PKA (_pkalgo subkeyPKP) -> frameSSHAgentRequest <$> ed25519AddIdentityPayload (BC8.pack comment) subkeyPKP (BL.toStrict rawSecret)- SUUnencrypted (EdDSAPrivateKey EdSigningCurve448 _) _ ->+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve448 _) _ -> Left ( "subkey " ++ renderFingerprint (fingerprint subkeyPKP) ++ " uses Ed448, which is not supported by ssh-agent add-identity" )- SUUnencrypted _ _ ->+ SUSUnprotected _ _ -> Left ( "subkey " ++ renderFingerprint (fingerprint subkeyPKP)
HOpenPGP/Tools/Hokey/Lint/Policy.hs view
@@ -624,7 +624,8 @@ , skVer = colorizeKV (_keyVersion pkp) , skCreationTime = _timestamp pkp , skAlgorithmAndSize = kasIt pkp- , skBindingSigHashAlgorithms = has pkp (filter isSKBindingSig sigs)+ , skBindingSigHashAlgorithms =+ map (colorizeHA . hashAlgo pkp) . filter isSKBindingSig $ sigs , skRevocationSigWeakDigests = subkeyRevocationSigWeakDigests pkp sigs , skUsageFlags = kufs pkp (filter isSKBindingSig sigs)
hop.hs view
@@ -54,5851 +54,6591 @@ , fingerprint ) import Codec.Encryption.OpenPGP.KeyGeneration- ( KeyGenSpec (..)- , generateSecretKey- )-import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)-import Codec.Encryption.OpenPGP.Message- ( EncryptMessageOptions (..)- , RecoveredSessionMaterial (..)- , SessionMaterialExposure (..)- , encryptMessage- , encryptedPayloadBytes- , mkClearPayload- )-import Codec.Encryption.OpenPGP.Ontology- ( isKUF- , isPKBindingSig- , isSKBindingSig- )-import Codec.Encryption.OpenPGP.Policy- ( defaultDecryptPolicy- , defaultPolicy- , defaultVerificationPolicy- , lenientDecryptPolicy- )-import Codec.Encryption.OpenPGP.S2K- ( decodeOpenPGPEncodedSessionKey- , renderS2KError- , skesk2Key- , skesk2SessionKey- , string2Key- )-import Codec.Encryption.OpenPGP.SecretKey- ( SecretKeyEncryptOptions (..)- , SecretKeyError (..)- , decryptPrivateKey- , encryptSecretKeyWithPolicy- , mkUnencryptedSKAddendum- , reencryptSecretKey- , renderSecretKeyError- )-import Codec.Encryption.OpenPGP.Serialize- ( parsePkts- , putSKeyForPKPayload- )-import Codec.Encryption.OpenPGP.Signatures- ( SignError (..)- , renderSignError- , signDataWithEd25519- , signDataWithEd25519Legacy- , signDataWithEd25519V6- , signDataWithEd448- , signDataWithEd448V6- , signDataWithRSABuilder- , signDataWithRSAV6- , signKeyRevocationWithRSA- , signUserIDwithRSA- )-import qualified Codec.Encryption.OpenPGP.Subpackets as SP-import Codec.Encryption.OpenPGP.Types-import qualified Codec.Encryption.OpenPGP.Version as HOV-import Control.Applicative (many, optional, some, (<|>))-import Control.Error.Util (note)-import Control.Exception- ( IOException- , SomeException- , catch- , displayException- , evaluate- , throwIO- )-import Control.Lens ((^..))-import Control.Monad (forM, forM_, unless, when, (>=>))-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.State.Lazy (StateT, evalStateT, get, modify)-import Control.Monad.Trans.Except (ExceptT, runExceptT)-import Crypto.Error (eitherCryptoError)-import qualified Crypto.Hash as CH-import qualified Crypto.Hash.Algorithms as CHA-import Crypto.Number.Serialize (i2ospOf_, os2ip)-import qualified Crypto.PubKey.Ed25519 as Ed25519-import qualified Crypto.PubKey.Ed448 as Ed448-import qualified Crypto.PubKey.RSA as RSA-import qualified Crypto.PubKey.RSA.PKCS15 as P15-import Crypto.Random.Types (MonadRandom, getRandomBytes)-import qualified Data.Aeson as A-import Data.Bifunctor (first)-import qualified Data.Binary as Bin-import Data.Binary.Get (runGet)-import Data.Binary.Put- ( putByteString- , putLazyByteString- , putWord16be- , putWord32be- , putWord8- , runPut- )-import Data.Bits (shiftL, shiftR, (.&.), (.|.))-import qualified Data.ByteArray as BA-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC8-import Data.Char (digitToInt, isHexDigit, isSpace, toLower)-import Data.Conduit (fuseBoth, runConduitRes, (.|))-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.Combinators as CC-import qualified Data.Conduit.List as CL-import Data.Conduit.OpenPGP.Decrypt- ( DecryptKeyResolution (..)- , DecryptOutcome (..)- , PKESKRecipientKey (..)- , renderDecryptStructureError- )-import qualified Data.Conduit.OpenPGP.Decrypt as Decrypt-import Data.Conduit.OpenPGP.Keyring- ( conduitDropErrorsAndNothings- , conduitToSomeTKsDroppingEither- , sinkPublicKeyringMap- )-import Data.Conduit.OpenPGP.Verify- ( conduitVerify- , verifyPacketsBatch- )-import Data.Data.Lens (biplate)-import Data.Either (fromRight, isLeft, isRight, rights)-import Data.IORef (IORef, atomicModifyIORef', newIORef)-import Data.List- ( find- , findIndex- , intercalate- , isInfixOf- , isPrefixOf- , isSuffixOf- , nub- , partition- , stripPrefix- )-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe- ( catMaybes- , fromMaybe- , isJust- , listToMaybe- , mapMaybe- , maybeToList- )-import qualified Data.Set as S-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import Data.Text.Encoding.Error (lenientDecode)-import Data.Time.Clock (UTCTime)-import Data.Time.Clock.POSIX- ( POSIXTime- , getPOSIXTime- , posixSecondsToUTCTime- , utcTimeToPOSIXSeconds- )-import Data.Time.Format (defaultTimeLocale, formatTime)-import Data.Time.Format.ISO8601 (iso8601ParseM)-import qualified Data.Vector as V-import Data.Version (showVersion)-import Data.Word (Word8)-import GHC.Generics-import Options.Applicative.Builder- ( argument- , command- , eitherReader- , footerDoc- , headerDoc- , help- , helpDoc- , info- , long- , metavar- , option- , prefs- , progDesc- , showHelpOnError- , str- , strArgument- , strOption- , switch- , value- )-import Options.Applicative.Extra- ( execParserPure- , helper- , hsubparser- , renderFailure- )-import Options.Applicative.Types- ( CompletionResult (..)- , Parser- , ParserResult (..)- )-import Prettyprinter- ( hardline- , list- , pretty- , softline- )-import Prettyprinter.Render.Text (hPutDoc)-import System.Directory (doesFileExist)-import System.Environment (getArgs, getProgName, lookupEnv)-import System.Exit- ( ExitCode (..)- , exitSuccess- , exitWith- )-import System.IO- ( BufferMode (..)- , Handle- , hPutStrLn- , hSetBuffering- , stderr- , stdin- )-import Text.Read (readMaybe)--import HOpenPGP.Tools.Common.Armor (doDeArmor)-import HOpenPGP.Tools.Common.Common- ( banner- , keyMatchesEightOctetKeyId- , keyMatchesFingerprint- , versioner- , warranty- )-import HOpenPGP.Tools.Common.TKUtils- ( processTK- , verifyTKWithTyped- )-import Paths_hopenpgp_tools (version)--data Command- = VersionC VersionOptions- | ListProfilesC ListProfilesOptions- | GenerateKeyC KeyGenOptions- | ChangeKeyPasswordC ChangeKeyPasswordOptions- | MergeCertsC MergeCertsOptions- | ValidateUserIdC ValidateUserIdOptions- | CertifyUserIdC CertifyUserIdOptions- | RevokeKeyC RevokeKeyOptions- | UpdateKeyC UpdateKeyOptions- | VerifyC VerifyOptions- | InlineVerifyC InlineVerifyOptions- | EncryptC EncryptOptions- | DecryptC DecryptOptions- | InlineSignC InlineSignOptions- | InlineDetachC InlineDetachOptions- | ExtractCertC ExtractCertOptions- | SignC SignOptions- | UnsupportedC String- | DeArmorC- | ArmorC--data OutputFormat- = Unstructured- | JSON- | YAML- deriving (Eq, Read, Show)--data VerifyOptions- = VerifyOptions- { verifyNotBefore :: Maybe String- , verifyNotAfter :: Maybe String- , verifySigFile :: String- , verifyCertFiles :: [String]- }--data InlineVerifyOptions- = InlineVerifyOptions- { inlineNotBefore :: Maybe String- , inlineNotAfter :: Maybe String- , verificationsOut :: Maybe String- , inlineCertFiles :: [String]- }--data EncryptOptions- = EncryptOptions- { encNoArmor :: Bool- , encProfile :: Maybe String- , encAs :: AsBinaryText- , encSignWithKeyFiles :: [String]- , encSignWithKeyPasswords :: [String]- , encSessionKeyOutFile :: Maybe String- , encFor :: EncryptFor- , encPasswords :: [String]- , encRecipientCerts :: [String]- }--data EncryptProfile- = EncryptProfileRFC9580- | EncryptProfileRFC4880- deriving (Eq)--data Profile p = Profile- { profileName :: String- , profileDescription :: String- , profileValue :: p- , profileAliases :: [String]- }--encryptProfiles :: [Profile EncryptProfile]-encryptProfiles =- [ Profile- "rfc9580"- "SEIPDv2"- EncryptProfileRFC9580- ["default", "security", "performance"]- , Profile- "rfc4880"- "SEIPDv1"- EncryptProfileRFC4880- ["compatibility"]- ]--data DecryptOptions- = DecryptOptions- { decNoArmor :: Bool- , decVerifyNotBefore :: Maybe String- , decVerifyNotAfter :: Maybe String- , decSessionKeys :: [String]- , decSessionKeyOutFile :: Maybe String- , decPasswords :: [String]- , decKeyPasswords :: [String]- , decKeyFiles :: [String]- , decVerifyCerts :: [String]- , decVerificationsOutFile :: Maybe String- }--data InlineSignOptions- = InlineSignOptions- { inlineSignNoArmor :: Bool- , inlineSignAs :: Maybe InlineSignMode- , inlineSignKeyFiles :: [String]- , inlineSignKeyPasswords :: [String]- }--data InlineDetachOptions- = InlineDetachOptions- { inlineDetachNoArmor :: Bool- , inlineDetachOutputSigs :: String- }--data ChangeKeyPasswordOptions- = ChangeKeyPasswordOptions- { changeKeyPasswordNoArmor :: Bool- , changeKeyPasswordOldPasswords :: [String]- , changeKeyPasswordNewPassword :: Maybe String- }--data MergeCertsOptions- = MergeCertsOptions- { mergeCertsNoArmor :: Bool- , mergeCertsFiles :: [String]- }--data ValidateUserIdOptions- = ValidateUserIdOptions- { validateUserIdAddrSpecOnly :: Bool- , validateUserIdAt :: Maybe String- , validateUserIdString :: String- , validateUserIdAuthorityFiles :: [String]- }--data CertifyUserIdOptions- = CertifyUserIdOptions- { certifyUserIds :: [String]- , certifyUserIdNoArmor :: Bool- , certifyUserIdNoRequireSelfSig :: Bool- , certifyUserIdKeyPasswordFiles :: [String]- , certifyUserIdSignerFiles :: [String]- }--data RevokeKeyOptions- = RevokeKeyOptions- { revokeKeyNoArmor :: Bool- , revokeKeyPasswordFiles :: [String]- }--data UpdateKeyOptions- = UpdateKeyOptions- { updateKeyNoArmor :: Bool- , updateKeySigningOnly :: Bool- , updateKeyRevokeDeprecatedKeys :: Bool- , updateKeyNoAddedCapabilities :: Bool- , updateKeyPasswordFiles :: [String]- , updateKeyMergeCerts :: [String]- }--newtype ListProfilesOptions- = ListProfilesOptions- { profileSubcommand :: String- }--data VersionOptions- = VersionOptions- { vBackend :: Bool- , vExtended :: Bool- , vSopSpec :: Bool- , vSopv :: Bool- }--data CliOptions- = CliOptions- { cliDebug :: Bool- , cliCommand :: Command- }--data SopFailure- = MissingArg- | IncompleteVerification- | BadData- | PasswordNotHumanReadable- | ExpectedText- | CannotDecrypt- | UnsupportedAsymmetricAlgo- | CertCannotEncrypt- | UnsupportedOption- | OutputExists- | MissingInput- | NoSignature- | KeyIsProtected- | KeyCannotSign- | UnsupportedSpecialPrefix- | IncompatibleOptions- | UnsupportedProfile- | UnsupportedSubcommand- | PrimaryKeyBad- | CertUserIdNoMatch- | KeyCannotCertify--failureCode :: SopFailure -> Int-failureCode MissingArg = 19-failureCode IncompleteVerification = 23-failureCode BadData = 41-failureCode PasswordNotHumanReadable = 31-failureCode ExpectedText = 53-failureCode CannotDecrypt = 29-failureCode UnsupportedAsymmetricAlgo = 13-failureCode CertCannotEncrypt = 17-failureCode UnsupportedOption = 37-failureCode OutputExists = 59-failureCode MissingInput = 61-failureCode NoSignature = 3-failureCode KeyIsProtected = 67-failureCode KeyCannotSign = 79-failureCode UnsupportedSpecialPrefix = 71-failureCode IncompatibleOptions = 83-failureCode UnsupportedProfile = 89-failureCode UnsupportedSubcommand = 69-failureCode PrimaryKeyBad = 103-failureCode CertUserIdNoMatch = 107-failureCode KeyCannotCertify = 109--failWith :: MonadIO m => SopFailure -> String -> m a-failWith f msg = liftIO $ do- BLC8.hPutStrLn stderr (BLC8.pack msg)- exitWith (ExitFailure (failureCode f))--voP :: Parser VerifyOptions-voP =- VerifyOptions- <$> optional- ( strOption- ( long "not-before"- <> metavar "DATE"- <> help "ignore signatures before DATE"- )- )- <*> optional- ( strOption- ( long "not-after"- <> metavar "DATE"- <> help "ignore signatures after DATE"- )- )- <*> argument str (metavar "SIGNATURES" <> sigHelp)- <*> some (strArgument (metavar "CERTS..." <> certHelp))- where- sigHelp =- helpDoc . Just $- pretty "file containing OpenPGP signatures"- certHelp =- helpDoc . Just $- pretty "one or more certificate files"--ivoP :: Parser InlineVerifyOptions-ivoP =- InlineVerifyOptions- <$> optional- ( strOption- ( long "not-before"- <> metavar "DATE"- <> help "ignore signatures before DATE"- )- )- <*> optional- ( strOption- ( long "not-after"- <> metavar "DATE"- <> help "ignore signatures after DATE"- )- )- <*> optional- ( strOption- ( long "verifications-out"- <> metavar "VERIFICATIONS"- <> help "write verification records to file"- )- )- <*> some (strArgument (metavar "CERTS..." <> certHelp))- where- certHelp =- helpDoc . Just $- pretty "one or more certificate files"--lpoP :: Parser ListProfilesOptions-lpoP =- ListProfilesOptions- <$> strArgument- (metavar "SUBCOMMAND" <> help "subcommand to list profiles for")--vopP :: Parser VersionOptions-vopP =- VersionOptions- <$> switch- (long "backend" <> help "show backend implementation version")- <*> switch- (long "extended" <> help "show extended version information")- <*> switch (long "sop-spec" <> help "show targeted sop draft")- <*> switch- (long "sopv" <> help "show implemented sopv subset version")--encP :: Parser EncryptOptions-encP =- EncryptOptions- <$> switch (long "no-armor" <> help "output binary")- <*> optional- (strOption (long "profile" <> help "encryption profile"))- <*> option- (eitherReader asTypeReader)- (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)- <*> many- (strOption (long "sign-with" <> help "signing key material"))- <*> many- ( strOption- ( long "with-key-password"- <> help "password for unlocking signing key material"- )- )- <*> optional- ( strOption- ( long "session-key-out"- <> metavar "SESSIONKEY"- <> help "write generated session key to file"- )- )- <*> option- (eitherReader encryptForReader)- ( long "for"- <> metavar "ENCRYPTION_PURPOSE"- <> help- "select recipient key purpose (any, storage, communications)"- <> value EncryptForAny- )- <*> many- ( strOption- (long "with-password" <> help "symmetric encryption password")- )- <*> many- ( strArgument- (metavar "CERT" <> help "recipient certificate files")- )- where- astypeHelp =- helpDoc . Just $- pretty "what to treat the input as"- <> softline- <> list (map (pretty . fst) asTypes)--decP :: Parser DecryptOptions-decP =- DecryptOptions- <$> switch (long "no-armor" <> help "output binary")- <*> optional- ( strOption- ( long "verify-not-before"- <> metavar "DATE"- <> help "ignore signatures before DATE when decrypting"- )- )- <*> optional- ( strOption- ( long "verify-not-after"- <> metavar "DATE"- <> help "ignore signatures after DATE when decrypting"- )- )- <*> many- ( strOption- (long "with-session-key" <> help "session key for decryption")- )- <*> optional- ( strOption- (long "session-key-out" <> help "write recovered session key")- )- <*> many- ( strOption- (long "with-password" <> help "password for SKESK decryption")- )- <*> many- ( strOption- ( long "with-key-password"- <> help "password for unlocking decryption key material"- )- )- <*> many (strArgument (metavar "KEY" <> help "secret key material"))- <*> many- ( strOption- ( long "verify-with"- <> help "certificate(s) to verify signatures with"- )- )- <*> optional- ( strOption- ( long "verifications-out"- <> help "write verification results to file"- )- )--inlineSignP :: Parser InlineSignOptions-inlineSignP =- InlineSignOptions- <$> switch (long "no-armor" <> help "output binary")- <*> optional- ( option- (eitherReader inlineSignModeReader)- (long "as" <> metavar "DATATYPE" <> inlineSignAsHelp)- )- <*> some (strArgument (metavar "KEY" <> help "signing key file(s)"))- <*> many- ( strOption- ( long "with-key-password"- <> metavar "PASSWORD"- <> help "password for encrypted signing key"- )- )- where- inlineSignAsHelp =- helpDoc . Just $- pretty "what to treat the input as"- <> softline- <> list [pretty "binary", pretty "text", pretty "clearsigned"]--inlineDetachP :: Parser InlineDetachOptions-inlineDetachP =- InlineDetachOptions- <$> switch (long "no-armor" <> help "output binary")- <*> strOption- ( long "signatures-out"- <> metavar "SIGNATURES"- <> help "write detached signatures to file"- )--mergeCertsP :: Parser MergeCertsOptions-mergeCertsP =- MergeCertsOptions- <$> switch (long "no-armor" <> help "output binary")- <*> some- ( strArgument- (metavar "CERTS..." <> help "one or more certificate files")- )--validateUserIdP :: Parser ValidateUserIdOptions-validateUserIdP =- ValidateUserIdOptions- <$> switch- ( long "addr-spec-only"- <> help- "match only the addr-spec portion of conventional OpenPGP User IDs"- )- <*> optional- ( strOption- ( long "validate-at"- <> metavar "DATE"- <> help "evaluate certifications at DATE"- )- )- <*> argument str (metavar "USERID" <> help "user ID to validate")- <*> some- ( strArgument- ( metavar "CERTS..."- <> help "one or more authority certificate files"- )- )--certifyUserIdP :: Parser CertifyUserIdOptions-certifyUserIdP =- CertifyUserIdOptions- <$> some- ( strOption- ( long "userid"- <> metavar "USERID"- <> help "user ID to certify (repeatable)"- )- )- <*> switch- ( long "no-armor"- <> help "output binary"- )- <*> switch- ( long "no-require-self-sig"- <> help "allow certifying user IDs that do not have self-signatures"- )- <*> many- ( strOption- ( long "with-key-password"- <> help "password for unlocking signer key material"- )- )- <*> some- ( strArgument- (metavar "KEYS..." <> help "one or more signer key files")- )--revokeKeyP :: Parser RevokeKeyOptions-revokeKeyP =- RevokeKeyOptions- <$> switch (long "no-armor" <> help "output binary")- <*> many- ( strOption- ( long "with-key-password"- <> help "password for unlocking secret key material"- )- )--updateKeyP :: Parser UpdateKeyOptions-updateKeyP =- UpdateKeyOptions- <$> switch (long "no-armor" <> help "output binary")- <*> switch- ( long "signing-only"- <> help "limit updated material to signing-capable key material"- )- <*> switch- ( long "revoke-deprecated-keys"- <> help- "emit revocations for deprecated key material when supported"- )- <*> switch- ( long "no-added-capabilities"- <> help- "do not add capabilities beyond existing target key material"- )- <*> many- ( strOption- ( long "with-key-password"- <> help "password for unlocking key material"- )- )- <*> many- ( strOption- ( long "merge-certs"- <> metavar "CERTS"- <> help "additional certificate files to merge into target keys"- )- )--changeKeyPasswordP :: Parser ChangeKeyPasswordOptions-changeKeyPasswordP =- ChangeKeyPasswordOptions- <$> switch (long "no-armor" <> help "output binary")- <*> many- ( strOption- ( long "old-key-password"- <> help "password(s) used to unlock existing secret key material"- )- )- <*> optional- ( strOption- ( long "new-key-password"- <> help "password used to protect rewritten secret key material"- )- )--dispatch :: POSIXTime -> Command -> IO ()-dispatch cpt cmd' = dispatch' cpt cmd'- where- dispatch' _ (VersionC o') = doVersion o'- dispatch' _ (ListProfilesC o') = doListProfiles o'- dispatch' t (GenerateKeyC o) = doGenerateKey t o- dispatch' _ (ChangeKeyPasswordC o) = doChangeKeyPassword o- dispatch' _ (MergeCertsC o) = doMergeCerts o- dispatch' t (ValidateUserIdC o) = doValidateUserId t o- dispatch' t (CertifyUserIdC o) = doCertifyUserId t o- dispatch' t (RevokeKeyC o) = doRevokeKey t o- dispatch' t (UpdateKeyC o) = doUpdateKey t o- dispatch' t (VerifyC o') = doVerify t o'- dispatch' t (InlineVerifyC o') = doInlineVerify t o'- dispatch' t (EncryptC o') = doEncrypt t o'- dispatch' t (DecryptC o') = doDecrypt t o'- dispatch' t (InlineSignC o') = doInlineSign t o'- dispatch' t (InlineDetachC o') = doInlineDetach t o'- dispatch' _ (ExtractCertC o) = doExtractCert o- dispatch' t (SignC o) = doSign t o- dispatch' _ (UnsupportedC c) =- failWith- UnsupportedSubcommand- ("command not yet implemented: " ++ c)- dispatch' _ DeArmorC = doDeArmor- dispatch' _ ArmorC = doArmor--main :: IO ()-main = do- hSetBuffering stderr LineBuffering- args <- getArgs- ensureKnownSubcommand knownSopSubcommands args- cpt <- getPOSIXTime- let result =- execParserPure- (prefs showHelpOnError)- ( info- (helper <*> versioner "hop" <*> cliP)- ( headerDoc (Just (banner "hop"))- <> progDesc "hOpenPGP SOP Tool"- <> footerDoc (Just (warranty "hop"))- )- )- args- case result of- Success cliOptions -> do- let _ = cliDebug cliOptions- dispatch cpt (cliCommand cliOptions)- Failure f -> do- let (msg, ec) = renderFailure f "hop"- case ec of- ExitSuccess -> putStrLn msg >> exitSuccess- ExitFailure 1- | "Invalid option" `isInfixOf` msg- || "Invalid argument" `isInfixOf` msg ->- hPutStrLn stderr msg >> exitWith (ExitFailure 37)- | otherwise ->- hPutStrLn stderr msg >> exitWith (ExitFailure 19)- _ -> hPutStrLn stderr msg >> exitWith ec- CompletionInvoked compl -> do- progn <- getProgName- msg <- execCompletion compl progn- putStr msg- exitSuccess--knownSopSubcommands :: [String]-knownSopSubcommands =- [ "armor"- , "dearmor"- , "change-key-password"- , "decrypt"- , "encrypt"- , "certify-userid"- , "extract-cert"- , "generate-key"- , "inline-detach"- , "inline-sign"- , "inline-verify"- , "list-profiles"- , "merge-certs"- , "revoke-key"- , "sign"- , "update-key"- , "validate-userid"- , "verify"- , "version"- ]--ensureKnownSubcommand :: [String] -> [String] -> IO ()-ensureKnownSubcommand knownSubcommands args =- if any (`elem` ["-h", "--help", "--version"]) args- then pure ()- else case find (not . isPrefixOf "-") args of- Just subcommand- | subcommand `notElem` knownSubcommands ->- failWith- UnsupportedSubcommand- ("unsupported subcommand: " ++ subcommand)- _ -> pure ()--cliP :: Parser CliOptions-cliP =- CliOptions- <$> switch (long "debug" <> help "emit more verbose output")- <*> cmd--banner' :: Handle -> IO ()-banner' h =- hPutDoc- h- (banner "hop" <> hardline <> warranty "hop" <> hardline)--data Vrf- = Vrf- { _vrfmsg :: String- , _vrfmfpr :: Maybe Fingerprint- }- deriving (Eq, Generic, Show)--instance A.ToJSON Vrf--cmd :: Parser Command-cmd =- hsubparser- ( command- "armor"- (info (pure ArmorC) (progDesc "Armor stdin to stdout"))- <> command- "dearmor"- (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout"))- <> command- "change-key-password"- ( info- (ChangeKeyPasswordC <$> changeKeyPasswordP)- (progDesc "Update a key password")- )- <> command- "decrypt"- (info (DecryptC <$> decP) (progDesc "Decrypt a message"))- <> command- "encrypt"- (info (EncryptC <$> encP) (progDesc "Encrypt a message"))- <> command- "certify-userid"- ( info- (CertifyUserIdC <$> certifyUserIdP)- (progDesc "Certify user IDs in a certificate")- )- <> command- "extract-cert"- ( info- (ExtractCertC <$> ecoP)- ( progDesc- "Extract a certificate from a secret key and output it to stdout"- )- )- <> command- "generate-key"- ( info- (GenerateKeyC <$> gkoP)- (progDesc "Generate a secret key and output it to stdout")- )- <> command- "inline-detach"- ( info- (InlineDetachC <$> inlineDetachP)- (progDesc "Create inline detached signatures")- )- <> command- "inline-sign"- ( info- (InlineSignC <$> inlineSignP)- (progDesc "Create inline signatures")- )- <> command- "inline-verify"- ( info- (InlineVerifyC <$> ivoP)- (progDesc "Verify inline-signed data")- )- <> command- "list-profiles"- (info (ListProfilesC <$> lpoP) (progDesc "List SOP profiles"))- <> command- "merge-certs"- ( info- (MergeCertsC <$> mergeCertsP)- (progDesc "Merge OpenPGP certificates")- )- <> command- "revoke-key"- ( info- (RevokeKeyC <$> revokeKeyP)- (progDesc "Create a key revocation certificate")- )- <> command- "sign"- ( info- (SignC <$> soP)- (progDesc "Create detached signatures and output them to stdout")- )- <> command- "update-key"- (info (UpdateKeyC <$> updateKeyP) (progDesc "Update key material"))- <> command- "validate-userid"- ( info- (ValidateUserIdC <$> validateUserIdP)- (progDesc "Validate a certificate user ID")- )- <> command- "verify"- (info (VerifyC <$> voP) (progDesc "Verify signatures"))- <> command- "version"- ( info- (VersionC <$> vopP)- (progDesc "output hop version to stdout")- )- )--doArmor :: IO ()-doArmor = do- m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume- let lbs = BL.fromChunks m- armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs- if armoredAlready- then BL.putStr lbs- else do- let label' = guessLabel (decodeAllPackets lbs) lbs- a = Armor label' [] lbs- BL.putStr $ AA.encodeLazy [a]- where- decodeAllPackets lbs = runGet (many Bin.get) lbs- guessLabel [] _ = ArmorMessage- guessLabel (pkt : _) lbs =- case pkt of- SignaturePkt _ ->- if all isSignaturePacket (decodeAllPackets lbs)- then ArmorSignature- else ArmorMessage- SecretKeyPkt _ _ -> ArmorPrivateKeyBlock- PublicKeyPkt _ -> ArmorPublicKeyBlock- _ -> ArmorMessage- isSignaturePacket SignaturePkt {} = True- isSignaturePacket _ = False--doVersion :: VersionOptions -> IO ()-doVersion VersionOptions {..} = do- let selected = length (filter id [vBackend, vExtended, vSopSpec, vSopv])- when (selected > 1) $- failWith- IncompatibleOptions- "version: --backend, --extended, --sop-spec, and --sopv are mutually exclusive"- when vBackend $- putStrLn $- "hOpenPGP " ++ HOV.version- when vExtended $ do- mapM_ putStrLn $- [ "hop " ++ showVersion version- , ""- , "This is hop, from hopenpgp-tools " ++ showVersion version ++ ","- , "built with hOpenPGP " ++ HOV.version- ]- when vSopSpec $- putStrLn "draft-dkg-openpgp-stateless-cli-16"- when vSopv $- putStrLn "1.0"- unless (vBackend || vExtended || vSopSpec || vSopv) $- putStrLn $- "hop " ++ showVersion version--gkoP :: Parser KeyGenOptions-gkoP =- KeyGenOptions- <$> switch (long "no-armor" <> help "don't armor the output")- <*> optional- ( strOption- ( long "with-key-password"- <> help "password used to protect generated secret key material"- )- )- <*> optional- ( strOption- ( long "profile"- <> metavar "PROFILE"- <> help- "key generation profile (default, rfc4880, compatibility, security, performance)"- )- )- <*> switch- (long "signing-only" <> help "generate signing-only key material")- <*> many- ( strArgument- (metavar "USERID" <> help "User ID associated with this key")- )--data KeyGenOptions- = KeyGenOptions- { noArmor :: Bool- , keyPassword :: Maybe String- , keyProfile :: Maybe String- , keySigningOnly :: Bool- , userIds :: [String]- }--doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()-doGenerateKey pt KeyGenOptions {..} = do- profile <- parseKeyGenProfile keyProfile- password <- parseGenerateKeyPassword keyPassword- let ts = ThirtyTwoBitTimeStamp (floor pt)- keyVersion = keyVersionForProfile profile- sk <-- runExceptT- ( runSomeKeyGenSpec- (primaryKeySpecForProfile ts keyVersion profile)- )- >>= either (failWith BadData) pure- baseKey <-- buildKeyWith sk $ do- case userIds of- (primaryUid : restUids) -> do- addUserId ts True (T.pack primaryUid)- mapM_ (addUserId ts False . T.pack) restUids- [] -> pure ()- addSubkeysForProfile ts keyVersion profile keySigningOnly- newkey <- get- return newkey- baseKeyWithDirectSig <-- if keyVersion == V6- then do- let pkp = keyPktPKPayload (_tkPrimaryKey baseKey)- ska = case _tkPrimaryKey baseKey of- KeyPktSecretPrimary _ ska' -> ska'- _ -> error "doGenerateKey: expected secret primary key"- issuer <- issuerSubpacketsFor "generate-key" pkp- let hashed =- [ SigSubPacket False (SigCreationTime ts)- , SigSubPacket- False- ( IssuerFingerprint- (issuerFingerprintVersionFor pkp)- (fingerprint pkp)- )- , SigSubPacket False (KeyFlags (S.singleton CertifyKeysKey))- ]- payload = runPut $ putKeyForSigning pkp- sig <-- signWithKey- "generate-key"- pkp- DirectKeySignature- SHA512- hashed- issuer- payload- (Just ska)- pure baseKey {_tkRevs = _tkRevs baseKey ++ [sig]}- else pure baseKey- s <-- maybe- (pure (SomeSecretTK baseKeyWithDirectSig))- ( `encryptTransferableSecretKey`- (SomeSecretTK baseKeyWithDirectSig)- )- password- let lbs = runPut $ Bin.put (someTKToUnknown s)- BL.putStr $- if not noArmor- then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs]- else lbs--type KeyBuilder = StateT (TK 'SecretTK) IO--buildKeyWith :: (SomePKPayload, SKey) -> KeyBuilder a -> IO a-buildKeyWith (pkp, ska) a =- case secretAddendumForGeneratedKey pkp ska of- Right add -> evalStateT a (bareKT pkp add)- Left err ->- failWith- BadData- ("generate-key: invalid secret key material: " ++ err)- where- bareKT pkp add =- TK- { _tkPrimaryKey = KeyPktSecretPrimary pkp add- , _tkRevs = []- , _tkDirectKeySigs = []- , _tkUIDs = []- , _tkUAts = []- , _tkSubs = []- }--secretAddendumForGeneratedKey- :: SomePKPayload -> SKey -> Either String SKAddendum-secretAddendumForGeneratedKey pkp skey =- mkUnencryptedSKAddendum pkp skey--data SomeKeyGenSpec where- SomeKeyGenSpec :: KeyGenSpec v -> SomeKeyGenSpec--runSomeKeyGenSpec- :: MonadRandom m- => SomeKeyGenSpec- -> ExceptT String m (SomePKPayload, SKey)-runSomeKeyGenSpec (SomeKeyGenSpec spec) = generateSecretKey spec--modifyTKSecretKeysM- :: Monad m- => TK 'SecretTK- -> (SomePKPayload -> SKAddendum -> m SKAddendum)- -> m (TK 'SecretTK)-modifyTKSecretKeysM tk cb = do- let keys = tkSecretKeyPairs tk- newSkas <- mapM (uncurry cb) keys- let index = zip (map fst keys) newSkas- pure $- modifyTKSecretKeys tk $- \pkp ska -> (pkp, fromMaybe ska (lookup pkp index))--modifyTKSecretKeysE- :: TK 'SecretTK- -> (SomePKPayload -> SKAddendum -> IO (Either String SKAddendum))- -> IO (Either String (TK 'SecretTK))-modifyTKSecretKeysE tk cb = do- let keys = tkSecretKeyPairs tk- result <- mapM (uncurry cb) keys- case sequence result of- Left err -> pure (Left err)- Right skas ->- let index = zip (map fst keys) skas- in pure $- Right $- modifyTKSecretKeys tk $- \pkp ska -> (pkp, fromMaybe ska (lookup pkp index))--data KeyGenProfile- = KeyGenRFC4880- | KeyGenSecurity- | KeyGenSigningOnly- deriving (Eq)--keyGenProfiles :: [Profile KeyGenProfile]-keyGenProfiles =- [ Profile- "security"- "Ed25519 signing key, X25519 encryption subkey"- KeyGenSecurity- ["default", "performance", "rfc9580"]- , Profile- "rfc4880"- "RSA-4096 (v4 keys)"- KeyGenRFC4880- ["compatibility"]- ]--resolveProfile :: String -> [Profile p] -> Maybe p-resolveProfile name profiles =- lookup name [(profileName p, profileValue p) | p <- profiles]- <|> profileValue- <$> find (\p -> name `elem` profileAliases p) profiles--parseKeyGenProfile :: Maybe String -> IO KeyGenProfile-parseKeyGenProfile Nothing = pure KeyGenSecurity-parseKeyGenProfile (Just name) =- case resolveProfile name keyGenProfiles of- Just p -> pure p- Nothing ->- failWith- UnsupportedProfile- ("generate-key: unsupported profile " ++ name)--keyVersionForProfile :: KeyGenProfile -> KeyVersion-keyVersionForProfile KeyGenRFC4880 = V4-keyVersionForProfile KeyGenSecurity = V6-keyVersionForProfile KeyGenSigningOnly = V6--primaryKeySpecForProfile- :: ThirtyTwoBitTimeStamp- -> KeyVersion- -> KeyGenProfile- -> SomeKeyGenSpec-primaryKeySpecForProfile ts version KeyGenRFC4880 =- case version of- V4 -> SomeKeyGenSpec (KeyGenRSA ts 4096 :: KeyGenSpec V4)- V6 -> SomeKeyGenSpec (KeyGenRSA ts 4096 :: KeyGenSpec V6)- DeprecatedV3 -> error "primaryKeySpecForProfile: V3 unsupported"-primaryKeySpecForProfile ts _ _ =- SomeKeyGenSpec (KeyGenEd25519 ts)--parseGenerateKeyPassword- :: Maybe String -> IO (Maybe BL.ByteString)-parseGenerateKeyPassword Nothing = pure Nothing-parseGenerateKeyPassword (Just passwordFile) =- Just- <$> ( loadPasswordFromFile- "generate-key"- "--with-key-password"- passwordFile- >>= normalizeHumanReadablePassword- "generate-key"- "--with-key-password"- )--loadPasswordFiles- :: String -> String -> [String] -> IO [BL.ByteString]-loadPasswordFiles context optionName = mapM (loadPasswordFromFile context optionName)--loadPasswordFromFile- :: String -> String -> FilePath -> IO BL.ByteString-loadPasswordFromFile = loadFromFile "password file"--loadInputFromFile- :: String -> String -> FilePath -> IO BL.ByteString-loadInputFromFile = loadFromFile "file"--loadFromFile- :: String -> String -> String -> FilePath -> IO BL.ByteString-loadFromFile fileKind context optionName path = do- case stripPrefix "@ENV:" path of- Just varName- | null varName ->- failWith- BadData- (context ++ ": empty environment variable name in " ++ optionName)- | otherwise -> do- envValue <- lookupEnv varName- case envValue of- Nothing ->- failWith- MissingInput- ( context- ++ ": environment variable not found for "- ++ optionName- ++ ": "- ++ varName- )- Just envVal -> pure (BLC8.pack envVal)- Nothing ->- case stripPrefix "@FD:" path of- Just fdSpec -> loadFromFD 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- ++ ": "- ++ fileKind- ++ " does not exist for "- ++ optionName- ++ ": "- ++ path- )- BL.readFile path--loadFromFD- :: String -> String -> String -> IO BL.ByteString-loadFromFD 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- )--loadOpenPGPPackets- :: String -> FilePath -> IO [Pkt]-loadOpenPGPPackets context path = do- lbs <- loadInputFromFile context "file" path- decodeOpenPGPInput path lbs--normalizeHumanReadablePassword- :: String -> String -> BL.ByteString -> IO BL.ByteString-normalizeHumanReadablePassword context optionName passwordBytes =- case TE.decodeUtf8' (BL.toStrict passwordBytes) of- Left _ ->- failWith- PasswordNotHumanReadable- ( context- ++ ": password is not human-readable UTF-8 for "- ++ optionName- )- Right txt ->- pure- (BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt)))--passwordRetryCandidates :: BL.ByteString -> [BL.ByteString]-passwordRetryCandidates passwordBytes =- case TE.decodeUtf8' (BL.toStrict passwordBytes) of- Left _ -> [passwordBytes]- Right txt ->- let trimmed = BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt))- in if trimmed == passwordBytes- then [passwordBytes]- else [passwordBytes, trimmed]--addSubkeysForProfile- :: ThirtyTwoBitTimeStamp- -> KeyVersion- -> KeyGenProfile- -> Bool- -> KeyBuilder ()-addSubkeysForProfile ts keyVersion _profile signingOnly = do- addSubkey ts keyVersion _profile [SignDataKey]- unless signingOnly $ do- addSubkey- ts- keyVersion- _profile- [EncryptStorageKey, EncryptCommunicationsKey]- addSubkey ts keyVersion _profile [AuthKey]--subkeySpecForProfile- :: ThirtyTwoBitTimeStamp- -> KeyVersion- -> KeyGenProfile- -> [KeyFlag]- -> SomeKeyGenSpec-subkeySpecForProfile ts version KeyGenRFC4880 _ =- case version of- V4 -> SomeKeyGenSpec (KeyGenRSA ts 4096 :: KeyGenSpec V4)- V6 -> SomeKeyGenSpec (KeyGenRSA ts 4096 :: KeyGenSpec V6)- DeprecatedV3 -> error "subkeySpecForProfile: V3 unsupported"-subkeySpecForProfile ts _ _ keyflags- | any- (`elem` keyflags)- [EncryptStorageKey, EncryptCommunicationsKey] =- SomeKeyGenSpec (KeyGenX25519 ts)- | otherwise =- SomeKeyGenSpec (KeyGenEd25519 ts)--encryptUnencryptedV4SecretKey- :: SomePKPayload- -> SKey- -> BL.ByteString- -> IO (Either String SKAddendum)-encryptUnencryptedV4SecretKey pkp skey passphrase = do- saltBytes <- getRandomBytes 8- ivBytes <- getRandomBytes 16- let sa = AES256- keyLen = 32- s2k = IteratedSalted SHA256 (Salt8 saltBytes) 65536- iv = IV ivBytes- pure $- case string2Key s2k keyLen passphrase of- Left err -> Left (renderS2KError err)- Right keyMaterial ->- case putSKeyForPKPayload pkp skey of- Left err -> Left err- Right putAction ->- let cleartext = runPut putAction- sha1Checksum =- BA.convert- (CH.hash (BL.toStrict cleartext) :: CH.Digest CHA.SHA1)- clearWithChecksum =- BL.toStrict (cleartext <> BL.fromStrict sha1Checksum)- in case encryptNoNonce sa s2k iv clearWithChecksum keyMaterial of- Left err -> Left (show err)- Right encrypted ->- Right (SUSSHA1 sa s2k iv (BL.fromStrict encrypted))--encryptTransferableSecretKey- :: BL.ByteString -> SomeTK -> IO SomeTK-encryptTransferableSecretKey password stk =- case stk of- SomePublicTK _ -> pure stk- SomeSecretTK tk -> do- tk' <-- modifyTKSecretKeysM tk (encryptSecretAddendumForOutput password)- pure $ SomeSecretTK tk'- where- encryptSecretAddendumForOutput- :: BL.ByteString -> SomePKPayload -> SKAddendum -> IO SKAddendum- encryptSecretAddendumForOutput password pkp ska =- case ska of- SUUnencrypted skey _- | _keyVersion pkp == V4 -> do- result <- encryptUnencryptedV4SecretKey pkp skey password- case result of- Left err ->- failWith- BadData- ( "generate-key: failed to protect V4 secret key material: "- ++ err- )- Right val -> pure val- SUUnencrypted skey _ ->- encryptSecretKeyWithPolicy- defaultPolicy- pkp- skey- (Passphrase password)- >>= \result -> case result of- Left err ->- failWith- BadData- ( "generate-key: failed to protect secret key material: "- ++ show err- )- Right val -> pure val- _ -> pure ska--changeTKPassword- :: [BL.ByteString]- -> Maybe BL.ByteString- -> SomeTK- -> IO (Either String SomeTK)-changeTKPassword oldPasswords mNewPassword stk =- case stk of- SomePublicTK _ -> pure $ Right stk- SomeSecretTK tk -> do- result <-- modifyTKSecretKeysE- tk- (changeSKAddendum oldPasswords mNewPassword)- case result of- Left err -> pure $ Left err- Right tk' -> pure $ Right $ SomeSecretTK tk'- where- changeSKAddendum- :: [BL.ByteString]- -> Maybe BL.ByteString- -> SomePKPayload- -> SKAddendum- -> IO (Either String SKAddendum)- changeSKAddendum oldPasswords mNewPassword pkp ska =- case ska of- SUUnencrypted skey _ ->- case _keyVersion pkp of- V4 ->- case mNewPassword of- Just newPassword -> do- result <- encryptUnencryptedV4SecretKey pkp skey newPassword- case result of- Right newSka -> pure $ Right newSka- Left err -> pure $ Left err- Nothing -> pure $ Right ska- _ ->- case mNewPassword of- Just newPassword -> do- encryptedResult <-- encryptSecretKeyWithPolicy- defaultPolicy- pkp- skey- (Passphrase newPassword)- case encryptedResult of- Right newSka -> pure $ Right newSka- Left err -> pure $ Left (renderSecretKeyError err)- Nothing -> pure $ Right ska- _ ->- case mNewPassword of- Just newPassword ->- tryReencrypt oldPasswords newPassword pkp ska- Nothing ->- tryDecrypt oldPasswords pkp ska-- tryReencrypt [] _ _ _ = pure $ Left "no usable password for encrypted key material"- tryReencrypt (old : rest) newPassword pkp ska = do- if _keyVersion pkp == V4- then do- case decryptPrivateKey (pkp, ska) old of- Left _ -> tryReencrypt rest newPassword pkp ska- Right (SUUnencrypted skey _) -> do- result <- encryptUnencryptedV4SecretKey pkp skey newPassword- case result of- Right newSka -> pure $ Right newSka- Left _ -> tryReencrypt rest newPassword pkp ska- Right _ -> tryReencrypt rest newPassword pkp ska- else do- result <-- reencryptSecretKey- ( SecretKey- { _secretKeyPKPayload = pkp- , _secretKeySKAddendum = ska- }- )- (Passphrase old)- (Passphrase newPassword)- SecretKeyEncryptOptions- { skeoPolicy = defaultPolicy- , skeoGenerateSaltAndIV = True- , skeoSalt = Nothing- , skeoIV = Nothing- }- case result of- Right (SecretKey {_secretKeySKAddendum = newSka}) ->- pure $ Right newSka- Left _ -> tryReencrypt rest newPassword pkp ska-- tryDecrypt [] _ _ = pure $ Left "no usable password for encrypted key material"- tryDecrypt (old : rest) pkp ska =- case decryptPrivateKey (pkp, ska) old of- Right decrypted -> pure $ Right decrypted- Left _ -> tryDecrypt rest pkp ska--rsaSigningKey :: SKAddendum -> IO RSA.PrivateKey-rsaSigningKey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) =- pure (k {RSA.private_p = 0, RSA.private_q = 0})-rsaSigningKey _ =- failWith- BadData- "generate-key: unsupported secret key format for RSA signing"--issuerSubpacketsFor- :: String -> SomePKPayload -> IO [SigSubPacket]-issuerSubpacketsFor context pkp =- case _keyVersion pkp of- V6 -> pure []- _ ->- case eightOctetKeyID pkp of- Left err ->- failWith- BadData- (context ++ ": could not derive issuer key id: " ++ show err)- Right keyId -> pure [SigSubPacket False (Issuer keyId)]--addUserId- :: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder ()-addUserId ts primary userid = do- tk <- get- let pkp = keyPktPKPayload (_tkPrimaryKey tk)- ska :: SKAddendum- ska = case _tkPrimaryKey tk of- KeyPktSecretPrimary _ ska' -> ska'- _ -> error "addUserId: expected secret primary key"- signed <- selfsign pkp ska userid- modify (newUID signed)- where- newUID signed tk = tk {_tkUIDs = _tkUIDs tk ++ [signed]}- selfsign pkp ska u = do- issuer <- liftIO (unhashed pkp)- sig <-- liftIO $- signWithKey- "generate-key"- pkp- PositiveCert- SHA512- (hashed pkp)- issuer- (userIdPayloadForSigning pkp (UserId u))- (Just ska)- pure (u, [sig])- hashed pkp =- [ SigSubPacket False (SigCreationTime ts)- , SigSubPacket- False- ( IssuerFingerprint- (issuerFingerprintVersionFor pkp)- (fingerprint pkp)- )- , SigSubPacket False (KeyFlags (S.singleton CertifyKeysKey))- , SigSubPacket False (PrimaryUserId primary)- , SigSubPacket- False- (PreferredHashAlgorithms [SHA512, SHA256, SHA384, SHA224])- , SigSubPacket- False- (PreferredSymmetricAlgorithms [AES256, AES192, AES128])- ]- unhashed = issuerSubpacketsFor "generate-key"--addSubkey- :: ThirtyTwoBitTimeStamp- -> KeyVersion- -> KeyGenProfile- -> [KeyFlag]- -> KeyBuilder ()-addSubkey ts keyVersion profile keyflags = do- tk <- get- (subpkp, subska) <-- liftIO $- runExceptT- ( runSomeKeyGenSpec- (subkeySpecForProfile ts keyVersion profile keyflags)- )- >>= either (failWith BadData) pure- subska <-- case secretAddendumForGeneratedKey subpkp subska of- Right add -> pure add- Left err ->- failWith- BadData- ("generate-key: invalid subkey material: " ++ err)- let pkp = keyPktPKPayload (_tkPrimaryKey tk)- ska :: SKAddendum- ska = case _tkPrimaryKey tk of- KeyPktSecretPrimary _ ska' -> ska'- _ -> error "addSubkey: expected secret primary key"- issuerPrimary <- liftIO (unhashed pkp)- issuerSub <- liftIO (unhashed subpkp)- embeddedBacksig <-- if SignDataKey `elem` keyflags- then- Just- <$> liftIO- ( signWithKey- "generate-key"- subpkp- PrimaryKeyBindingSig- SHA512- (hashed subpkp)- issuerSub- (subkeyPayloadForSigning pkp subpkp)- (Just subska)- )- else pure Nothing- bindingSig <-- liftIO $- signWithKey- "generate-key"- pkp- SubkeyBindingSig- SHA512- (hashedwithflags pkp)- ( maybe- issuerPrimary- ( \sig -> SigSubPacket False (EmbeddedSignature sig) : issuerPrimary- )- embeddedBacksig- )- (subkeyPayloadForSigning pkp subpkp)- (Just ska)- modify (addIt subpkp subska bindingSig)- where- addIt sp ss binding tk =- tk- { _tkSubs = _tkSubs tk ++ [(KeyPktSecretSubkey sp ss, [binding])]- }- hashed pkp =- [ SigSubPacket False (SigCreationTime ts)- , SigSubPacket- False- ( IssuerFingerprint- (issuerFingerprintVersionFor pkp)- (fingerprint pkp)- )- ]- hashedwithflags pkp =- hashed pkp- ++ [SigSubPacket False (KeyFlags (S.fromList keyflags))]- unhashed = issuerSubpacketsFor "generate-key"--putKeyForSigning :: SomePKPayload -> Bin.Put-putKeyForSigning pkp@(PKPayload V6 _ _ _ _) = do- putWord8 0x9B- let bs = runPut (Bin.put pkp)- putWord32be (fromIntegral (BL.length bs))- putLazyByteString bs-putKeyForSigning pkp = do- putWord8 0x99- let bs = runPut (Bin.put pkp)- putWord16be (fromIntegral (BL.length bs))- putLazyByteString bs--putUserIdForSigning :: UserId -> Bin.Put-putUserIdForSigning (UserId u) = do- let bs = TE.encodeUtf8 u- putWord8 0xB4- putWord32be (fromIntegral (B.length bs))- putByteString bs--userIdPayloadForSigning- :: SomePKPayload -> UserId -> BL.ByteString-userIdPayloadForSigning pkp uid =- runPut $ do- putKeyForSigning pkp- putUserIdForSigning uid--subkeyPayloadForSigning- :: SomePKPayload -> SomePKPayload -> BL.ByteString-subkeyPayloadForSigning primary sub =- runPut $ do- putKeyForSigning primary- putKeyForSigning sub--issuerFingerprintVersionFor- :: SomePKPayload -> IssuerFingerprintVersion-issuerFingerprintVersionFor pkp =- case _keyVersion pkp of- V6 -> IssuerFingerprintV6- _ -> IssuerFingerprintV4--ecoP :: Parser ExtractCertOptions-ecoP =- ExtractCertOptions- <$> switch (long "no-armor" <> help "don't armor the output")--data ExtractCertOptions- = ExtractCertOptions- { ecNoArmor :: Bool- }--doExtractCert :: ExtractCertOptions -> IO ()-doExtractCert ExtractCertOptions {..} = do- kbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume- let lbs = BL.fromChunks kbs- pkts <- decodeOpenPGPInput "stdin" lbs- tks <-- runConduitRes $- CL.sourceList pkts- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- when (null tks) $- failWith- MissingInput- "extract-cert: no transferable secret key found on standard input"- let output = runPut $ mapM_ (Bin.put . someTKToUnknown . pubToSecret) tks- BL.putStr $- if not ecNoArmor- then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]- else output- where- pubToSecret tk =- case tk of- SomeSecretTK _ -> SomePublicTK (someTKToPublicViewTK tk)- SomePublicTK publicTk -> SomePublicTK publicTk--doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO ()-doChangeKeyPassword ChangeKeyPasswordOptions {..} = do- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- packets <- decodeOpenPGPInput "stdin" input- tks <-- runConduitRes $- CL.sourceList packets- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- when (null tks) $- failWith- MissingInput- "change-key-password: no transferable secret key found on standard input"- when (any (not . hasSecretKeyMaterial) tks) $- failWith- MissingInput- "change-key-password: expected transferable secret key input on standard input"- oldPasswordsRaw <-- loadPasswordFiles- "change-key-password"- "--old-key-password"- changeKeyPasswordOldPasswords- let oldPasswords = concatMap passwordRetryCandidates oldPasswordsRaw- newPassword <-- parseChangeKeyPasswordNewPassword changeKeyPasswordNewPassword- changed <- mapM (changeTKPassword oldPasswords newPassword) tks- case sequence changed of- Left err ->- failWith- BadData- err- Right rewrittenTks ->- let output = runPut (mapM_ (Bin.put . someTKToUnknown) rewrittenTks)- in BL.putStr $- if changeKeyPasswordNoArmor || BL.null output- then output- else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output]--parseChangeKeyPasswordNewPassword- :: Maybe String -> IO (Maybe BL.ByteString)-parseChangeKeyPasswordNewPassword Nothing = pure Nothing-parseChangeKeyPasswordNewPassword (Just passwordFile) =- Just- <$> ( loadPasswordFromFile- "change-key-password"- "--new-key-password"- passwordFile- >>= normalizeHumanReadablePassword- "change-key-password"- "--new-key-password"- )--hasSecretKeyMaterial :: SomeTK -> Bool-hasSecretKeyMaterial tk =- case tk of- SomeSecretTK _ -> True- SomePublicTK _ -> False--doValidateUserId :: POSIXTime -> ValidateUserIdOptions -> IO ()-doValidateUserId cpt ValidateUserIdOptions {..} = do- authorityTks <-- concat- <$> mapM- (loadCertTKsFromFile "validate-userid")- validateUserIdAuthorityFiles- validateAtTime <- verificationUpperBound cpt validateUserIdAt- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- certPkts <- decodeOpenPGPInput "standard input" input- certTks <-- runConduitRes $- CL.sourceList certPkts- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- when (null certTks) $- failWith- MissingInput- "validate-userid: no certificate found on standard input"- let targetUserId = T.pack validateUserIdString- forM_ certTks $ \certTk ->- when- ( not- ( certificateHasMatchingValidatedUserId- authorityTks- validateAtTime- validateUserIdAddrSpecOnly- targetUserId- certTk- )- )- $ failWith- CertUserIdNoMatch- ( "validate-userid: certificate has no correctly bound user ID matching "- ++ validateUserIdString- )--certificateHasMatchingValidatedUserId- :: [SomeTK] -> Maybe UTCTime -> Bool -> Text -> SomeTK -> Bool-certificateHasMatchingValidatedUserId authorityTks validateAtTime addrSpecOnly targetUserId certTk =- case verifyTKWithTyped- defaultVerificationPolicy- (certTk : authorityTks)- validateAtTime- certTk of- Left _ -> False- Right verifiedTk ->- any matchingBoundUid (_tkUIDs (someTKToPublicViewTK verifiedTk))- where- matchingBoundUid (uid, sigs) =- useridMatches addrSpecOnly targetUserId uid- && any (signatureMatchesSigner certTk) sigs- && any- (\sig -> any (`signatureMatchesSigner` sig) authorityTks)- sigs--useridMatches :: Bool -> Text -> Text -> Bool-useridMatches False targetUserId uid = uid == targetUserId-useridMatches True targetUserId uid =- case conventionalAddrSpec uid of- Just addrSpec -> addrSpec == targetUserId- Nothing -> False--conventionalAddrSpec :: Text -> Maybe Text-conventionalAddrSpec uid =- let (prefix, suffix) = T.breakOnEnd (T.pack "<") uid- in if T.null prefix- then Nothing- else case T.unsnoc suffix of- Just (addrSpec, '>')- | T.any (== '<') addrSpec -> Nothing- | otherwise -> guardNonEmpty (T.strip addrSpec)- _ -> Nothing- where- guardNonEmpty text- | T.null text = Nothing- | otherwise = Just text--signatureMatchesSigner :: SomeTK -> SignaturePayload -> Bool-signatureMatchesSigner signer sig =- maybe- False- (keyMatchesFingerprint False signer)- (signatureIssuerFingerprint sig)- || maybe- False- (keyMatchesEightOctetKeyId False signer . Right)- (signatureIssuerKeyId sig)--signatureIssuerFingerprint- :: SignaturePayload -> Maybe Fingerprint-signatureIssuerFingerprint =- listToMaybe . mapMaybe getIssuerFingerprint . signatureSubpackets- where- getIssuerFingerprint (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) =- Just issuerFingerprint- getIssuerFingerprint _ = Nothing--signatureIssuerKeyId :: SignaturePayload -> Maybe EightOctetKeyId-signatureIssuerKeyId = listToMaybe . mapMaybe getIssuerKeyId . signatureSubpackets- where- getIssuerKeyId (SigSubPacket _ (Issuer issuerKeyId)) = Just issuerKeyId- getIssuerKeyId _ = Nothing--signatureSubpackets :: SignaturePayload -> [SigSubPacket]-signatureSubpackets (SigV4 _ _ _ hashed unhashed _ _) = hashed ++ unhashed-signatureSubpackets (SigV6 _ _ _ _ hashed unhashed _ _) = hashed ++ unhashed-signatureSubpackets _ = []--doCertifyUserId :: POSIXTime -> CertifyUserIdOptions -> IO ()-doCertifyUserId _cpt CertifyUserIdOptions {..} = do- signerPasswordsRaw <-- loadPasswordFiles- "certify-userid"- "--with-key-password"- certifyUserIdKeyPasswordFiles- let signerPasswords = concatMap passwordRetryCandidates signerPasswordsRaw- signerTks <-- concat- <$> mapM- ( \p ->- loadCertifySignerTKsFromFile signerPasswords "certify-userid" p- )- certifyUserIdSignerFiles- when (null signerTks) $- failWith- MissingInput- "certify-userid: no signer certificate found"- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- certPkts <- decodeOpenPGPInput "standard input" input- targetTks <-- runConduitRes $- CL.sourceList certPkts- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- when (null targetTks) $- failWith- MissingInput- "certify-userid: no certificate found on standard input"- let targetUserIds = map T.pack certifyUserIds- requireSelfSig = not certifyUserIdNoRequireSelfSig- updatedTargets <-- mapM- ( \targetTk ->- addUserIdCertifications- targetTk- targetUserIds- requireSelfSig- signerTks- )- targetTks- let output = runPut (mapM_ (Bin.put . someTKToUnknown) updatedTargets)- BL.putStr $- if certifyUserIdNoArmor- then output- else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]--loadCertifySignerTKsFromFile- :: [BL.ByteString] -> String -> String -> IO [SomeTK]-loadCertifySignerTKsFromFile signerPasswords context path = do- lbs <- loadInputFromFile context "file" path- packets <- decodeOpenPGPInput path lbs- tks <-- runConduitRes $- CL.sourceList packets- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- let fallbackTks = signingFallbackTKs packets- when (null tks && null fallbackTks) $- failWith- MissingInput- ("certify-userid: no signer key material found in " ++ path)- mapM- ( unlockTransferableSecretKeyMaterial- "certify-userid failed"- path- "--with-key-password"- signerPasswords- )- (if null tks then fallbackTks else tks)--addUserIdCertifications- :: SomeTK -> [Text] -> Bool -> [SomeTK] -> IO SomeTK-addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks = do- forM_ targetUserIds $ \targetUserId ->- case find- ((== targetUserId) . fst)- (_tkUIDs (someTKToPublicViewTK targetTk)) of- Nothing ->- failWith- CertUserIdNoMatch- ( "certify-userid: target certificate has no user ID matching "- ++ T.unpack targetUserId- )- Just (_, sigs) ->- when- ( requireSelfSig- && not (any (signatureMatchesSigner targetTk) sigs)- )- $ failWith- CertUserIdNoMatch- ( "certify-userid: target user ID has no self-signature: "- ++ T.unpack targetUserId- )- newSigs <-- concat- <$> forM- signerTks- ( \signerTk ->- forM- targetUserIds- ( \targetUserId -> do- sig <- createUIDCertification targetUserId signerTk- pure (targetUserId, sig)- )- )- let updateUID (uid, sigs) =- if uid `elem` targetUserIds- then (uid, sigs ++ map snd (filter ((== uid) . fst) newSigs))- else (uid, sigs)- pure $ case targetTk of- SomePublicTK tk -> SomePublicTK tk {_tkUIDs = map updateUID (_tkUIDs tk)}- SomeSecretTK tk -> SomeSecretTK tk {_tkUIDs = map updateUID (_tkUIDs tk)}--createUIDCertification- :: Text -> SomeTK -> IO SignaturePayload-createUIDCertification targetUserId signerTk = do- signerSka <-- case signerTk of- SomeSecretTK secretTk ->- case _tkPrimaryKey secretTk of- KeyPktSecretPrimary _ ska -> pure ska- _ ->- failWith- KeyCannotCertify- "certify-userid: signer certificate has no secret key material"- SomePublicTK _ ->- failWith- KeyCannotCertify- "certify-userid: signer certificate has no secret key material"- let signerPkp =- keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK signerTk))- signingKey <- rsaSigningKey signerSka- issuer <- issuerSubpacketsFor "certify-userid" signerPkp- let hashed = [SigSubPacket False (SigCreationTime (_timestamp signerPkp))]- certification =- signUserIDwithRSA- signerPkp- (UserId targetUserId)- hashed- issuer- signingKey- case certification of- Left err ->- failWith- BadData- ("certify-userid: failed to create certification: " ++ show err)- Right sig -> pure sig--doRevokeKey :: POSIXTime -> RevokeKeyOptions -> IO ()-doRevokeKey _cpt RevokeKeyOptions {..} = do- keyPasswordsRaw <-- loadPasswordFiles- "revoke-key"- "--with-key-password"- revokeKeyPasswordFiles- let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw- input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- keyPkts <- decodeOpenPGPInput "standard input" input- keyTks <-- runConduitRes $- CL.sourceList keyPkts- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- when (null keyTks) $- failWith- MissingInput- "revoke-key: no key found on standard input"- revocationSigPkts <-- mapM (createKeyRevocation keyPasswords) keyTks- let output = runPut (mapM_ Bin.put revocationSigPkts)- BL.putStr $- if revokeKeyNoArmor- then output- else AA.encodeLazy [Armor ArmorSignature [] output]- where- createKeyRevocation keyPasswords' keyTk = do- unlockedTk <-- unlockTransferableSecretKeyMaterial- "revoke-key failed"- "standard input"- "--with-key-password"- keyPasswords'- keyTk- (pkp, mSka) <-- case unlockedTk of- SomeSecretTK secretTk ->- pure $ case _tkPrimaryKey secretTk of- KeyPktSecretPrimary pkp ska -> (pkp, Just ska)- _ -> error "createKeyRevocation: unexpected primary key type"- SomePublicTK publicTk ->- pure $ case _tkPrimaryKey publicTk of- KeyPktPublicPrimary pkp -> (pkp, Nothing)- _ -> error "createKeyRevocation: unexpected primary key type"- ska <-- case mSka of- Just s -> pure s- Nothing ->- failWith- KeyCannotCertify- "revoke-key: key has no secret key material"- signingKey <- rsaSigningKey ska- issuer <- issuerSubpacketsFor "revoke-key" pkp- let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]- revocation = signKeyRevocationWithRSA pkp hashed issuer signingKey- case revocation of- Left err ->- failWith- BadData- ("revoke-key: failed to create revocation: " ++ show err)- Right sig -> pure (SignaturePkt sig)--hasBadPrimaryKey :: SomeTK -> Bool-hasBadPrimaryKey stk =- primaryKeyTooSmallForVerification stk- || hasHardPrimaryKeyRevocation stk--hasHardPrimaryKeyRevocation :: SomeTK -> Bool-hasHardPrimaryKeyRevocation stk =- any isHardKeyRevocation (_tkRevs (someTKToPublicViewTK stk))- where- isHardKeyRevocation sig = case sig of- SigV4 KeyRevocationSig _ _ hashedSubs _ _ _ ->- any hasHardReason hashedSubs- SigV6 KeyRevocationSig _ _ _ hashedSubs _ _ _ ->- any hasHardReason hashedSubs- _ -> False- where- hasHardReason (SigSubPacket _ (ReasonForRevocation reason _)) =- not (reason `elem` [KeySuperseded, KeyRetiredAndNoLongerUsed])- hasHardReason _ = False--doUpdateKey :: POSIXTime -> UpdateKeyOptions -> IO ()-doUpdateKey cpt UpdateKeyOptions {..} = do- keyPasswordsRaw <-- loadPasswordFiles- "update-key"- "--with-key-password"- updateKeyPasswordFiles- let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw- when updateKeyRevokeDeprecatedKeys $- hPutStrLn- stderr- "Warning: update-key: --revoke-deprecated-keys requested, but no deprecated-key detector is available; proceeding without synthetic revocations."- stdinInput <-- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- stdinPkts <- decodeOpenPGPInput "stdin" stdinInput- stdinTks <-- runConduitRes $- CL.sourceList stdinPkts- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- when (null stdinTks) $- failWith- MissingInput- "update-key: no key found on standard input"- updateSourceTks <-- concat- <$> mapM- (\p -> loadVerifyTKsFromFile "update-key" p)- updateKeyMergeCerts- when (null updateSourceTks) $- failWith MissingInput "update-key: no update keys found"- stdinUnlocked <-- mapM- (unlockUpdateKeyMaterial "standard input" keyPasswords)- stdinTks- when (any hasBadPrimaryKey stdinUnlocked) $- failWith- PrimaryKeyBad- "update-key: primary key is too weak or hard-revoked"- updateUnlocked <-- mapM- (unlockUpdateKeyMaterial "update input" keyPasswords)- updateSourceTks- let updateTks =- if updateKeySigningOnly- then filter (updateKeyHasSigningCapability cpt) updateUnlocked- else updateUnlocked- when (updateKeySigningOnly && null updateTks) $- failWith- MissingInput- "update-key: no signing-capable update keys found"- let updatedTks =- map- ( \targetTk ->- let mergedTkUnknown =- foldl'- (<>)- (someTKToUnknown targetTk)- ( map- someTKToUnknown- ( selectUpdateMergeInputs- cpt- updateKeyNoAddedCapabilities- targetTk- updateTks- )- )- in case fromUnknownToTKEither mergedTkUnknown of- Right mergedStk -> mergedStk- Left _ -> targetTk- )- stdinUnlocked- -- Choose armor type based on whether updated key has secret material- armorType =- if any hasSecretKeyMaterial updatedTks- then ArmorPrivateKeyBlock- else ArmorPublicKeyBlock- output = runPut (mapM_ (Bin.put . someTKToUnknown) updatedTks)- BL.putStr $- if updateKeyNoArmor- then output- else AA.encodeLazy [Armor armorType [] output]--doMergeCerts :: MergeCertsOptions -> IO ()-doMergeCerts MergeCertsOptions {..} = do- stdinInput <-- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- stdinPkts <- decodeOpenPGPInput "stdin" stdinInput- stdinTks <-- runConduitRes $- CL.sourceList stdinPkts- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- mergeInTks <-- concat- <$> mapM- (\p -> loadVerifyTKsFromFile "merge-certs" p)- mergeCertsFiles- let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks- output = runPut (mapM_ (Bin.put . someTKToUnknown) mergedTks)- BL.putStr $- if mergeCertsNoArmor || BL.null output- then output- else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]--mergeCertificatesForOutput- :: [SomeTK] -> [SomeTK] -> [SomeTK]-mergeCertificatesForOutput stdinTks mergeInTks =- map mergeGroup (groupByPrimaryKey stdinTks)- where- -- Upstream could expose this as a dedicated helper over TKWithWireRep- -- so downstreams can keep packet provenance while merging certs.- mergeGroup (base, rest) =- let primary = certificatePrimaryFingerprint base- mergedStdin =- case fromUnknownToTKEither- (foldl' (<>) (someTKToUnknown base) (map someTKToUnknown rest)) of- Right mergedStk -> mergedStk- Left _ -> base- matchingMergeInputs =- filter ((== primary) . certificatePrimaryFingerprint) mergeInTks- mergedAll =- case fromUnknownToTKEither- ( foldl'- (<>)- (someTKToUnknown mergedStdin)- (map someTKToUnknown matchingMergeInputs)- ) of- Right mergedStk -> mergedStk- Left _ -> mergedStdin- in mergedAll--groupByPrimaryKey :: [SomeTK] -> [(SomeTK, [SomeTK])]-groupByPrimaryKey [] = []-groupByPrimaryKey (tk : rest) =- let primary = certificatePrimaryFingerprint tk- (samePrimary, differentPrimary) =- partition ((== primary) . certificatePrimaryFingerprint) rest- in (tk, samePrimary) : groupByPrimaryKey differentPrimary--certificatePrimaryFingerprint :: SomeTK -> B.ByteString-certificatePrimaryFingerprint =- BL.toStrict- . unFingerprint- . fingerprint- . keyPktPKPayload- . _tkPrimaryKey- . someTKToPublicViewTK--unlockUpdateKeyMaterial- :: String -> [BL.ByteString] -> SomeTK -> IO SomeTK-unlockUpdateKeyMaterial _ [] tk = pure tk-unlockUpdateKeyMaterial source keyPasswords tk =- unlockTransferableSecretKeyMaterial- "update-key failed"- source- "--with-key-password"- keyPasswords- tk--updateKeyHasSigningCapability :: POSIXTime -> SomeTK -> Bool-updateKeyHasSigningCapability cpt tk =- any- ( \funKey ->- S.null (fkufs funKey) || S.member SignDataKey (fkufs funKey)- )- (tkToFunKeysAt cpt tk)--selectUpdateMergeInputs- :: POSIXTime- -> Bool- -> SomeTK- -> [SomeTK]- -> [SomeTK]-selectUpdateMergeInputs cpt noAddedCaps targetTk updateTks =- filteredByCaps- where- targetPrimary = certificatePrimaryFingerprint targetTk- mergeCandidates =- filter- ((== targetPrimary) . certificatePrimaryFingerprint)- updateTks- targetCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt targetTk))- addsCapabilities updateTk =- let updateCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt updateTk))- in not (S.null (updateCapabilities S.\\ targetCapabilities))- filteredByCaps =- if noAddedCaps- then filter (not . addsCapabilities) mergeCandidates- else mergeCandidates--soP :: Parser SignOptions-soP =- SignOptions- <$> switch (long "no-armor" <> help "don't armor the output")- <*> optional- ( strOption- ( long "micalg-out"- <> metavar "MICALG"- <> help "write MIME micalg parameter value to file"- )- )- <*> many- ( strOption- ( long "with-key-password"- <> help "password for unlocking signing key material"- )- )- <*> option- (eitherReader asTypeReader)- (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)- <*> some- ( strArgument- ( metavar "KEYS..."- <> help "paths to at least one secret key, one key per filename"- )- )- where- astypeHelp =- helpDoc . Just $- pretty "what to treat the input as"- <> softline- <> list (map (pretty . fst) asTypes)--data SignOptions- = SignOptions- { sNoArmor :: Bool- , sMicalgOut :: Maybe String- , sKeyPasswords :: [String]- , sAs :: AsBinaryText- , sKeyFiles :: [String]- }--asTypes :: [(String, AsBinaryText)]-asTypes = [("binary", AsBinary), ("text", AsText)]--data AsBinaryText- = AsBinary- | AsText- deriving (Eq)--data InlineSignMode- = InlineSignAsBinary- | InlineSignAsText- | InlineSignAsClearSigned- deriving (Eq)--data EncryptFor- = EncryptForAny- | EncryptForStorage- | EncryptForCommunications- deriving (Eq)--asTypeReader :: String -> Either String AsBinaryText-asTypeReader = note "unknown as type" . flip lookup asTypes--encryptForReader :: String -> Either String EncryptFor-encryptForReader "any" = Right EncryptForAny-encryptForReader "storage" = Right EncryptForStorage-encryptForReader "communications" = Right EncryptForCommunications-encryptForReader _ =- Left- "encryption purpose must be one of: any, storage, communications"--doSign :: POSIXTime -> SignOptions -> IO ()-doSign pt SignOptions {..} = do- forM_ sMicalgOut (ensureOutputPathAvailable "sign")- mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume- when (sAs == AsText) $- ensureUTF8TextInput "sign" (BL.fromChunks mbs)- forM_- sMicalgOut- (\_ -> ensureCanonicalMIMETextInput (BL.fromChunks mbs))- signingPasswordsRaw <-- loadPasswordFiles "sign" "--with-key-password" sKeyPasswords- let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw- ks <- loadSigningKeys "sign" sKeyFiles signingPasswords- let ts = ThirtyTwoBitTimeStamp (floor pt)- payload' = BL.fromChunks mbs- payload = payload'- processedKeys <- mapM (normalizeSigningKey pt) ks- let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys- signingHash =- selectSigningHash- (concat perTransferKeySigners)- []- legacySigningHashFallbackOrder- when (any null perTransferKeySigners) $- failWith- KeyCannotSign- "sign: supplied key cannot produce detached signatures"- signatures <-- mapM- (signData sAs ts signingHash payload)- (concat perTransferKeySigners)- let output = runPut (mapM_ (Bin.put . SignaturePkt) signatures)- case sMicalgOut of- Just outPath ->- writeFileWithOutputExistsCheck- "sign"- outPath- (renderMicalg signatures)- Nothing -> pure ()- BL.putStr $- if not sNoArmor- then AA.encodeLazy [Armor ArmorSignature [] output]- else output- where- signData- :: AsBinaryText- -> ThirtyTwoBitTimeStamp- -> HashAlgorithm- -> BL.ByteString- -> FunKey- -> IO SignaturePayload- signData mode t signHash d k = do- let st = case mode of- AsBinary -> BinarySig- AsText -> CanonicalTextSig- payload = d- issuerPackets <- unhashed (fpkp k)- signWithKey- "sign"- (fpkp k)- st- signHash- (hashed (fpkp k) t)- issuerPackets- payload- (fmska k)- hashed pkp ct =- [ SigSubPacket False (SigCreationTime ct)- , SigSubPacket- False- ( IssuerFingerprint- (issuerFingerprintVersionFor pkp)- (fingerprint pkp)- )- ]- unhashed pkp = issuerSubpacketsFor "sign" pkp-loadSigningKeys- :: String -> [String] -> [BL.ByteString] -> IO [SomeTK]-loadSigningKeys context keyFiles keyPasswords = concat <$> mapM loadSigningKeyFile keyFiles- where- loadSigningKeyFile path = do- packets <- loadOpenPGPPackets context path- tks <-- runConduitRes $- CL.sourceList packets- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- let fallbackTks = signingFallbackTKs packets- when (null tks && null fallbackTks) $- failWith- MissingInput- ("sign: no secret key material found in " ++ path)- mapM- (decryptSigningKeyMaterial path keyPasswords)- (if null tks then fallbackTks else tks)--decryptSigningKeyMaterial- :: FilePath -> [BL.ByteString] -> SomeTK -> IO SomeTK-decryptSigningKeyMaterial path keyPasswords =- unlockTransferableSecretKeyMaterial- "sign failed"- path- "--with-key-password"- keyPasswords--unlockTransferableSecretKeyMaterial- :: String- -> FilePath- -> String- -> [BL.ByteString]- -> SomeTK- -> IO SomeTK-unlockTransferableSecretKeyMaterial context path passwordOption keyPasswords stk =- case stk of- SomePublicTK _ -> pure stk- SomeSecretTK tk -> do- tk' <-- modifyTKSecretKeysM- tk- (unlockSecretAddendum context path passwordOption keyPasswords)- pure $ SomeSecretTK tk'--unlockSecretAddendum- :: MonadIO m- => String- -> FilePath- -> String- -> [BL.ByteString]- -> SomePKPayload- -> SKAddendum- -> m SKAddendum-unlockSecretAddendum _ _ _ _ _ sk@(SUUnencrypted _ _) = pure sk-unlockSecretAddendum context path passwordOption [] _ _ =- failWith- KeyIsProtected- ( context- ++ ": encrypted key material in "- ++ path- ++ " requires "- ++ passwordOption- )-unlockSecretAddendum context path passwordOption keyPasswords pkp sk =- case tryDecrypt keyPasswords of- Right decrypted -> pure decrypted- Left _ ->- failWith- KeyIsProtected- ( context- ++ ": could not unlock key material in "- ++ path- ++ " with provided "- ++ passwordOption- ++ " values"- )- where- tryDecrypt [] = Left ()- tryDecrypt (password : rest) =- case decryptPrivateKey (pkp, sk) password of- Left _ -> tryDecrypt rest- Right decrypted -> Right decrypted--normalizeSigningKey :: POSIXTime -> SomeTK -> IO SomeTK-normalizeSigningKey pt tk =- case processTK (Just pt) tk of- Left err ->- failWith- BadData- ("sign: invalid signing key material: " ++ show err)- Right normalized -> pure normalized--signPayloadWithKeys- :: POSIXTime- -> AsBinaryText- -> BL.ByteString- -> [SomeTK]- -> [HashAlgorithm]- -> [HashAlgorithm]- -> IO [SignaturePayload]-signPayloadWithKeys pt asMode payload keys recipientHashPrefs fallbackOrder = do- processedKeys <- mapM (normalizeSigningKey pt) keys- let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys- signingHash =- selectSigningHash- (concat perTransferKeySigners)- recipientHashPrefs- fallbackOrder- when (any null perTransferKeySigners) $- failWith- KeyCannotSign- "encrypt: supplied key cannot produce signatures"- mapM- (signData asMode ts signingHash payload)- (concat perTransferKeySigners)- where- ts = ThirtyTwoBitTimeStamp (floor pt)- signData- :: AsBinaryText- -> ThirtyTwoBitTimeStamp- -> HashAlgorithm- -> BL.ByteString- -> FunKey- -> IO SignaturePayload- signData mode t signHash d' k = do- let st = case mode of- AsBinary -> BinarySig- AsText -> CanonicalTextSig- payload' = d'- issuerPackets <- unhashed (fpkp k)- signWithKey- "encrypt"- (fpkp k)- st- signHash- (hashed (fpkp k) t)- issuerPackets- payload'- (fmska k)- hashed pkp ct =- [ SigSubPacket False (SigCreationTime ct)- , SigSubPacket- False- ( IssuerFingerprint- (issuerFingerprintVersionFor pkp)- (fingerprint pkp)- )- ]- unhashed pkp = issuerSubpacketsFor "encrypt" pkp--signingCapableFunKeys :: POSIXTime -> SomeTK -> [FunKey]-signingCapableFunKeys pt =- filter canSign . tkToFunKeysAt pt- where- canSign k =- canSignDataUsage (fkufs k)- && case fmska k of- Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True- Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True- Just (SUUnencrypted (Ed25519PrivateKey _) _) -> True- Just (SUUnencrypted (Ed448PrivateKey _) _) -> True- Just (SUUnencrypted (UnknownSKey _) _) ->- isEd25519PKA (_pkalgo (fpkp k))- || isEdDSAPKA (_pkalgo (fpkp k))- || isEd448PKA (_pkalgo (fpkp k))- _ -> False- canSignDataUsage keyFlags = S.null keyFlags || S.member SignDataKey keyFlags---- Legacy alias kept for internal call sites that have not been updated.-signingCapableRSAFunKeys :: POSIXTime -> SomeTK -> [FunKey]-signingCapableRSAFunKeys = signingCapableFunKeys--{- | Algorithm-dispatching signature helper used by all sign paths.-Supports RSA (v4), Ed25519 (v4), and Ed448 (v4).--}-signWithKey- :: String- -- ^ context for error messages- -> SomePKPayload- -> SigType- -> HashAlgorithm- -> [SigSubPacket]- -- ^ hashed subpackets- -> [SigSubPacket]- -- ^ unhashed subpackets- -> BL.ByteString- -- ^ payload to sign- -> Maybe SKAddendum- -> IO SignaturePayload-signWithKey ctx signerPKP st signHash hsd usd payload mska =- case mska of- Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) ->- validateRSASigningKeySize ctx signerPKP- >> if _keyVersion signerPKP == V6- then signRSAWithV6Salt (k {RSA.private_p = 0, RSA.private_q = 0})- else- signWithRSABuilder- signHash- (k {RSA.private_p = 0, RSA.private_q = 0})- Just- (SUUnencrypted (EdDSAPrivateKey EdSigningCurve25519 rawBytes) _) ->- signWithEd25519SecretKey- ctx- signerPKP- st- hsd- usd- payload- rawBytes- Just- (SUUnencrypted (Ed25519PrivateKey rawBytes) _) ->- signWithEd25519SecretKey- ctx- signerPKP- st- hsd- usd- payload- rawBytes- Just- (SUUnencrypted (EdDSAPrivateKey EdSigningCurve448 rawBytes) _) ->- signWithEd448SecretKey ctx signerPKP st hsd usd payload rawBytes- Just- (SUUnencrypted (Ed448PrivateKey rawBytes) _) ->- signWithEd448SecretKey ctx signerPKP st hsd usd payload rawBytes- 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-- signWithEd25519SecretKey ctx signerPKP st hsd usd payload 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- signWithEd448SecretKey ctx signerPKP st hsd usd payload 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--normalizeUnknownSecretForEdDSA- :: String -> Int -> BL.ByteString -> IO B.ByteString-normalizeUnknownSecretForEdDSA ctx expectedLen rawLbs- | B.length raw == expectedLen = pure raw- | B.length raw >= 2 =- let bits =- (fromIntegral (B.index raw 0) `shiftL` 8)- .|. fromIntegral (B.index raw 1)- mpiBytes = (bits + 7) `div` 8- payload = B.drop 2 raw- in if B.length payload == mpiBytes && mpiBytes <= expectedLen- then pure (i2ospOf_ expectedLen (os2ip payload))- else bad- | otherwise = bad- where- raw = BL.toStrict rawLbs- bad =- failWith- BadData- ( ctx- ++ " failed: unsupported EdDSA secret key encoding (length="- ++ show (B.length raw)- ++ ")"- )--validateRSASigningKeySize :: String -> SomePKPayload -> IO ()-validateRSASigningKeySize ctx signerPKP =- case pubkeySize (_pubkey signerPKP) of- Right bits- | bits < 2048 ->- failWith- KeyCannotSign- ( ctx- ++ " failed: RSA signing keys smaller than 2048 bits are not supported"- )- | otherwise -> pure ()- Left err ->- failWith- BadData- (ctx ++ " failed: unable to determine RSA key size: " ++ err)---- FIXME: clean this up-isEd25519PKA, isEd448PKA, isEdDSAPKA :: PubKeyAlgorithm -> Bool-isEd25519PKA pka = fromFVal pka == 27-isEdDSAPKA pka = fromFVal pka == 22-isEd448PKA pka = fromFVal pka == 28--selectSigningHash- :: [FunKey] -> [HashAlgorithm] -> [HashAlgorithm] -> HashAlgorithm-selectSigningHash signerKeys recipientHashPrefs fallbackOrder =- fromMaybe- SHA512- (find (hashSupportedByAllSigners signerKeys) candidateOrder)- where- requestedPrefs =- if null recipientHashPrefs- then signerPrefs- else recipientHashPrefs- signerPrefs = concatMap fpreferredHashes signerKeys- filteredRequested = filter (hashSupportedByAllSigners signerKeys) requestedPrefs- filteredSignerPrefs = filter (hashSupportedByAllSigners signerKeys) signerPrefs- candidateOrder = filteredRequested ++ filteredSignerPrefs ++ fallbackOrder--legacySigningHashFallbackOrder :: [HashAlgorithm]-legacySigningHashFallbackOrder = [SHA512, SHA384, SHA256, SHA224]--rfc9580SigningHashFallbackOrder :: [HashAlgorithm]-rfc9580SigningHashFallbackOrder = [SHA3_512, SHA3_256, SHA512, SHA384, SHA256, SHA224]--hashSupportedByAllSigners :: [FunKey] -> HashAlgorithm -> Bool-hashSupportedByAllSigners signers ha =- not (isDeprecatedHashAlgorithm ha)- && all (`signerSupportsHashAlgorithm` ha) signers--signerSupportsHashAlgorithm :: FunKey -> HashAlgorithm -> Bool-signerSupportsHashAlgorithm signer ha =- not (isDeprecatedHashAlgorithm ha)- && case _pkalgo (fpkp signer) of- RSA -> rsaPKCS15SupportedHash ha- DeprecatedRSASignOnly -> rsaPKCS15SupportedHash ha- DeprecatedRSAEncryptOnly -> rsaPKCS15SupportedHash ha- _ -> not (isOtherHashAlgorithm ha)--rsaPKCS15SupportedHash :: HashAlgorithm -> Bool-rsaPKCS15SupportedHash SHA224 = True-rsaPKCS15SupportedHash SHA256 = True-rsaPKCS15SupportedHash SHA384 = True-rsaPKCS15SupportedHash SHA512 = True-rsaPKCS15SupportedHash _ = False--isDeprecatedHashAlgorithm :: HashAlgorithm -> Bool-isDeprecatedHashAlgorithm DeprecatedMD5 = True-isDeprecatedHashAlgorithm SHA1 = True-isDeprecatedHashAlgorithm RIPEMD160 = True-isDeprecatedHashAlgorithm _ = False--isOtherHashAlgorithm :: HashAlgorithm -> Bool-isOtherHashAlgorithm (OtherHA _) = True-isOtherHashAlgorithm _ = False--hashAlgorithmHeaderName :: HashAlgorithm -> String-hashAlgorithmHeaderName DeprecatedMD5 = "MD5"-hashAlgorithmHeaderName SHA1 = "SHA1"-hashAlgorithmHeaderName RIPEMD160 = "RIPEMD160"-hashAlgorithmHeaderName SHA224 = "SHA224"-hashAlgorithmHeaderName SHA256 = "SHA256"-hashAlgorithmHeaderName SHA384 = "SHA384"-hashAlgorithmHeaderName SHA512 = "SHA512"-hashAlgorithmHeaderName SHA3_256 = "SHA3-256"-hashAlgorithmHeaderName SHA3_512 = "SHA3-512"-hashAlgorithmHeaderName (OtherHA _) = "SHA512"--ensureCanonicalMIMETextInput :: BL.ByteString -> IO ()-ensureCanonicalMIMETextInput lbs = do- let bs = BL.toStrict lbs- when (B.any (> 0x7f) bs) $- failWith- ExpectedText- "sign: --micalg-out requires canonical 7-bit text data on standard input"- case TE.decodeUtf8' bs of- Left _ ->- failWith- ExpectedText- "sign: --micalg-out requires UTF-8 text data on standard input"- Right _ -> pure ()- when (not (canonicalCRLFLineEndings bs)) $- failWith- ExpectedText- "sign: --micalg-out requires CRLF line endings on standard input"- when (hasTrailingLineWhitespace bs) $- failWith- ExpectedText- "sign: --micalg-out requires no trailing line whitespace on standard input"- where- canonicalCRLFLineEndings bytes = go (B.unpack bytes)- where- go [] = True- go [13] = False- go (13 : 10 : rest) = go rest- go (13 : _) = False- go (10 : _) = False- go (_ : rest) = go rest- hasTrailingLineWhitespace bytes =- endsWithWhitespace bytes- || trailingWhitespaceBeforeCRLF (B.unpack bytes)- endsWithWhitespace bytes =- case B.unsnoc bytes of- Just (_, c) -> c == 32 || c == 9- Nothing -> False- trailingWhitespaceBeforeCRLF (a : 13 : 10 : rest)- | a == 32 || a == 9 = True- | otherwise = trailingWhitespaceBeforeCRLF (13 : 10 : rest)- trailingWhitespaceBeforeCRLF (_ : rest) = trailingWhitespaceBeforeCRLF rest- trailingWhitespaceBeforeCRLF _ = False--ensureUTF8TextInput :: String -> BL.ByteString -> IO ()-ensureUTF8TextInput subcommand lbs =- case TE.decodeUtf8' (BL.toStrict lbs) of- Left _ ->- failWith- ExpectedText- (subcommand ++ ": --as=text requires UTF-8 text on standard input")- Right _ -> pure ()--renderMicalg :: [SignaturePayload] -> String-renderMicalg signatures =- case nub (mapMaybe signatureMicalg signatures) of- [micalg] -> micalg- _ -> ""- where- signatureMicalg (SigV4 _ _ ha _ _ _ _) = hashAlgorithmMicalg ha- signatureMicalg _ = Nothing- hashAlgorithmMicalg DeprecatedMD5 = Just "pgp-md5"- hashAlgorithmMicalg SHA1 = Just "pgp-sha1"- hashAlgorithmMicalg RIPEMD160 = Just "pgp-ripemd160"- hashAlgorithmMicalg SHA224 = Just "pgp-sha224"- hashAlgorithmMicalg SHA256 = Just "pgp-sha256"- hashAlgorithmMicalg SHA384 = Just "pgp-sha384"- hashAlgorithmMicalg SHA512 = Just "pgp-sha512"- hashAlgorithmMicalg SHA3_256 = Just "pgp-sha3-256"- hashAlgorithmMicalg SHA3_512 = Just "pgp-sha3-512"- hashAlgorithmMicalg (OtherHA _) = Nothing--signingFallbackTKs :: [Pkt] -> [SomeTK]-signingFallbackTKs packets =- [ SomeSecretTK- TK- { _tkPrimaryKey = KeyPktSecretPrimary pkp ska- , _tkRevs = []- , _tkDirectKeySigs = []- , _tkUIDs = []- , _tkUAts = []- , _tkSubs = []- }- | SecretKeyPkt pkp ska <- packets- ]--data FunKey- = FunKey- { fpkp :: SomePKPayload- , fmska :: Maybe SKAddendum- , fkufs :: S.Set KeyFlag- , fpreferredHashes :: [HashAlgorithm]- , fpreferredSymmetricAlgorithms :: [SymmetricAlgorithm]- , fsupportsSEIPDv2 :: Bool- }- deriving (Show)--tkToFunKeysAt :: POSIXTime -> SomeTK -> [FunKey]-tkToFunKeysAt pt stk =- catMaybes- ( mainKey : case stk of- SomePublicTK _ -> map extractPublic (_tkSubs publicView)- SomeSecretTK secretTk -> map extractSecret (_tkSubs secretTk)- )- where- publicView = someTKToPublicViewTK stk- pkp = keyPktPKPayload (_tkPrimaryKey publicView)- mska = case stk of- SomeSecretTK secretTk -> case _tkPrimaryKey secretTk of- KeyPktSecretPrimary _ ska -> Just ska- _ -> Nothing- SomePublicTK _ -> Nothing- uids = _tkUIDs publicView- mainPreferredHashes = effectiveHashPreferencesAt pt stk- mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt stk- mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt stk- mainKey =- Just- ( FunKey- pkp- mska- (fromMaybe S.empty (grabASig uids >>= sig2KUFs))- mainPreferredHashes- mainPreferredSymmetricAlgorithms- mainSupportsSEIPDv2- )- sig2KUFs = getHasheds >=> find isKUF >=> getKUFs- grabASig :: [(a, [b])] -> Maybe b- grabASig = (listToMaybe >=> listToMaybe) . map snd -- FIXME: this should grab the "best" sig- getHasheds :: SignaturePayload -> Maybe [SigSubPacket]- getHasheds (SigV4 _ _ _ hasheds _ _ _) = Just hasheds- getHasheds (SigV6 _ _ _ _ hasheds _ _ _) = Just hasheds- getHasheds _ = Nothing- getKUFs :: SigSubPacket -> Maybe (S.Set KeyFlag)- getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs- getKUFs _ = Nothing- extractPublic :: (KeyPkt k, [SignaturePayload]) -> Maybe FunKey- extractPublic (KeyPktPublicSubkey spkp, sigs) =- return- ( FunKey- spkp- Nothing- (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))- mainPreferredHashes- mainPreferredSymmetricAlgorithms- mainSupportsSEIPDv2- )- extractPublic _ = Nothing- extractSecret :: (KeyPkt k, [SignaturePayload]) -> Maybe FunKey- extractSecret (KeyPktSecretSubkey spkp sska, sigs) =- return- ( FunKey- spkp- (Just sska)- (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))- mainPreferredHashes- mainPreferredSymmetricAlgorithms- mainSupportsSEIPDv2- )- extractSecret _ = Nothing--effectiveHashPreferencesAt- :: POSIXTime -> SomeTK -> [HashAlgorithm]-effectiveHashPreferencesAt pt tk =- concatMap toHashes $- fromMaybe- []- ( effectiveKeyPreferencesAt- (posixSecondsToUTCTime (realToFrac pt))- (someTKToPublicViewTK tk)- )- where- toHashes (PreferredHashAlgorithms hashes) = hashes- toHashes _ = []--effectiveSymmetricPreferencesAt- :: POSIXTime -> SomeTK -> [SymmetricAlgorithm]-effectiveSymmetricPreferencesAt pt tk =- concatMap toSymmetricAlgorithms $- fromMaybe- []- ( effectiveKeyPreferencesAt- (posixSecondsToUTCTime (realToFrac pt))- (someTKToPublicViewTK tk)- )- where- toSymmetricAlgorithms (PreferredSymmetricAlgorithms algorithms) = algorithms- toSymmetricAlgorithms _ = []--effectiveSEIPDv2SupportAt :: POSIXTime -> SomeTK -> Bool-effectiveSEIPDv2SupportAt pt tk =- any supportsSEIPDv2Flag $- concatMap toFeatureFlags $- fromMaybe- []- ( effectiveKeyPreferencesAt- (posixSecondsToUTCTime (realToFrac pt))- (someTKToPublicViewTK tk)- )- where- toFeatureFlags (Features flags) = S.toList flags- toFeatureFlags _ = []- supportsSEIPDv2Flag FeatureSEIPDv2 = True- supportsSEIPDv2Flag _ = False---- SOP Handler Stubs--- These implement the stateless OpenPGP CLI commands per draft-16--doVerify :: POSIXTime -> VerifyOptions -> IO ()-doVerify cpt VerifyOptions {..} = do- (krs, verifyTks) <- loadVerifyContext cpt verifyCertFiles- signatureInput <-- runConduitRes $ CC.sourceFile verifySigFile .| CC.sinkLazy- sigPkts <- decodeLikeSignaturePackets signatureInput- let sigs = V.fromList (filter isDetachedVerificationSignaturePkt sigPkts)- blob <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- upperBound <- verificationUpperBound cpt verifyNotAfter- lowerBound <- verificationLowerBound cpt verifyNotBefore- let sigsWithoutUnsupportedCritical =- V.filter- (not . detachedSignatureHasUnsupportedCriticalSubpackets)- sigs- binaryVerifications <-- verifyWithLiteralData- BinaryData- blob- sigsWithoutUnsupportedCritical- krs- upperBound- verifications <-- if any isRight binaryVerifications- then pure binaryVerifications- else- verifyWithLiteralData- TextData- blob- sigsWithoutUnsupportedCritical- krs- upperBound- let decodedVerifications = map (first show) verifications- signerPolicyAdjusted =- map- (enforceVerificationSignerPolicy cpt verifyTks)- decodedVerifications- let filtered =- filterByVerificationBounds- lowerBound- upperBound- signerPolicyAdjusted- policyFiltered =- filter (not . verificationResultUsesDeprecatedHash) filtered- mapM_- (putStrLn . renderSOPVerificationLine verifyTks)- (rights policyFiltered)- case any isRight policyFiltered of- True -> exitSuccess- _ -> failWith NoSignature "No acceptable signatures found"- where- decodeLikeSignaturePackets lbs = do- decodedArmors <-- decodeAsciiArmorInput- ("signature input in " ++ verifySigFile)- lbs- case decodedArmors of- Just armors ->- case firstBy isDetachedSignatureArmor armors of- Just (Armor ArmorSignature _ bs) ->- parseOpenPGPPackets- ("signature input in " ++ verifySigFile)- (BL.fromStrict (BLC8.toStrict bs))- _ ->- case firstBy isDetachedSignatureUnsupportedArmor armors of- Just (ClearSigned _ _ _) ->- failWith- BadData- ("verify: expected detached signatures in " ++ verifySigFile)- Just (Armor _ _ _) ->- failWith- BadData- ("verify: expected signature armor in " ++ verifySigFile)- _ ->- parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs- Nothing ->- parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs- verifyWithLiteralData format payload sigs keyring upperBound =- runConduitRes $- CC.yieldMany- (V.cons (LiteralDataPkt format (FileName mempty) 0 payload) sigs)- .| conduitVerify keyring upperBound- .| CC.sinkList--detachedSignatureHasUnsupportedCriticalSubpackets :: Pkt -> Bool-detachedSignatureHasUnsupportedCriticalSubpackets (SignaturePkt sig) =- any criticalUnsupported (signatureHashedSubpackets sig)- where- criticalUnsupported (SigSubPacket True (OtherSigSub _ _)) = True- criticalUnsupported (SigSubPacket True (UserDefinedSigSub _ _)) = True- criticalUnsupported (SigSubPacket True (NotationData _ _ _)) = True- criticalUnsupported _ = False-detachedSignatureHasUnsupportedCriticalSubpackets _ = False--signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]-signatureHashedSubpackets (SigV4 _ _ _ hashed _ _ _) = hashed-signatureHashedSubpackets (SigV6 _ _ _ _ hashed _ _ _) = hashed-signatureHashedSubpackets _ = []--verificationResultUsesDeprecatedHash- :: Either String Verification -> Bool-verificationResultUsesDeprecatedHash (Right verification) =- verificationUsesDeprecatedHash verification-verificationResultUsesDeprecatedHash _ = False--verificationUsesDeprecatedHash :: Verification -> Bool-verificationUsesDeprecatedHash (Verification _ sigPayload _) =- isDeprecatedHashAlgorithm (signatureHashAlgorithm sigPayload)--signatureHashAlgorithm :: SignaturePayload -> HashAlgorithm-signatureHashAlgorithm (SigV3 _ _ _ _ ha _ _) = ha-signatureHashAlgorithm (SigV4 _ _ ha _ _ _ _) = ha-signatureHashAlgorithm (SigV6 _ _ ha _ _ _ _ _) = ha-signatureHashAlgorithm (SigVOther _ _) = OtherHA 0--enforceVerificationSignerPolicy- :: POSIXTime- -> [SomeTK]- -> Either String Verification- -> Either String Verification-enforceVerificationSignerPolicy _ _ result@(Left _) = result-enforceVerificationSignerPolicy cpt verifyTks result@(Right verification)- | signerAllowed = result- | otherwise =- Left- "verification failed: signer key is not valid for signing at signature creation time"- where- signerAllowed = any signerMatchesProcessed verifyTks- signerFp = fingerprint (_verificationSigner verification)- verificationTimePosix =- maybe- cpt- (realToFrac . utcTimeToPOSIXSeconds)- (signatureCreationTime (_verificationSignature verification))- verificationTime = posixSecondsToUTCTime verificationTimePosix- signerMatchesProcessed tk- | not (keyMatchesFingerprint True tk signerFp) = False- | keyMatchesFingerprint False tk signerFp = True- | otherwise =- any- (subkeyAllowsSigning verificationTime signerFp)- ( map- (\(kp, sigs) -> (keyPktToPkt kp, sigs))- (_tkSubs (someTKToPublicViewTK tk))- )--subkeyAllowsSigning- :: UTCTime -> Fingerprint -> (Pkt, [SignaturePayload]) -> Bool-subkeyAllowsSigning t signerFp (pkt, sigs) =- case subkeyPayload pkt of- Just pkp- | fingerprint pkp == signerFp ->- any- (bindingSignatureAllowsSigning t)- (filter isSKBindingSig sigs)- _ -> False- where- subkeyPayload (PublicSubkeyPkt pkp) = Just pkp- subkeyPayload (SecretSubkeyPkt pkp _) = Just pkp- subkeyPayload _ = Nothing--bindingSignatureAllowsSigning- :: UTCTime -> SignaturePayload -> Bool-bindingSignatureAllowsSigning t sig =- allowsSigning && hasValidBacksig- where- allowsSigning =- let flagSets = signatureKeyFlagSets sig- in null flagSets || any (S.member SignDataKey) flagSets- hasValidBacksig =- any- ( \embedded ->- isPKBindingSig embedded- && not (signatureExpiredAt t embedded)- )- (signatureEmbeddedSignatures sig)--signatureEmbeddedSignatures- :: SignaturePayload -> [SignaturePayload]-signatureEmbeddedSignatures sig =- [ embedded- | SigSubPacket _ (EmbeddedSignature embedded) <-- signatureSubpackets sig- ]--signatureKeyFlagSets :: SignaturePayload -> [S.Set KeyFlag]-signatureKeyFlagSets sig =- [ flags- | SigSubPacket _ (KeyFlags flags) <- signatureSubpackets sig- ]--signatureExpiredAt :: UTCTime -> SignaturePayload -> Bool-signatureExpiredAt t sig =- case (signatureCreationTime sig, signatureValiditySeconds sig) of- (Just created, Just validitySeconds) ->- utcTimeToPOSIXSeconds t- >= utcTimeToPOSIXSeconds created + fromIntegral validitySeconds- _ -> False--signatureValiditySeconds :: SignaturePayload -> Maybe Integer-signatureValiditySeconds sig =- listToMaybe- [ fromIntegral secs- | SigSubPacket _ (SigExpirationTime (ThirtyTwoBitDuration secs)) <-- signatureSubpackets sig- ]-verificationUpperBound- :: POSIXTime -> Maybe String -> IO (Maybe UTCTime)-verificationUpperBound cpt Nothing = return (Just (posixSecondsToUTCTime cpt))-verificationUpperBound _ (Just "-") = return Nothing-verificationUpperBound cpt (Just "now") =- return (Just (posixSecondsToUTCTime cpt))-verificationUpperBound _ (Just s) = do- let m = iso8601ParseM s :: Maybe UTCTime- case m of- Just t -> return (Just t)- Nothing -> failWith BadData ("Invalid DATE value: " ++ s)--verificationLowerBound- :: POSIXTime -> Maybe String -> IO (Maybe UTCTime)-verificationLowerBound _ Nothing = return Nothing-verificationLowerBound _ (Just "-") = return Nothing-verificationLowerBound cpt (Just "now") =- return (Just (posixSecondsToUTCTime cpt))-verificationLowerBound _ (Just s) = do- let m = iso8601ParseM s :: Maybe UTCTime- case m of- Just t -> return (Just t)- Nothing -> failWith BadData ("Invalid DATE value: " ++ s)--filterByVerificationBounds- :: Maybe UTCTime- -> Maybe UTCTime- -> [Either String Verification]- -> [Either String Verification]-filterByVerificationBounds lower upper = map (>>= ensureBounds)- where- ensureBounds v =- case signatureCreationTime (_verificationSignature v) of- Nothing ->- Left "verification failed: signature is missing creation time"- Just sigTime- | Just upperBound <- upper- , sigTime > upperBound ->- Left- "verification failed: signature created after --not-after bound"- | Just lowerBound <- lower- , sigTime < lowerBound ->- Left- "verification failed: signature created before --not-before bound"- | otherwise -> Right v--signatureCreationTime :: SignaturePayload -> Maybe UTCTime-signatureCreationTime (SigV4 _ _ _ hashed _ _ _) =- firstCreationTime hashed-signatureCreationTime (SigV6 _ _ _ _ hashed _ _ _) =- firstCreationTime hashed-signatureCreationTime _ = Nothing--firstCreationTime :: [SigSubPacket] -> Maybe UTCTime-firstCreationTime = listToMaybe . mapMaybe getCreation- where- getCreation (SigSubPacket _ (SigCreationTime (ThirtyTwoBitTimeStamp ts))) =- Just (posixSecondsToUTCTime (fromIntegral ts))- getCreation _ = Nothing--isDetachedVerificationSignaturePkt :: Pkt -> Bool-isDetachedVerificationSignaturePkt (SignaturePkt (SigV4 sigType _ _ _ _ _ _)) =- sigType == BinarySig || sigType == CanonicalTextSig-isDetachedVerificationSignaturePkt (SignaturePkt (SigV6 sigType _ _ _ _ _ _ _)) =- sigType == BinarySig || sigType == CanonicalTextSig-isDetachedVerificationSignaturePkt _ = False--doInlineVerify :: POSIXTime -> InlineVerifyOptions -> IO ()-doInlineVerify cpt InlineVerifyOptions {..} = do- (krs, verifyTks) <- loadVerifyContext cpt inlineCertFiles- signedInput <-- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- upperBound <- verificationUpperBound cpt inlineNotAfter- lowerBound <- verificationLowerBound cpt inlineNotBefore- (allowTrailingSignatures, parsedPackets) <-- inlineVerifyPackets signedInput- packets <-- normalizeInlineVerifyPackets- allowTrailingSignatures- parsedPackets- let verifications =- map (first show) (verifyPacketsBatch krs upperBound packets)- filtered = filterByVerificationBounds lowerBound upperBound verifications- successLines = map (renderSOPVerificationLine verifyTks) (rights filtered)- renderedOut =- if null successLines- then ""- else unlines successLines- case verificationsOut of- Just outPath ->- writeFileWithOutputExistsCheck- "inline-verify"- outPath- renderedOut- Nothing -> pure ()- case any isRight filtered of- True ->- extractSingleLiteralPayload packets >>= BL.putStr >> exitSuccess- _ -> failWith NoSignature "No acceptable signatures found"- where- inlineVerifyPackets :: BL.ByteString -> IO (Bool, [Pkt])- inlineVerifyPackets lbs = do- decodedArmors <- decodeAsciiArmorInput "inline-verify input" lbs- case decodedArmors- >>= listToMaybe . filter isInlineVerifyCandidateArmor 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- (FileName B.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)-- parseInlineVerifyMessagePackets- :: String -> BL.ByteString -> IO [Pkt]- parseInlineVerifyMessagePackets context packetBytes = do- rawPkts <- parseRawOpenPGPPackets context packetBytes- when (any compressedPacketParseFailed rawPkts) $- failWith- BadData- "inline-verify input has malformed compressed packet data"- when (any compressedPacketIsEmpty rawPkts) $- failWith- BadData- "inline-verify input has empty compressed packet data"- expanded <- expandPacketsStrict context rawPkts- when- (any isMarkerPacket expanded && any isCompressedPacket rawPkts)- $ failWith- BadData- "inline-verify input has malformed compressed packet sequence"- pure expanded-- expandPacketsStrict :: String -> [Pkt] -> IO [Pkt]- expandPacketsStrict context =- fmap concat . mapM expandPacket- where- expandPacket pkt =- case decompressPkt pkt of- Left err ->- failWith- BadData- ( context- ++ ": failed to parse compressed packet: "- ++ renderCompressionError err- )- Right packets -> pure packets--isInlineVerifyCandidateArmor :: Armor -> Bool-isInlineVerifyCandidateArmor (Armor ArmorMessage _ _) = True-isInlineVerifyCandidateArmor ClearSigned {} = True-isInlineVerifyCandidateArmor _ = False--clearSignedSignaturePackets :: Armor -> IO [Pkt]-clearSignedSignaturePackets (Armor ArmorSignature _ sigbs) =- let sigPktsSource =- parseOpenPGPPackets- "cleartext signature block"- (BL.fromStrict (BLC8.toStrict sigbs))- in do- parsed <- sigPktsSource- let sigPkts = filter isSignaturePkt parsed- if null sigPkts- then- failWith- BadData- "cleartext signature block has no signature packets"- else return sigPkts-clearSignedSignaturePackets (Armor _ _ _) =- failWith- BadData- "cleartext signed message does not contain an armored signature block"-clearSignedSignaturePackets (ClearSigned _ _ inner) =- clearSignedSignaturePackets inner--isSignaturePkt :: Pkt -> Bool-isSignaturePkt SignaturePkt {} = True-isSignaturePkt _ = False--normalizeInlineVerifyPackets :: Bool -> [Pkt] -> IO [Pkt]-normalizeInlineVerifyPackets allowTrailingSignatures pkts- | any isBrokenPacket relevantPkts =- failWith- BadData- "inline-verify input contains malformed packet encoding"- | any (not . isInlineVerificationPacket) filteredPkts =- failWith- BadData- "inline-verify input contains unsupported packet types"- | otherwise =- case ( [pkt | pkt@LiteralDataPkt {} <- filteredPkts]- , [pkt | pkt@SignaturePkt {} <- filteredPkts]- ) of- ([], _) ->- failWith- BadData- "inline-verify input has no literal message payload"- ([_], []) ->- failWith- BadData- "inline-verify input has no signatures"- ([lit], sigs)- | not hasOnePass- && ( null signaturePositions- || not (all (< literalIndex) signaturePositions)- )- && ( not allowTrailingSignatures- || not (all (> literalIndex) signaturePositions)- ) ->- failWith- BadData- "inline-verify input has malformed signed-message packet order"- | otherwise -> pure (lit : sigs)- (_, _) ->- failWith- BadData- "inline-verify input contains multiple literal payloads"- where- relevantPkts = filter (not . isMarkerPacket) pkts- filteredPkts = filter (not . isIgnorableInlineVerifyPacket) relevantPkts- packetPositions = zip [0 :: Int ..] filteredPkts- signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]- onePassPositions = [i | (i, OnePassSignaturePkt {}) <- packetPositions]- literalPositions = [i | (i, LiteralDataPkt {}) <- packetPositions]- hasOnePass = not (null onePassPositions)- literalIndex =- case literalPositions of- (i : _) -> i- [] -> -1- isBrokenPacket BrokenPacketPkt {} = True- isBrokenPacket _ = False--isIgnorableInlineVerifyPacket :: Pkt -> Bool-isIgnorableInlineVerifyPacket (OtherPacketPkt tag _) = tag >= 40-isIgnorableInlineVerifyPacket _ = False--isInlineVerificationPacket :: Pkt -> Bool-isInlineVerificationPacket LiteralDataPkt {} = True-isInlineVerificationPacket SignaturePkt {} = True-isInlineVerificationPacket OnePassSignaturePkt {} = True-isInlineVerificationPacket (OtherPacketPkt tag _) = tag >= 40-isInlineVerificationPacket BrokenPacketPkt {} = False-isInlineVerificationPacket _ = False--doEncrypt :: POSIXTime -> EncryptOptions -> IO ()-doEncrypt cpt EncryptOptions {..} = do- payload <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- when (encAs == AsText) $- ensureUTF8TextInput "encrypt" payload- symmetricPasswordsRaw <-- loadPasswordFiles "encrypt" "--with-password" encPasswords- symmetricPasswords <-- mapM- (normalizeHumanReadablePassword "encrypt" "--with-password")- symmetricPasswordsRaw- signingKeyPasswordsRaw <-- loadPasswordFiles- "encrypt"- "--with-key-password"- encSignWithKeyPasswords- let signingKeyPasswords = concatMap passwordRetryCandidates signingKeyPasswordsRaw- encryptProfile <- parseEncryptProfile encProfile- when- (not (null encRecipientCerts) && not (null symmetricPasswords))- $ failWith- UnsupportedOption- "encrypt: combining recipient certificates with --with-password is not yet supported"- recipientKeys <-- if null encRecipientCerts- then pure []- else loadEncryptRecipients cpt encFor encRecipientCerts- recipientHashPrefs <-- if null encRecipientCerts- then pure []- else loadRecipientPreferredHashes cpt encRecipientCerts- signatures <-- if null encSignWithKeyFiles- then pure []- else do- signingKeys <-- loadSigningKeys "encrypt" encSignWithKeyFiles signingKeyPasswords- signPayloadWithKeys- cpt- encAs- payload- signingKeys- recipientHashPrefs- ( case encryptProfile of- EncryptProfileRFC9580 -> rfc9580SigningHashFallbackOrder- EncryptProfileRFC4880 -> legacySigningHashFallbackOrder- )- out <-- case encRecipientCerts of- [] ->- doEncryptWithPassword- encryptProfile- payload- symmetricPasswords- encSessionKeyOutFile- _ ->- doEncryptForRecipients- encryptProfile- encAs- payload- signatures- recipientKeys- encSessionKeyOutFile- BL.putStr $- if encNoArmor- then out- else AA.encodeLazy [Armor ArmorMessage [] out]--doEncryptWithPassword- :: EncryptProfile- -> BL.ByteString- -> [BL.ByteString]- -> Maybe String- -> IO BL.ByteString-doEncryptWithPassword encryptProfile payload passwords sessionKeyOutFile = do- password <-- case passwords of- [] ->- failWith- MissingArg- "encrypt: supply at least one recipient certificate or --with-password"- [p] -> pure p- _ ->- failWith- UnsupportedOption- "encrypt: multiple --with-password values are not yet supported"- let exposure =- if isJust sessionKeyOutFile- then ExposeSessionMaterial- else DoNotExposeSessionMaterial- encrypted <-- case encryptProfile of- EncryptProfileRFC9580 -> do- s2kSalt <- Salt16 <$> getRandomBytes 16- iv <- IV <$> getRandomBytes 32- pure $- encryptMessage- RFC9580EncryptMessageOptions- { rfc9580EncryptMessageExposure = exposure- , rfc9580EncryptMessageSymmetricAlgorithm = AES256- , rfc9580EncryptMessageS2K = Argon2 s2kSalt 1 4 15- , rfc9580EncryptMessageIV = iv- }- (Passphrase password)- (mkClearPayload payload)- EncryptProfileRFC4880 -> do- salt <- Salt8 <$> getRandomBytes 8- iv <- IV <$> getRandomBytes 16- pure $- encryptMessage- RFC4880EncryptMessageOptions- { rfc4880EncryptMessageExposure = exposure- , rfc4880EncryptMessageSymmetricAlgorithm = AES256- , rfc4880EncryptMessageS2K = IteratedSalted SHA256 salt 65536- , rfc4880EncryptMessageIV = iv- }- (Passphrase password)- (mkClearPayload payload)- case encrypted of- Left err -> failWith BadData ("encrypt failed: " ++ show err)- Right (ciphertext, mRecoveredSession) -> do- forM_ sessionKeyOutFile $ \path ->- case mRecoveredSession of- Just recoveredSession ->- writeFileWithOutputExistsCheck- "encrypt"- path- ( renderSessionKeyOutLine- (fromFVal (recoveredSessionAlgorithm recoveredSession))- (unSessionKey (recoveredSessionKey recoveredSession))- ++ "\n"- )- Nothing ->- failWith- UnsupportedOption- "encrypt: --session-key-out unavailable for this password encryption mode"- pure (encryptedPayloadBytes ciphertext)--doEncryptForRecipients- :: EncryptProfile- -> AsBinaryText- -> BL.ByteString- -> [SignaturePayload]- -> [FunKey]- -> Maybe String- -> IO BL.ByteString-doEncryptForRecipients encryptProfile asMode payload signatures recipients sessionKeyOutFile = do- let targets = map recipientTargetFor recipients- payloadShape =- defaultRecipientPayloadShape- { recipientPayloadDataType = literalDataType- , recipientPayloadUseOnePassSignatures = not (null signatures)- , recipientPayloadSignatures = signatures- }- result <-- if useStrictEncryptProfile- then- encryptForRecipients- RecipientEncryptRequest- { recipientEncryptRequestTargets = targets- , recipientEncryptRequestPayloadShape = payloadShape- , recipientEncryptRequestPayload = BL.toStrict payload- , recipientEncryptRequestSymmetricOverride = symmetricOverride- , recipientEncryptRequestOverrides =- RecipientEncryptRequestSEIPDv2Overrides- { recipientEncryptRequestAEADOverride = Nothing- , recipientEncryptRequestChunkSizeOverride = Nothing- , recipientEncryptRequestSaltOverride = Nothing- }- }- else- encryptForRecipients- RecipientEncryptRequest- { recipientEncryptRequestTargets = targets- , recipientEncryptRequestPayloadShape = payloadShape- , recipientEncryptRequestPayload = BL.toStrict payload- , recipientEncryptRequestSymmetricOverride = symmetricOverride- , recipientEncryptRequestOverrides =- RecipientEncryptRequestSEIPDv1Overrides- { recipientEncryptRequestIVOverride = Nothing- }- }- RecipientEncryptResult {..} <-- case result of- Left err ->- failWith- (sopFailureForPKESKEncryptError err)- ("encrypt failed: " ++ renderPKESKEncryptError err)- Right val -> pure val- forM_ sessionKeyOutFile $ \path ->- writeFileWithOutputExistsCheck- "encrypt"- path- ( renderSessionKeyOutLine- (fromFVal (pkeskSessionAlgorithm recipientEncryptSessionMaterial))- (unSessionKey (pkeskSessionKey recipientEncryptSessionMaterial))- ++ "\n"- )- pure (runPut (Bin.put (Block recipientEncryptPackets)))- where- literalDataType =- case asMode of- AsBinary -> BinaryData- AsText -> UTF8Data- anyRecipientSupportsSEIPDv2 = any fsupportsSEIPDv2 recipients- symmetricOverride- | useStrictEncryptProfile =- preferredStrictSymmetric <|> Just AES256- | otherwise = preferredLegacySymmetric- isV6Recipient pkp = _keyVersion pkp == V6- useStrictEncryptProfile =- case encryptProfile of- EncryptProfileRFC9580 ->- anyRecipientSupportsSEIPDv2- || any (isV6Recipient . fpkp) recipients- EncryptProfileRFC4880 ->- anyRecipientSupportsSEIPDv2- || any (isV6Recipient . fpkp) recipients- preferredStrictSymmetric =- preferredRecipientSymmetric isSupportedStrictEncryptSymmetric- preferredLegacySymmetric =- preferredRecipientSymmetric isSupportedLegacyEncryptSymmetric- preferredRecipientSymmetric isSupported =- case filter- (not . null)- (map fpreferredSymmetricAlgorithms recipients) of- [] -> Nothing- (prefList : prefLists) ->- listToMaybe- [ candidate- | candidate <- filter isSupported prefList- , all (candidate `elem`) prefLists- ]- isSupportedStrictEncryptSymmetric algo =- algo `elem` [AES128, AES192, AES256]- -- Legacy profile fallback should not hard-fail on deprecated/unsupported- -- recipient preferences (e.g. IDEA in AEADED interop fixtures).- isSupportedLegacyEncryptSymmetric algo =- algo `elem` [AES128, AES192, AES256]- recipientTargetFor funkey =- let recipient = fpkp funkey- recipientNeedsV6PKESK =- useStrictEncryptProfile- && (fsupportsSEIPDv2 funkey || _keyVersion recipient == V6)- in if _keyVersion recipient == V6- then- recipientEncryptionTargetWithStrategyTyped- recipient- RecipientPreferV6W- else case _pkalgo recipient of- ECDH ->- -- Under strict (SEIPDv2) mode, keep Curve25519-compatible v4 ECDH keys on- -- the X25519/v6 path so ESK/payload versions stay aligned.- if recipientNeedsV6PKESK- then case normalizeX25519CompatibleECDHRecipient recipient of- Just x25519Recipient ->- recipientEncryptionTargetWithStrategyTyped- x25519Recipient- RecipientPreferV6W- Nothing ->- recipientEncryptionTargetWithStrategyTyped- recipient- RecipientPreferV6W- else- recipientEncryptionTargetWithStrategyTyped- recipient- RecipientForceV3InteropW- DeprecatedRSAEncryptOnly ->- if recipientNeedsV6PKESK- then- recipientEncryptionTargetWithStrategyTyped- recipient- RecipientPreferV6W- else- recipientEncryptionTargetWithStrategyTyped- recipient- RecipientForceV3InteropW- RSA ->- if recipientNeedsV6PKESK- then- recipientEncryptionTargetWithStrategyTyped- recipient- RecipientPreferV6W- else- recipientEncryptionTargetWithStrategyTyped- recipient- RecipientForceV3InteropW- _ ->- if recipientNeedsV6PKESK- then- recipientEncryptionTargetWithStrategyTyped- recipient- RecipientPreferV6W- else recipientEncryptionTarget recipient-- normalizeX25519CompatibleECDHRecipient pkp =- case _pubkey pkp of- ECDHPubKey (EdDSAPubKey EdSigningCurve25519 _) _ _ ->- Just- ( PKPayload- (_keyVersion pkp)- (_timestamp pkp)- (_v3exp pkp)- X25519- (_pubkey pkp)- )- _ -> Nothing--parseEncryptProfile :: Maybe String -> IO EncryptProfile-parseEncryptProfile Nothing = pure EncryptProfileRFC9580-parseEncryptProfile (Just name) =- case resolveProfile name encryptProfiles of- Just p -> pure p- Nothing ->- failWith- UnsupportedProfile- ("encrypt: unsupported profile " ++ name)--doDecrypt :: POSIXTime -> DecryptOptions -> IO ()-doDecrypt cpt DecryptOptions {..} = do- sessionKeys <- parseDecryptSessionKeys decSessionKeys- verificationOutputPath <-- resolveDecryptVerificationsOut decVerificationsOutFile- let hasVerifyWith = not (null decVerifyCerts)- hasVerifyOut = isJust verificationOutputPath- hasVerifyBounds = isJust decVerifyNotBefore || isJust decVerifyNotAfter- doingVerification = hasVerifyWith && hasVerifyOut- when (hasVerifyWith /= hasVerifyOut) $- failWith- IncompleteVerification- "decrypt: verification requires both --verify-with and --verifications-out"- when (hasVerifyBounds && not doingVerification) $- failWith- IncompleteVerification- "decrypt: --verify-not-before/--verify-not-after require both --verify-with and --verifications-out"- passwords <-- loadPasswordFiles "decrypt" "--with-password" decPasswords- keyPasswordsRaw <-- loadPasswordFiles "decrypt" "--with-key-password" decKeyPasswords- let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw- when (null passwords && null sessionKeys && null decKeyFiles) $- failWith- MissingArg- "decrypt: supply KEYS, --with-password, or --with-session-key"- ciphertextInput <-- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy- ciphertext <- decodeCiphertextInput ciphertextInput- validateDecryptPartialBodyEncoding ciphertext- ciphertextPktsRaw <-- parseRawOpenPGPPackets "decrypt input" ciphertext- let ciphertextPkts =- filter- ( \pkt ->- not- ( isForwardCompatUnknownESKPacket pkt- || isUnsupportedSKESKPacket pkt- )- )- ciphertextPktsRaw- -- Pre-flight: reject messages with no encrypted payload at all (upstream- -- won't produce a useful DecryptMalformedStructure for the empty case).- when (not (any isEncryptedPayloadPacket ciphertextPkts)) $- failWith BadData "decrypt input: no encrypted data packet found"- validateCiphertextPacketLayout ciphertextPkts- recipientKeys <-- loadDecryptRecipientKeys cpt "decrypt" decKeyFiles keyPasswords- when- ( null recipientKeys- && not (null decKeyFiles)- && null passwords- && null sessionKeys- )- $ failWith- CannotDecrypt- "decrypt failed: no usable secret key material found in provided KEYS"- let passwordAttempts =- case passwords of- [] -> [[]]- _ ->- map- (\password -> [password])- (concatMap passwordRetryCandidates passwords)- runDecryptAttemptWithPolicy decryptPolicy keyCandidates passwordBytes = do- passwordQueue <- newIORef passwordBytes- sessionKeyQueue <-- newIORef (map decryptSessionKeyMaterial sessionKeys)- let decryptInputPkts = prioritizeDecryptablePKESKs keyCandidates ciphertextPkts- let keyResolutionResolver =- selectRecipientKeyInfosByRecipientIdentifier keyCandidates- let opts =- Decrypt.DecryptOptions- { Decrypt.decryptOptionsKeyResolution =- DecryptWithUnwrapCandidatesCallback keyResolutionResolver- , Decrypt.decryptOptionsPolicy = decryptPolicy- , Decrypt.decryptOptionsPassphraseCallback =- decryptInputCallback passwordQueue sessionKeyQueue- }- (outcome, pkts) <-- runConduitRes $- CL.sourceList decryptInputPkts- .| fuseBoth (Decrypt.conduitDecrypt opts) CL.consume- case outcome of- DecryptMalformedStructure reason ->- pure (Left reason)- DecryptTruncated ->- failWith BadData "decrypt failed: encrypted message is truncated"- _ -> pure (Right pkts)- tryDecryptWithPasswords [passwordBytes] =- runDecryptAttempt recipientKeys passwordBytes- `catch` decryptIOFailureToSOP- tryDecryptWithPasswords (passwordBytes : rest) =- runDecryptAttempt recipientKeys passwordBytes `catch` retryNext- where- retryNext :: ExitCode -> IO [Pkt]- retryNext exitCode- | exitCode == ExitFailure (failureCode CannotDecrypt) =- tryDecryptWithPasswords rest- | otherwise = throwIO exitCode- tryDecryptWithPasswords [] =- failWith- CannotDecrypt- "decrypt failed: passphrase required but not provided"- decryptIOFailureToSOP :: IOException -> IO [Pkt]- decryptIOFailureToSOP err =- failWith- CannotDecrypt- ("decrypt failed: " ++ displayException err)- runDecryptAttempt keyCandidates passwordBytes = do- strictOutcome <-- runDecryptAttemptWithPolicy- defaultDecryptPolicy- keyCandidates- passwordBytes- case strictOutcome of- Right pkts -> pure pkts- Left reason ->- let reasonStr = renderDecryptStructureError reason- in if shouldRetryLenientDecrypt reasonStr keyCandidates passwordBytes- then do- lenientOutcome <-- runDecryptAttemptWithPolicy- lenientDecryptPolicy- keyCandidates- passwordBytes- case lenientOutcome of- Right pkts -> pure pkts- Left lenientReason ->- failWith- BadData- ( "decrypt failed: malformed encrypted message structure ("- ++ renderDecryptStructureError lenientReason- ++ ")"- )- else- failWith- BadData- ( "decrypt failed: malformed encrypted message structure ("- ++ reasonStr- ++ ")"- )- shouldRetryLenientDecrypt reason keyCandidates passwordBytes- | "ESK packets must immediately precede encrypted data"- `isInfixOf` reason =- True- | "ESK packets present but none are version-aligned with SEIPDv2 payload"- `isInfixOf` reason =- null passwordBytes- && not (null keyCandidates)- && any isLegacyRSAPKESK ciphertextPkts- | otherwise = False- isLegacyRSAPKESK (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) =- pka == RSA || pka == DeprecatedRSAEncryptOnly- isLegacyRSAPKESK _ = False- decryptedPktsRaw <- tryDecryptWithPasswords passwordAttempts- sessionKeyOutLine <-- resolveSessionKeyOut- decSessionKeyOutFile- sessionKeys- ciphertextPkts- recipientKeys- (concatMap passwordRetryCandidates passwords)- decryptedPkts <- do- decompressed <-- mapM- ( either (\e -> failWith BadData (renderCompressionError e)) pure- . recursivelyDecompressPacket- )- decryptedPktsRaw- pure (concat decompressed)- validateDecryptedMessageStructure decryptedPktsRaw decryptedPkts- payload <- extractSingleLiteralPayload decryptedPkts- BL.putStr payload- case (decSessionKeyOutFile, sessionKeyOutLine) of- (Just path, Just line) -> writeFileWithOutputExistsCheck "decrypt" path (line ++ "\n")- _ -> pure ()- when doingVerification $- doDecryptVerifyOutput- cpt- decVerifyCerts- verificationOutputPath- decVerifyNotBefore- decVerifyNotAfter- decryptedPkts--data DecryptSessionKey- = DecryptSessionKey- { decryptSessionKeyMaterial :: BL.ByteString- , decryptSessionKeyOutLine :: Maybe String- }--decryptInputCallback- :: IORef [BL.ByteString]- -> IORef [BL.ByteString]- -> String- -> IO BL.ByteString-decryptInputCallback _passwordQueue sessionKeyQueue prompt- | "PKESK session key material" `isInfixOf` prompt = do- mSessionKeyMaterial <-- atomicModifyIORef' sessionKeyQueue $ \keys ->- case keys of- [] -> ([], Nothing)- (k : rest) -> (rest, Just k)- case mSessionKeyMaterial of- Just sessionKeyMaterial -> pure sessionKeyMaterial- Nothing ->- failWith- CannotDecrypt- "decrypt failed: PKESK session key material required but not provided"-decryptInputCallback passwordQueue _ _ = do- mPassword <-- atomicModifyIORef' passwordQueue $ \passwords ->- case passwords of- [] -> ([], Nothing)- (p : rest) -> (rest, Just p)- case mPassword of- Just password -> pure password- Nothing ->- failWith- CannotDecrypt- "decrypt failed: passphrase required but not provided"--parseDecryptSessionKeys :: [String] -> IO [DecryptSessionKey]-parseDecryptSessionKeys = mapM parseSessionKeySpec--parseSessionKeySpec :: String -> IO DecryptSessionKey-parseSessionKeySpec spec =- case break (== ':') spec of- (_, "") -> do- material <- decodeHexBytes spec- pure- DecryptSessionKey- { decryptSessionKeyMaterial = BL.fromStrict material- , decryptSessionKeyOutLine = sessionKeyOutLineFromMaterial material- }- (algoSpec, ':' : keyHex) -> do- algo <- parseAlgorithmOctet algoSpec- keyBytes <- decodeHexBytes keyHex- when (B.null keyBytes) $- failWith- BadData- "decrypt: --with-session-key key material cannot be empty"- pure- DecryptSessionKey- { decryptSessionKeyMaterial =- BL.fromStrict (encodeOpenPGPSessionKey algo keyBytes)- , decryptSessionKeyOutLine =- Just (renderSessionKeyOutLine algo keyBytes)- }- _ -> failWith BadData "decrypt: invalid --with-session-key format"--resolveSessionKeyOut- :: Maybe String- -> [DecryptSessionKey]- -> [Pkt]- -> [PKESKRecipientKey]- -> [BL.ByteString]- -> IO (Maybe String)-resolveSessionKeyOut Nothing _ _ _ _ = pure Nothing-resolveSessionKeyOut (Just _) sessionKeys ciphertextPkts recipientKeys passwordCandidates =- case mapMaybe decryptSessionKeyOutLine sessionKeys of- (line : _) -> pure (Just line)- [] -> do- discoveredLine <-- recoverSessionKeyOutFromCiphertext- ciphertextPkts- recipientKeys- passwordCandidates- case discoveredLine of- Just line -> pure (Just line)- Nothing -> pure Nothing--recoverSessionKeyOutFromCiphertext- :: [Pkt]- -> [PKESKRecipientKey]- -> [BL.ByteString]- -> IO (Maybe String)-recoverSessionKeyOutFromCiphertext ciphertextPkts recipientKeys passwordCandidates =- case recoverFromSKESK of- Just line -> pure (Just line)- Nothing -> recoverFromLegacyRSAPKESK- where- recoverFromSKESK =- listToMaybe $- mapMaybe- ( \(SKESKPayloadV4 sa s2k maybeEsk, passphrase) ->- case maybeEsk of- Nothing ->- case skesk2Key (SKESK4Packet sa s2k Nothing) passphrase of- Left _ -> Nothing- Right sessionKey ->- Just (renderSessionKeyOutLine (fromFVal sa) sessionKey)- Just esk ->- case skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase of- Left _ -> Nothing- Right (algo, sessionKey) ->- Just (renderSessionKeyOutLine (fromFVal algo) sessionKey)- )- [ (payload, passphrase)- | payload <- skeskPayloadsV4- , passphrase <- passwordCandidates- ]- skeskPayloadsV4 =- mapMaybe- ( \pkt ->- case pkt of- SKESKPkt (SKESKPayloadV4Packet payload) -> Just payload- _ -> Nothing- )- ciphertextPkts- recoverFromLegacyRSAPKESK =- recoverRSACombos- [(mpi, rsaKey) | mpi <- rsaPKESKMPIs, rsaKey <- rsaRecipientKeys]- recoverRSACombos [] = pure Nothing- recoverRSACombos ((mpi, rsaKey) : rest) = do- encodedResult <- decryptLegacyRSAPKESK rsaKey mpi- case encodedResult of- Left _ -> recoverRSACombos rest- Right encoded ->- case decodeOpenPGPEncodedSessionKey encoded of- Right (algo, keyBytes) ->- pure (Just (renderSessionKeyOutLine (fromFVal algo) keyBytes))- Left _ -> recoverRSACombos rest- rsaPKESKMPIs =- mapMaybe- ( \pkt ->- case pkt of- PKESKPkt- (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka (mpi :| [])))- | pka == RSA || pka == DeprecatedRSAEncryptOnly ->- Just mpi- _ -> Nothing- )- ciphertextPkts- rsaRecipientKeys =- mapMaybe- ( \keyInfo ->- case pkeskRecipientSKey keyInfo of- RSAPrivateKey (RSA_PrivateKey privateKey) -> Just privateKey- _ -> Nothing- )- recipientKeys--decryptLegacyRSAPKESK- :: RSA.PrivateKey -> MPI -> IO (Either String B.ByteString)-decryptLegacyRSAPKESK privateKey mpi = do- attempted <-- P15.decryptSafer privateKey (mpiToCiphertext privateKey mpi)- pure (first show attempted)- where- mpiToCiphertext rsaKey (MPI encodedMPI) =- let modulusBytes = rsaModulusOctets rsaKey- in i2ospOf_ modulusBytes encodedMPI- rsaModulusOctets rsaKey =- let modulusBits = integerBitLength (RSA.public_n (RSA.private_pub rsaKey))- in max 1 ((modulusBits + 7) `div` 8)- integerBitLength n- | n <= 0 = 0- | otherwise = go n 0- where- go 0 bits = bits- go val bits = go (val `div` 2) (bits + 1)--parseAlgorithmOctet :: String -> IO Word8-parseAlgorithmOctet algoSpec =- case readMaybe algoSpec :: Maybe Int of- Just octet- | octet >= 0 && octet <= 255 ->- case toFVal (fromIntegral octet) :: SymmetricAlgorithm of- OtherSA _ ->- failWith- BadData- ("decrypt: unsupported --with-session-key algorithm: " ++ algoSpec)- _ -> pure (fromIntegral octet)- _ ->- failWith- BadData- ("decrypt: invalid --with-session-key algorithm: " ++ algoSpec)--decodeHexBytes :: String -> IO B.ByteString-decodeHexBytes hex =- if odd (length hex)- then- failWith- BadData- "decrypt: hex key material must have an even number of digits"- else B.pack <$> go hex- where- go [] = pure []- go (a : b : rest) = do- hi <- nibble a- lo <- nibble b- (fromIntegral (hi * 16 + lo) :) <$> go rest- go _ = failWith BadData "decrypt: malformed hex key material"- nibble c =- if isHexDigit c- then pure (digitToInt c)- else failWith BadData "decrypt: key material must be hexadecimal"--isEncryptedPayloadPacket :: Pkt -> Bool-isEncryptedPayloadPacket SymEncIntegrityProtectedDataPkt {} = True-isEncryptedPayloadPacket SymEncDataPkt {} = True-isEncryptedPayloadPacket _ = False--isForwardCompatUnknownESKPacket :: Pkt -> Bool-isForwardCompatUnknownESKPacket (OtherPacketPkt tag _) = tag == 1 || tag == 3-isForwardCompatUnknownESKPacket (BrokenPacketPkt _ tag _) = tag == 1 || tag == 3-isForwardCompatUnknownESKPacket _ = False--isUnsupportedSKESKPacket :: Pkt -> Bool-isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ s2k _))) = isUnknownS2K s2k-isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ s2k _ _ _))) = isUnknownS2K s2k-isUnsupportedSKESKPacket _ = False--isUnknownS2K :: S2K -> Bool-isUnknownS2K OtherS2K {} = True-isUnknownS2K _ = False--validateCiphertextPacketLayout :: [Pkt] -> IO ()-validateCiphertextPacketLayout pkts =- case findIndex isEncryptedPayloadPacket pkts of- Nothing -> pure ()- Just payloadIndex ->- let trailing =- filter- (not . isMarkerPacketPacket)- (drop (payloadIndex + 1) pkts)- in when (not (null trailing)) $- failWith- BadData- "decrypt input: malformed encrypted message structure (unexpected packets after encrypted data)"--isMarkerPacketPacket :: Pkt -> Bool-isMarkerPacketPacket MarkerPkt {} = True-isMarkerPacketPacket _ = False--validateDecryptedMessageStructure :: [Pkt] -> [Pkt] -> IO ()-validateDecryptedMessageStructure rawPkts pkts = do- let literalCount = length [() | LiteralDataPkt {} <- pkts]- signatureCount = length [() | SignaturePkt {} <- pkts]- onePassCount = length [() | OnePassSignaturePkt {} <- pkts]- hasCompressedRaw = any isCompressedPacket rawPkts- hasUnknownPackets = any isUnknownPacket rawPkts || any isUnknownPacket pkts- maxCompressionDepth = maximum (0 : map compressionDepth rawPkts)- when (any compressedPacketParseFailed rawPkts) $- failWith- BadData- "decrypt failed: malformed compressed data stream"- when (maxCompressionDepth > 2) $- failWith- BadData- "decrypt failed: malformed encrypted message structure (excessive compression nesting)"- when (hasCompressedRaw && any isMarkerPacket pkts) $- failWith- BadData- "decrypt failed: malformed encrypted message structure (compressed marker packet)"- when (any isDisallowedDecryptedPacketType pkts) $- failWith- BadData- "decrypt failed: malformed encrypted message structure (unexpected packet type in plaintext)"- when (literalCount == 0) $- failWith- BadData- "decrypt failed: malformed encrypted message structure (no literal data payload found)"- when (literalCount > 1) $- failWith- BadData- "decrypt failed: malformed encrypted message structure (multiple literal payloads)"- when- (not hasUnknownPackets && onePassCount > 0 && signatureCount == 0)- $ failWith- BadData- "decrypt failed: malformed signed message structure (one-pass signature without trailing signature)"- when- ( not hasUnknownPackets- && signatureCount > 0- && onePassCount == 0- && not isOldStyleSignedMessage- )- $ failWith- BadData- "decrypt failed: malformed signed message structure (trailing signature without one-pass signature)"- where- isOldStyleSignedMessage =- case [i | (i, LiteralDataPkt {}) <- packetPositions] of- [literalIndex] ->- not (null signaturePositions)- && all (< literalIndex) signaturePositions- _ -> False- packetPositions = zip [0 :: Int ..] (filter (not . isMarkerPacket) pkts)- signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]--compressedPacketParseFailed :: Pkt -> Bool-compressedPacketParseFailed pkt@CompressedDataPkt {} = isLeft (decompressPkt pkt)-compressedPacketParseFailed _ = False--recursivelyDecompressPacket- :: Pkt -> Either CompressionError [Pkt]-recursivelyDecompressPacket pkt@CompressedDataPkt {} = do- inner <- decompressPkt pkt- concat <$> mapM recursivelyDecompressPacket inner-recursivelyDecompressPacket pkt = Right [pkt]--compressedPacketIsEmpty :: Pkt -> Bool-compressedPacketIsEmpty pkt@CompressedDataPkt {} =- case decompressPkt pkt of- Right [] -> True- _ -> False-compressedPacketIsEmpty _ = False--isCompressedPacket :: Pkt -> Bool-isCompressedPacket CompressedDataPkt {} = True-isCompressedPacket _ = False--compressionDepth :: Pkt -> Int-compressionDepth pkt@CompressedDataPkt {} =- let inner = either (const []) id (decompressPkt pkt)- in if null inner- then 1- else 1 + maximum (0 : map compressionDepth inner)-compressionDepth _ = 0--isMarkerPacket :: Pkt -> Bool-isMarkerPacket MarkerPkt {} = True-isMarkerPacket _ = False--isUnknownPacket :: Pkt -> Bool-isUnknownPacket OtherPacketPkt {} = True-isUnknownPacket BrokenPacketPkt {} = True-isUnknownPacket _ = False--isDisallowedDecryptedPacketType :: Pkt -> Bool-isDisallowedDecryptedPacketType PKESKPkt {} = True-isDisallowedDecryptedPacketType SKESKPkt {} = True-isDisallowedDecryptedPacketType PublicKeyPkt {} = True-isDisallowedDecryptedPacketType PublicSubkeyPkt {} = True-isDisallowedDecryptedPacketType SecretKeyPkt {} = True-isDisallowedDecryptedPacketType SecretSubkeyPkt {} = True-isDisallowedDecryptedPacketType SymEncDataPkt {} = True-isDisallowedDecryptedPacketType SymEncIntegrityProtectedDataPkt {} = True-isDisallowedDecryptedPacketType _ = False--encodeOpenPGPSessionKey :: Word8 -> B.ByteString -> B.ByteString-encodeOpenPGPSessionKey algo keyBytes =- B.cons- algo- ( keyBytes- <> B.pack [fromIntegral (checksum `div` 256), fromIntegral checksum]- )- where- checksum :: Int- checksum =- B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536--sessionKeyOutLineFromMaterial :: B.ByteString -> Maybe String-sessionKeyOutLineFromMaterial raw = do- (algo, keyBytes) <- decodeOpenPGPSessionKeyMaterial raw- pure (renderSessionKeyOutLine algo keyBytes)--decodeOpenPGPSessionKeyMaterial- :: B.ByteString -> Maybe (Word8, B.ByteString)-decodeOpenPGPSessionKeyMaterial raw = do- (algo, body) <- B.uncons raw- case toFVal (fromIntegral algo) :: SymmetricAlgorithm of- OtherSA _ -> Nothing- _ -> do- let bodyLen = B.length body- if bodyLen < 3- then Nothing- else do- let keyBytes = B.take (bodyLen - 2) body- checksumHi = fromIntegral (B.index body (bodyLen - 2)) :: Int- checksumLo = fromIntegral (B.index body (bodyLen - 1)) :: Int- checksumExpected = checksumHi * 256 + checksumLo- checksumActual =- B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536- if B.null keyBytes || checksumActual /= checksumExpected- then Nothing- else Just (algo, keyBytes)--renderSessionKeyOutLine :: Word8 -> B.ByteString -> String-renderSessionKeyOutLine algo keyBytes =- show algo ++ ":" ++ hexEncodeBytes keyBytes--hexEncodeBytes :: B.ByteString -> String-hexEncodeBytes = concatMap encodeByte . B.unpack- where- encodeByte w =- [ nibble (w `shiftR` 4)- , nibble (w .&. 0x0f)- ]- nibble n = "0123456789abcdef" !! fromIntegral n--extractSingleLiteralPayload :: [Pkt] -> IO BL.ByteString-extractSingleLiteralPayload pkts =- case [p | LiteralDataPkt _ _ _ p <- pkts] of- [payload] -> pure payload- [] ->- failWith- BadData- "decrypt failed: malformed encrypted message structure (no literal data payload found)"- _ ->- failWith- BadData- "decrypt failed: malformed encrypted message structure (multiple literal data payloads found)"--doDecryptVerifyOutput- :: POSIXTime- -> [String]- -> Maybe String- -> Maybe String- -> Maybe String- -> [Pkt]- -> IO ()-doDecryptVerifyOutput cpt certFiles outFile notBeforeArg notAfterArg decryptedPkts = do- when (null certFiles) $- failWith- IncompleteVerification- "decrypt: verification requires at least one --verify-with cert"- (krs, verifyTks) <- loadVerifyContext cpt certFiles- upperBound <- verificationUpperBound cpt notAfterArg- lowerBound <- verificationLowerBound cpt notBeforeArg- verificationPkts <-- normalizeDecryptVerificationPackets decryptedPkts- let verifications =- map- (first show)- (verifyPacketsBatch krs upperBound verificationPkts)- filtered = filterByVerificationBounds lowerBound upperBound verifications- successLines =- map (renderSOPVerificationLine verifyTks) (rights filtered)- renderedOut =- if null successLines- then ""- else unlines successLines- case outFile of- Just path -> writeFileWithOutputExistsCheck "decrypt" path renderedOut- Nothing -> pure ()--normalizeDecryptVerificationPackets :: [Pkt] -> IO [Pkt]-normalizeDecryptVerificationPackets pkts =- case ( [pkt | pkt@LiteralDataPkt {} <- pkts]- , [pkt | pkt@SignaturePkt {} <- pkts]- ) of- ([], _) ->- failWith- CannotDecrypt- "decrypt failed: no literal data payload found"- ([lit], []) -> pure [lit]- ([lit], sigs) -> pure (lit : sigs)- (_, _) ->- failWith- BadData- "decrypt failed: malformed signed message structure (multiple literal payloads)"--resolveDecryptVerificationsOut- :: Maybe String -> IO (Maybe String)-resolveDecryptVerificationsOut newPath =- pure $ case newPath of- Just p -> Just p- Nothing -> Nothing--renderSOPVerificationLine- :: [SomeTK] -> Verification -> String-renderSOPVerificationLine verifyTks v =- ts- ++ " "- ++ signerFp- ++ " "- ++ certFp- ++ " "- ++ modeLabel- ++ " "- ++ jsonTrailer- where- sig = _verificationSignature v- ts = renderSOPVerificationTimestamp sig- signer = fingerprint (_verificationSigner v)- signerFp = hexEncodeBytes (BL.toStrict (unFingerprint signer))- modeLabel = signatureModeField sig- certFp =- case find (\tk -> keyMatchesFingerprint True tk signer) verifyTks of- Just tk ->- hexEncodeBytes- ( BL.toStrict- ( unFingerprint- ( fingerprint- (keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk)))- )- )- )- Nothing -> signerFp- jsonTrailer = "{\"signers\":[{\"fingerprint\":\"" ++ signerFp ++ "\"}]}"--signatureModeField :: SignaturePayload -> String-signatureModeField sig =- case sig of- SigV4 CanonicalTextSig _ _ _ _ _ _ -> "mode:text"- SigV6 CanonicalTextSig _ _ _ _ _ _ _ -> "mode:text"- _ -> "mode:binary"--renderSOPVerificationTimestamp :: SignaturePayload -> String-renderSOPVerificationTimestamp sig =- formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" $- case signatureCreationTime sig of- Just t -> t- Nothing -> posixSecondsToUTCTime 0--writeFileWithOutputExistsCheck- :: String -> FilePath -> String -> IO ()-writeFileWithOutputExistsCheck subcommand path content = do- ensureOutputPathAvailable subcommand path- writeFile path content--parseOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]-parseOpenPGPPackets context bytes =- ( do- let packets =- concatMap- (either (const []) id . decompressPkt)- (parsePkts bytes)- _ <- evaluate (length packets)- pure packets- )- `catch` parseFailure- where- parseFailure :: SomeException -> IO [Pkt]- parseFailure err =- failWith- BadData- ( context- ++ ": failed to parse OpenPGP packets: "- ++ displayException err- )--parseRawOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]-parseRawOpenPGPPackets context bytes =- ( do- let packets = parsePkts bytes- _ <- evaluate (length packets)- pure packets- )- `catch` parseFailure- where- parseFailure :: SomeException -> IO [Pkt]- parseFailure err =- failWith- BadData- ( context- ++ ": failed to parse OpenPGP packets: "- ++ displayException err- )--validateDecryptPartialBodyEncoding :: BL.ByteString -> IO ()-validateDecryptPartialBodyEncoding ciphertext =- case ensureNoShortFirstPartialBodyChunk (BL.toStrict ciphertext) of- Left err ->- failWith- BadData- ("decrypt input: invalid partial body encoding (" ++ err ++ ")")- Right () -> pure ()--ensureNoShortFirstPartialBodyChunk- :: B.ByteString -> Either String ()-ensureNoShortFirstPartialBodyChunk = parsePackets- where- parsePackets bs- | B.null bs = Right ()- | otherwise = do- (header, rest) <-- noteLeft "truncated packet header" (B.uncons bs)- if header .&. 0x80 /= 0x80- then Left "invalid packet header octet"- else do- remaining <-- if header .&. 0x40 == 0x40- then parseNewPacketBody rest- else parseOldPacketBody (header .&. 0x03) rest- parsePackets remaining-- parseOldPacketBody lengthType bs =- case lengthType of- 0 -> do- (lenOctet, rest) <-- noteLeft "truncated old-format one-octet length" (B.uncons bs)- dropExact- "truncated old-format packet body"- (fromIntegral lenOctet)- rest- 1 -> do- (hi, afterHi) <-- noteLeft "truncated old-format two-octet length" (B.uncons bs)- (lo, rest) <-- noteLeft- "truncated old-format two-octet length"- (B.uncons afterHi)- let len = fromIntegral hi * 256 + fromIntegral lo- dropExact "truncated old-format packet body" len rest- 2 -> do- (b1, afterB1) <-- noteLeft "truncated old-format four-octet length" (B.uncons bs)- (b2, afterB2) <-- noteLeft- "truncated old-format four-octet length"- (B.uncons afterB1)- (b3, afterB3) <-- noteLeft- "truncated old-format four-octet length"- (B.uncons afterB2)- (b4, rest) <-- noteLeft- "truncated old-format four-octet length"- (B.uncons afterB3)- let len =- (fromIntegral b1 `shiftL` 24)- + (fromIntegral b2 `shiftL` 16)- + (fromIntegral b3 `shiftL` 8)- + fromIntegral b4- dropExact "truncated old-format packet body" len rest- 3 -> Right B.empty- _ -> Left "invalid old-format length type"-- parseNewPacketBody = parseNewLengthChunks True-- parseNewLengthChunks isFirstChunk bs = do- (chunkLength, isPartial, afterLength) <- parseNewLength bs- when (isFirstChunk && isPartial && chunkLength < 512) $- Left- ( "first partial chunk is too short ("- ++ show chunkLength- ++ " octets, minimum is 512)"- )- afterChunk <-- dropExact- "truncated new-format packet body chunk"- chunkLength- afterLength- if isPartial- then parseNewLengthChunks False afterChunk- else Right afterChunk-- parseNewLength bs = do- (lengthOctet, rest) <-- noteLeft "truncated new-format length" (B.uncons bs)- case lengthOctet of- _- | lengthOctet < 192 ->- Right (fromIntegral lengthOctet, False, rest)- | lengthOctet < 224 -> do- (nextOctet, afterNext) <-- noteLeft "truncated new-format two-octet length" (B.uncons rest)- let len =- ((fromIntegral lengthOctet - 192) `shiftL` 8)- + fromIntegral nextOctet- + 192- Right (len, False, afterNext)- | lengthOctet < 255 ->- Right- ( 1 `shiftL` fromIntegral (lengthOctet .&. 0x1f)- , True- , rest- )- | otherwise -> do- (b1, afterB1) <-- noteLeft "truncated new-format five-octet length" (B.uncons rest)- (b2, afterB2) <-- noteLeft- "truncated new-format five-octet length"- (B.uncons afterB1)- (b3, afterB3) <-- noteLeft- "truncated new-format five-octet length"- (B.uncons afterB2)- (b4, afterB4) <-- noteLeft- "truncated new-format five-octet length"- (B.uncons afterB3)- let len =- (fromIntegral b1 `shiftL` 24)- + (fromIntegral b2 `shiftL` 16)- + (fromIntegral b3 `shiftL` 8)- + fromIntegral b4- Right (len, False, afterB4)-- dropExact context n bs- | B.length bs < n = Left context- | otherwise = Right (B.drop n bs)-- noteLeft err = maybe (Left err) Right--ensureOutputPathAvailable :: String -> FilePath -> IO ()-ensureOutputPathAvailable subcommand path = do- exists <- doesFileExist path- when exists $- failWith- OutputExists- (subcommand ++ ": output path already exists: " ++ path)--loadVerifyContext- :: POSIXTime -> [String] -> IO (PublicKeyring, [SomeTK])-loadVerifyContext _ certFiles = do- allTks <-- mapMaybe enforceVerifyPrimaryKeyPolicy- . map sanitizeVerifyTK- . concat- <$> mapM (loadCertTKsFromFile "verify") certFiles- let publicTks =- mapMaybe- ( \tk ->- case tk of- SomePublicTK publicTk -> Just publicTk- SomeSecretTK secretTk -> Just (publicViewTK secretTk)- )- allTks- keyring <-- runConduitRes $ CL.sourceList publicTks .| sinkPublicKeyringMap- pure (keyring, allTks)--loadVerifyTKsFromFile :: String -> String -> IO [SomeTK]-loadVerifyTKsFromFile context path = do- lbs <- loadInputFromFile context "file" path- certPkts <- decodeOpenPGPInput path lbs- runConduitRes $- CL.sourceList certPkts- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList--loadCertTKsFromFile :: String -> String -> IO [SomeTK]-loadCertTKsFromFile context path = do- lbs <- loadInputFromFile context "file" path- certPkts <- decodeOpenPGPInput path lbs- rejectSecretKeyPackets context path certPkts- runConduitRes $- CL.sourceList certPkts- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList--rejectSecretKeyPackets :: String -> String -> [Pkt] -> IO ()-rejectSecretKeyPackets context path packets =- when (any isSecretKeyPacket packets) $- failWith- BadData- ( context- ++ ": certificate input contains secret key material in "- ++ path- )- where- isSecretKeyPacket SecretKeyPkt {} = True- isSecretKeyPacket SecretSubkeyPkt {} = True- isSecretKeyPacket _ = False--sanitizeVerifyTK :: SomeTK -> SomeTK-sanitizeVerifyTK stk =- case primaryKeyIdentity stk of- Nothing -> stk- Just _ ->- case stk of- SomePublicTK tk -> SomePublicTK tk {_tkSubs = map sanitize (_tkSubs tk)}- SomeSecretTK tk -> SomeSecretTK tk {_tkSubs = map sanitize (_tkSubs tk)}- where- publicView = someTKToPublicViewTK stk- pkp = keyPktPKPayload (_tkPrimaryKey publicView)- primaryFp = fingerprint pkp- primaryKeyId =- either- (error "sanitizeVerifyTK: no key ID")- id- (eightOctetKeyID pkp)- sanitize- :: (KeyPkt k, [SignaturePayload]) -> (KeyPkt k, [SignaturePayload])- sanitize (kp, sigs) =- let sanitized =- mapMaybe (sanitizeBindingSignature primaryFp primaryKeyId) sigs- in if isSubkeyPacket (keyPktToPkt kp)- then (kp, sanitized)- else (kp, sigs)- isSubkeyPacket (PublicSubkeyPkt {}) = True- isSubkeyPacket (SecretSubkeyPkt {}) = True- isSubkeyPacket _ = False--enforceVerifyPrimaryKeyPolicy :: SomeTK -> Maybe SomeTK-enforceVerifyPrimaryKeyPolicy tk =- if primaryKeyTooSmallForVerification tk- then Nothing- else Just tk--primaryKeyTooSmallForVerification :: SomeTK -> Bool-primaryKeyTooSmallForVerification stk =- case _pkalgo pkp of- RSA -> rsaTooSmall- DeprecatedRSASignOnly -> rsaTooSmall- DeprecatedRSAEncryptOnly -> rsaTooSmall- _ -> False- where- pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk))- rsaTooSmall =- case pubkeySize (_pubkey pkp) of- Right bits -> bits < 2048- Left _ -> False--primaryKeyIdentity- :: SomeTK -> Maybe (Fingerprint, EightOctetKeyId)-primaryKeyIdentity stk = do- let pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk))- keyId <- either (const Nothing) Just (eightOctetKeyID pkp)- pure (fingerprint pkp, keyId)--sanitizeBindingSignature- :: Fingerprint- -> EightOctetKeyId- -> SignaturePayload- -> Maybe SignaturePayload-sanitizeBindingSignature _ _ sig- | hasUnsupportedCriticalSubpacket sig = Nothing- | hasUnsupportedCriticalEmbeddedBacksig sig = Nothing- | otherwise = Just sig- where- hasUnsupportedCriticalSubpacket sp =- any isUnsupportedCriticalSubpacket (signatureHashedSubpackets sp)- hasUnsupportedCriticalEmbeddedBacksig sp =- any- ( \ssp ->- case _sspPayload ssp of- EmbeddedSignature embedded ->- any- isUnsupportedCriticalSubpacket- (signatureHashedSubpackets embedded)- _ -> False- )- (signatureHashedSubpackets sp)- isUnsupportedCriticalSubpacket (SigSubPacket isCritical payload) =- isCritical- && case payload of- UserDefinedSigSub {} -> True- OtherSigSub {} -> True- NotationData {} -> True- _ -> False--loadDecryptRecipientKeys- :: POSIXTime- -> String- -> [String]- -> [BL.ByteString]- -> IO [PKESKRecipientKey]-loadDecryptRecipientKeys _ _ [] _ = pure []-loadDecryptRecipientKeys cpt context keyFiles passwords = concat <$> mapM loadRecipientKeyFile keyFiles- where- loadRecipientKeyFile path = do- packets <- loadOpenPGPPackets context path- -- Build the set of fingerprints that are explicitly non-encryption-capable.- -- Keys not resolvable via TK (processTK failure, bare material) are allowed.- nonEncFps <- buildNonEncryptionFingerprintSet packets- keys <-- mapM (packetRecipientKey path nonEncFps) packets- >>= pure . catMaybes- let brokenSecretKeyErrors =- nub- [ err- | BrokenPacketPkt err tag _ <- packets- , tag == 5 || tag == 7- ]- when (null keys && not (null brokenSecretKeyErrors)) $- failWith- CannotDecrypt- ( "decrypt failed: could not load usable secret key material from "- ++ path- ++ " ("- ++ intercalate "; " brokenSecretKeyErrors- ++ ")"- )- pure keys- -- Build a set of fingerprints that are EXPLICITLY non-encryption-capable.- -- Only keys whose binding signature carries a KeyFlags subpacket that does- -- NOT include any encryption bit are added. Keys with no binding-sig TK- -- (processTK failed, bare secret material, etc.) are NOT blocked — we fall- -- back to allowing them so that newly-generated or unusual keys still work.- buildNonEncryptionFingerprintSet packets = do- tks <-- runConduitRes $- CL.sourceList packets- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- let normTks = rights (map (processTK (Just cpt)) tks)- let tkDerived = S.fromList (concatMap nonEncryptionFingerprints normTks)- rawDerived = S.fromList (explicitNonEncryptionSubkeyFingerprints packets)- return (S.union tkDerived rawDerived)- nonEncryptionFingerprints tk =- -- Primary key: add to blocklist only if explicit key-flags are present- -- and all of them exclude encryption usage.- let primaryPkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk))- primaryFp = unFingerprint (fingerprint primaryPkp)- publicView = someTKToPublicViewTK tk- primarySigs =- concatMap snd (_tkUIDs publicView)- ++ concatMap snd (_tkUAts publicView)- ++ _tkRevs publicView- primaryEntry = [primaryFp | not (sigsAllowEncryption primarySigs)]- -- Subkeys: same rule as primary.- subEntries =- [ unFingerprint (fingerprint pkp)- | (kp, sigs) <- _tkSubs publicView- , let pkp = keyPktPKPayload kp- , not (sigsAllowEncryption sigs)- ]- blocked = primaryEntry ++ subEntries- in if tkHasAnyEncryptionCapableKey tk- then blocked- else []- explicitNonEncryptionSubkeyFingerprints packets =- let (mPending, blocked) = foldl' step (Nothing, []) packets- in maybe- blocked- ( \(fp, hasEnc, sawKeyFlags) -> finalize fp hasEnc sawKeyFlags blocked- )- mPending- where- step (mPending, blocked) pkt =- case pkt of- PublicSubkeyPkt pkp ->- ( Just (unFingerprint (fingerprint pkp), False, False)- , finalizePending mPending blocked- )- SecretSubkeyPkt pkp _ ->- ( Just (unFingerprint (fingerprint pkp), False, False)- , finalizePending mPending blocked- )- SignaturePkt sig ->- case mPending of- Nothing -> (Nothing, blocked)- Just (fp, hasEnc, sawKeyFlags) ->- let usableSig =- if signatureHasUnsupportedCriticalSubpackets sig- then []- else keyFlagsFromSig sig- hasEnc' = hasEnc || any hasEncryptionFlag usableSig- sawKeyFlags' = sawKeyFlags || not (null usableSig)- in (Just (fp, hasEnc', sawKeyFlags'), blocked)- _ -> (Nothing, finalizePending mPending blocked)- finalizePending Nothing blocked = blocked- finalizePending (Just (fp, hasEnc, sawKeyFlags)) blocked =- finalize fp hasEnc sawKeyFlags blocked- finalize fp hasEnc sawKeyFlags blocked- | sawKeyFlags && not hasEnc = fp : blocked- | otherwise = blocked- tkHasAnyEncryptionCapableKey tk =- let primaryPkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk))- publicView = someTKToPublicViewTK tk- primarySigs =- concatMap snd (_tkUIDs publicView)- ++ concatMap snd (_tkUAts publicView)- ++ _tkRevs publicView- primaryAllows =- supportsRecipientPKESKAlgorithm primaryPkp- && sigsAllowEncryption primarySigs- subAllows =- any- ( \(kp, sigs) ->- supportsRecipientPKESKAlgorithm (keyPktPKPayload kp)- && sigsAllowEncryption sigs- )- (_tkSubs publicView)- in primaryAllows || subAllows- sigsAllowEncryption [] = True- sigsAllowEncryption sigs =- let usableSigs = filter (not . signatureHasUnsupportedCriticalSubpackets) sigs- flagSets = concatMap keyFlagsFromSig usableSigs- in if null usableSigs- then False- else null flagSets || any hasEncryptionFlag flagSets- hasEncryptionFlag flags =- S.member EncryptCommunicationsKey flags- || S.member EncryptStorageKey flags- keyFlagsFromSig sig =- case sig of- SigV4 _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds- SigV6 _ _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds- _ -> []- signatureHasUnsupportedCriticalSubpackets sig =- let hasheds =- case sig of- SigV4 _ _ _ hs _ _ _ -> hs- SigV6 _ _ _ _ hs _ _ _ -> hs- _ -> []- in any isUnsupportedCritical hasheds- isUnsupportedCritical (SigSubPacket isCritical payload) =- isCritical- && case payload of- OtherSigSub {} -> True- UserDefinedSigSub {} -> True- NotationData {} -> True- _ -> False- keyFlagsFromSubpackets subpackets =- [ flags- | SigSubPacket _ (KeyFlags flags) <- subpackets- ]- packetRecipientKey path nonEncFps (SecretKeyPkt pkp ska) =- let fp = unFingerprint (fingerprint pkp)- in if S.member fp nonEncFps- then pure Nothing- else decryptRecipientKey path pkp ska- packetRecipientKey path nonEncFps (SecretSubkeyPkt pkp ska) =- let fp = unFingerprint (fingerprint pkp)- in if S.member fp nonEncFps- then pure Nothing- else decryptRecipientKey path pkp ska- packetRecipientKey _ _ _ = pure Nothing- decryptRecipientKey path pkp ska =- case secretKeyProtectionPolicyViolation pkp ska of- Just violation ->- failWith- KeyIsProtected- ( "decrypt failed: unsupported secret key protection in "- ++ path- ++ " ("- ++ violation- ++ ")"- )- Nothing ->- case ska of- SUUnencrypted skey _ ->- pure- ( Just- ( PKESKRecipientKey- { pkeskRecipientPKPayload = Just pkp- , pkeskRecipientSKey = skey- }- )- )- _ ->- case passwords of- [] ->- failWith- KeyIsProtected- ( "decrypt failed: encrypted key in "- ++ path- ++ " requires --with-key-password"- )- _ ->- case tryDecryptKey passwords of- Left _ ->- failWith- KeyIsProtected- ( "decrypt failed: could not decrypt key in "- ++ path- ++ " with provided --with-key-password values"- )- Right (SUUnencrypted skey _) ->- pure- ( Just- ( PKESKRecipientKey- { pkeskRecipientPKPayload = Just pkp- , pkeskRecipientSKey = skey- }- )- )- Right _ ->- failWith- KeyIsProtected- ("decrypt failed: unsupported secret key protection in " ++ path)- where- secretKeyProtectionPolicyViolation recipientPkp addendum =- let rejectArgon2WithoutAEAD s2k- | isArgon2S2K s2k =- Just "Argon2 S2K is only allowed with AEAD-protected secret keys"- | otherwise = Nothing- rejectSimpleForV6 s2k- | isSimpleS2K s2k =- Just "v6 secret key packets MUST NOT use simple S2K"- | otherwise = Nothing- in case addendum of- SUS16bit _ s2k _ _ ->- case _keyVersion recipientPkp of- V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k- _ -> rejectArgon2WithoutAEAD s2k- SUSSHA1 _ s2k _ _ ->- case _keyVersion recipientPkp of- V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k- _ -> rejectArgon2WithoutAEAD s2k- SUSym {} ->- if _keyVersion recipientPkp == V6- then- Just- "v6 secret key packets MUST NOT use legacy CFB secret-key protection"- else Nothing- _ -> Nothing- isArgon2S2K Argon2 {} = True- isArgon2S2K _ = False- isSimpleS2K (Simple _) = True- isSimpleS2K _ = False- tryDecryptKey [] = Left ()- tryDecryptKey (password : rest) =- case decryptPrivateKey (pkp, ska) password of- Left _ -> tryDecryptKey rest- Right decrypted -> Right decrypted--decodeOpenPGPInput :: String -> BL.ByteString -> IO [Pkt]-decodeOpenPGPInput path input = do- decodedArmors <-- decodeAsciiArmorInput ("OpenPGP input in " ++ path) input- case decodedArmors of- Just armors ->- case firstBy isOpenPGPArmorBlock armors of- Just (Armor _ _ bs) ->- parseOpenPGPPackets- ("armored OpenPGP input in " ++ path)- (BL.fromStrict (BLC8.toStrict bs))- _ ->- case firstBy isClearSignedArmor armors of- Just _ ->- failWith- BadData- ("Expected key data in " ++ path ++ ", got cleartext signature")- _ -> parseOpenPGPPackets "OpenPGP input" input- Nothing -> parseOpenPGPPackets "OpenPGP input" input--loadRecipientPreferredHashes- :: POSIXTime -> [String] -> IO [HashAlgorithm]-loadRecipientPreferredHashes cpt certFiles =- concat <$> mapM loadRecipientCertFile certFiles- where- loadRecipientCertFile path = do- pkts <- loadOpenPGPPackets "encrypt" path- rejectSecretKeyPackets "encrypt" path pkts- tks <-- runConduitRes $- CL.sourceList pkts- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- normalized <- mapM (normalizeRecipient path) tks- pure- (concatMap (effectiveHashPreferencesAt cpt) normalized)- normalizeRecipient path tk =- case processTK (Just cpt) tk of- Left err ->- failWith- BadData- ( "encrypt: invalid recipient certificate in "- ++ path- ++ ": "- ++ show err- )- Right normalized -> pure normalized--loadEncryptRecipients- :: POSIXTime -> EncryptFor -> [String] -> IO [FunKey]-loadEncryptRecipients cpt encPurpose certFiles = do- recipients <- concat <$> mapM loadRecipientsFromFile certFiles- if null recipients- then- failWith- CertCannotEncrypt- "encrypt: no supported recipient encryption keys found in provided certificates"- else pure recipients- where- loadRecipientsFromFile path = do- lbs <- loadInputFromFile "encrypt" "file" path- pkts <- decodeOpenPGPInput path lbs- rejectSecretKeyPackets "encrypt" path pkts- rejectCriticalUnknownRecipientPackets path pkts- tks <-- runConduitRes $- CL.sourceList pkts- .| conduitToSomeTKsDroppingEither- .| conduitDropErrorsAndNothings- .| CC.sinkList- normalized <- mapM (normalizeEncryptRecipientTK path) tks- let selected =- selectEncryptRecipients- encPurpose- (concatMap (tkToFunKeysAt cpt) normalized)- packetFallback =- nub- ( concatMap tkToEncryptPayloads normalized- ++ mapMaybe extractEncryptRecipientPayload pkts- )- pure $- case encPurpose of- EncryptForAny- | null selected -> map payloadToFunKey packetFallback- _ -> selected- normalizeEncryptRecipientTK path tk =- case processTK (Just cpt) tk of- Left err ->- failWith- BadData- ( "encrypt: invalid recipient certificate in "- ++ path- ++ ": "- ++ show err- )- Right normalized ->- if not- ( isTKTimeValid- (posixSecondsToUTCTime (realToFrac cpt))- (someTKToPublicViewTK normalized)- )- then- failWith- CertCannotEncrypt- ("encrypt: recipient certificate in " ++ path ++ " is expired")- else- if not (primaryUserIDExpirationAllowsAt cpt normalized)- then- failWith- CertCannotEncrypt- ("encrypt: recipient certificate in " ++ path ++ " is expired")- else pure normalized- rejectCriticalUnknownRecipientPackets path =- mapM_- ( \pkt ->- case pkt of- OtherPacketPkt tag _- | tag < 40 ->- if isForwardCompatRecipientPacketTag tag- then pure ()- else- failWith- BadData- ( "encrypt: invalid recipient certificate in "- ++ path- ++ ": critical unknown packet tag "- ++ show tag- )- BrokenPacketPkt _ tag _- | tag < 40 ->- if isForwardCompatRecipientPacketTag tag- then pure ()- else- failWith- BadData- ( "encrypt: invalid recipient certificate in "- ++ path- ++ ": critical unknown packet tag "- ++ show tag- )- _ -> pure ()- )- isForwardCompatRecipientPacketTag tag = tag `elem` [5, 6, 7, 14]- payloadToFunKey pkp = FunKey pkp Nothing S.empty [] [] False--primaryUserIDExpirationAllowsAt :: POSIXTime -> SomeTK -> Bool-primaryUserIDExpirationAllowsAt now tk =- case primaryUidSigs of- [] -> True- _ ->- any- (signatureKeyExpirationAllowsAt now primaryCreatedAt)- primaryUidSigs- where- publicView = someTKToPublicViewTK tk- primaryCreatedAt =- fromIntegral- (_timestamp (keyPktPKPayload (_tkPrimaryKey publicView)))- primaryUidSigs =- [ sig- | (_, sigs) <- _tkUIDs publicView- , sig <- sigs- , signatureMarksPrimaryUserId sig- ]--signatureMarksPrimaryUserId :: SignaturePayload -> Bool-signatureMarksPrimaryUserId sig =- any isPrimaryUIDSubpacket (signatureSubpackets sig)- where- isPrimaryUIDSubpacket (SigSubPacket _ (PrimaryUserId True)) = True- isPrimaryUIDSubpacket _ = False--signatureKeyExpirationAllowsAt- :: POSIXTime -> POSIXTime -> SignaturePayload -> Bool-signatureKeyExpirationAllowsAt now createdAt sig =- case signatureKeyValiditySeconds sig of- Nothing -> True- Just 0 -> True- Just validitySeconds -> now < createdAt + fromIntegral validitySeconds--signatureKeyValiditySeconds :: SignaturePayload -> Maybe Integer-signatureKeyValiditySeconds sig =- listToMaybe- [ fromIntegral secs- | SigSubPacket _ (KeyExpirationTime (ThirtyTwoBitDuration secs)) <-- signatureSubpackets sig- ]--selectEncryptRecipients :: EncryptFor -> [FunKey] -> [FunKey]-selectEncryptRecipients encPurpose keys =- chosen- where- supported = filter (supportsRecipientPKESKAlgorithm . fpkp) keys- (matchingPurpose, unrestrictedPurpose) =- partition (keyMatchesEncryptPurpose encPurpose . fkufs) supported- chosen =- case encPurpose of- EncryptForAny- | null matchingPurpose -> unrestrictedPurpose- _ -> matchingPurpose--tkToEncryptPayloads :: SomeTK -> [SomePKPayload]-tkToEncryptPayloads stk =- filter- supportsRecipientPKESKAlgorithm- (someTKToUnknown stk ^.. biplate :: [SomePKPayload])--extractEncryptRecipientPayload :: Pkt -> Maybe SomePKPayload-extractEncryptRecipientPayload pkt =- case pkt of- PublicKeyPkt pkp- | supportsRecipientPKESKAlgorithm pkp -> Just pkp- PublicSubkeyPkt pkp- | supportsRecipientPKESKAlgorithm pkp -> Just pkp- SecretKeyPkt pkp _- | supportsRecipientPKESKAlgorithm pkp -> Just pkp- SecretSubkeyPkt pkp _- | supportsRecipientPKESKAlgorithm pkp -> Just pkp- _ -> Nothing--keyMatchesEncryptPurpose :: EncryptFor -> S.Set KeyFlag -> Bool-keyMatchesEncryptPurpose encPurpose keyFlags =- not (S.null (keyFlags `S.intersection` encryptUsageFlags))- where- encryptUsageFlags =- case encPurpose of- EncryptForAny -> S.fromList [EncryptStorageKey, EncryptCommunicationsKey]- EncryptForStorage -> S.singleton EncryptStorageKey- EncryptForCommunications -> S.singleton EncryptCommunicationsKey--supportsRecipientPKESKAlgorithm :: SomePKPayload -> Bool-supportsRecipientPKESKAlgorithm pkp =- _pkalgo pkp- `elem` [ RSA- , DeprecatedRSAEncryptOnly- , ElgamalEncryptOnly- , ECDH- , X25519- , X448- ]- && hasSupportedRecipientIdentifierLength pkp--hasSupportedRecipientIdentifierLength :: SomePKPayload -> Bool-hasSupportedRecipientIdentifierLength pkp =- let keyIdentifierLen = BL.length (unFingerprint (fingerprint pkp))- in keyIdentifierLen == 16- || keyIdentifierLen == 20- || keyIdentifierLen == 32--sopFailureForPKESKEncryptError :: PKESKEncryptError -> SopFailure-sopFailureForPKESKEncryptError err =- case err of- UnsupportedRecipientAlgorithm _ -> UnsupportedAsymmetricAlgo- RecipientCapabilitySelectionFailure _ -> CertCannotEncrypt- NoRecipientsProvided -> CertCannotEncrypt- _ -> BadData--{- | Resolve a PKESK recipient key using two strategies depending on whether-the probe carries a wildcard recipient ID (eight zero bytes) or a real key-ID / fingerprint.--* Non-wildcard probes: the callback is invoked once for each PKESK attempt,- so we do an idempotent lookup by recipient identifier from the full- candidate list to avoid consuming keys needed by later PKESKs.--* Wildcard probes (all-zero legacy recipient ID): hOpenPGP retries the- callback after failed unwrap attempts. We therefore pop one candidate from- a shared queue on each callback invocation.--}-selectRecipientKeyInfosByRecipientIdentifier- :: [PKESKRecipientKey]- -> KeyIdentifier- -> PubKeyAlgorithm- -> IO [PKESKRecipientKey]-selectRecipientKeyInfosByRecipientIdentifier keyInfos keyIdentifier pka =- pure $- case keyIdentifier of- KeyIdentifierWildcard -> compatible- KeyIdentifierEightOctet recipientKeyId ->- filter (matchesLegacyRecipientKeyId recipientKeyId) compatible- KeyIdentifierFingerprint recipientFingerprint ->- filter- (matchesRecipientIdentifier (unFingerprint recipientFingerprint))- compatible- where- compatible =- [ keyInfo- | keyInfo <- keyInfos- , supportsPKESKAlgorithm pka keyInfo- ]--prioritizeDecryptablePKESKs- :: [PKESKRecipientKey] -> [Pkt] -> [Pkt]-prioritizeDecryptablePKESKs keyInfos pkts =- nonMatchingPrefix ++ matchingPrefix ++ suffix- where- (prefix, suffix) = break isEncryptedPayloadPacket pkts- (matchingPrefix, nonMatchingPrefix) =- partition- ( \pkt ->- case pkt of- PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)) ->- any (matchesRecipientIdentifier rid) keyInfos- PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ eoki _ _)) ->- any (matchesLegacyRecipientKeyId eoki) keyInfos- _ -> False- )- prefix--supportsPKESKAlgorithm- :: PubKeyAlgorithm -> PKESKRecipientKey -> Bool-supportsPKESKAlgorithm pka keyInfo =- case pkeskRecipientSKey keyInfo of- RSAPrivateKey {} -> pka == RSA || pka == DeprecatedRSAEncryptOnly- ElGamalPrivateKey {} -> pka == ElgamalEncryptOnly- ECDHPrivateKey {} -> pka == ECDH || pka == X25519- X25519PrivateKey {} -> pka == X25519- X448PrivateKey {} -> pka == X448- UnknownSKey {} ->- (pka == X25519 || pka == X448)- && case pkeskRecipientPKPayload keyInfo of- Just pkp -> _pkalgo pkp == pka- Nothing -> False- _ -> False--matchesRecipientIdentifier- :: BL.ByteString -> PKESKRecipientKey -> Bool-matchesRecipientIdentifier rid keyInfo =- case pkeskRecipientPKPayload keyInfo of- Nothing -> False- Just pkp ->- let identifier = BL.toStrict rid- fps = recipientFingerprintsForMatch pkp- in any (identifier `elem`) (map recipientIdMatchVariants fps)--recipientFingerprintsForMatch :: SomePKPayload -> [B.ByteString]-recipientFingerprintsForMatch pkp =- baseFp : maybeToList normalizedX25519Fp- where- baseFp = BL.toStrict (unFingerprint (fingerprint pkp))- normalizedX25519Fp =- BL.toStrict . unFingerprint . fingerprint- <$> normalizeX25519CompatiblePKP pkp--normalizeX25519CompatiblePKP- :: SomePKPayload -> Maybe SomePKPayload-normalizeX25519CompatiblePKP pkp =- case _pubkey pkp of- ECDHPubKey (EdDSAPubKey EdSigningCurve25519 _) _ _ ->- Just- ( PKPayload- (_keyVersion pkp)- (_timestamp pkp)- (_v3exp pkp)- X25519- (_pubkey pkp)- )- _ -> Nothing--recipientIdMatchVariants :: B.ByteString -> [B.ByteString]-recipientIdMatchVariants fp =- [ fp- , B.cons 0x04 fp- , B.cons 0x06 fp- , B.cons 0xFE fp- ]--matchesLegacyRecipientKeyId- :: EightOctetKeyId -> PKESKRecipientKey -> Bool-matchesLegacyRecipientKeyId eoki keyInfo =- case pkeskRecipientPKPayload keyInfo of- Nothing -> False- Just pkp ->- case eightOctetKeyID pkp of- Right keyId -> keyId == eoki- Left _ -> False--decodeCiphertextInput :: BL.ByteString -> IO BL.ByteString-decodeCiphertextInput input = do- decodedArmors <- decodeAsciiArmorInput "decrypt input" input- case decodedArmors of- Just armors ->- case firstBy isArmorMessageBlock armors of- Just (Armor ArmorMessage _ bs) -> return (BL.fromStrict (BLC8.toStrict bs))- _ ->- case firstBy isOpenPGPArmorBlock armors of- Just _ ->- failWith- BadData- "decrypt expects an armored OpenPGP message"- _ -> return input- Nothing -> return input--doInlineSign :: POSIXTime -> InlineSignOptions -> IO ()-doInlineSign pt InlineSignOptions {..} = do- let inlineMode = fromMaybe InlineSignAsBinary inlineSignAs- mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume- when (inlineMode /= InlineSignAsBinary) $- ensureUTF8TextInput "inline-sign" (BL.fromChunks mbs)- signingPasswordsRaw <-- loadPasswordFiles- "inline-sign"- "--with-key-password"- inlineSignKeyPasswords- let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw- ks <-- loadSigningKeys "inline-sign" inlineSignKeyFiles signingPasswords- processedKeys <- mapM (normalizeSigningKey pt) ks- let ts = ThirtyTwoBitTimeStamp (floor pt)- payloadRaw = BL.fromChunks mbs- funkeys = concatMap (tkToFunKeysAt pt) processedKeys- signingKeys = filter isInlineRSASigner funkeys- inlineSignHash =- selectSigningHash signingKeys [] legacySigningHashFallbackOrder- when (null signingKeys) $- failWith MissingInput "inline-sign: no signing-capable key found"- sigs <-- mapM- ( signInlineData- ts- (inlineSignSignatureMode inlineMode)- inlineSignHash- payloadRaw- )- signingKeys- case inlineMode of- InlineSignAsClearSigned -> doInlineSignCleartext inlineSignHash payloadRaw sigs- InlineSignAsText -> doInlineSignText payloadRaw sigs- InlineSignAsBinary -> doInlineSignBinary payloadRaw sigs- where- inlineSignSignatureMode mode =- case mode of- InlineSignAsBinary -> AsBinary- InlineSignAsText -> AsText- InlineSignAsClearSigned -> AsText- doInlineSignCleartext inlineSignHash payloadRaw sigs = do- when inlineSignNoArmor $- failWith- IncompatibleOptions- "inline-sign --as=clearsigned requires armored output"- let cleartextPayload =- if not (BL.null payloadRaw) && BL.last payloadRaw == 0x0a- then payloadRaw <> BL.singleton 0x0a- else payloadRaw- sigBytes = runPut $ mapM_ (Bin.put . SignaturePkt) sigs- hashHeader = ("Hash", hashAlgorithmHeaderName inlineSignHash)- clearSigned =- ClearSigned- [hashHeader]- (BLC8.fromStrict (BL.toStrict cleartextPayload))- (Armor ArmorSignature [] (BLC8.fromStrict (BL.toStrict sigBytes)))- BLC8.putStr (AA.encodeLazy [clearSigned])- doInlineSignText payloadRaw sigs =- doInlineSignMessage UTF8Data payloadRaw sigs- doInlineSignBinary payloadRaw sigs = do- doInlineSignMessage BinaryData payloadRaw sigs- doInlineSignMessage literalDataType payloadRaw sigs = do- let pktBytes =- runPut $- Bin.put- ( Block- ( map SignaturePkt sigs- ++ [LiteralDataPkt literalDataType (FileName B.empty) 0 payloadRaw]- )- )- BL.putStr $- if not inlineSignNoArmor- then AA.encodeLazy [Armor ArmorMessage [] pktBytes]- else pktBytes--inlineSignModeReader :: String -> Either String InlineSignMode-inlineSignModeReader "binary" = Right InlineSignAsBinary-inlineSignModeReader "text" = Right InlineSignAsText-inlineSignModeReader "clearsigned" = Right InlineSignAsClearSigned-inlineSignModeReader _ =- Left "signature mode must be one of: binary, text, clearsigned"--isInlineSigningCapable :: FunKey -> Bool-isInlineSigningCapable k =- (S.null (fkufs k) || S.member SignDataKey (fkufs k))- && case fmska k of- Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True- Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True- Just (SUUnencrypted (Ed25519PrivateKey _) _) -> True- Just (SUUnencrypted (Ed448PrivateKey _) _) -> True- Just (SUUnencrypted (UnknownSKey _) _) ->+ ( TKGen+ , addSubkey+ , addUID+ , newKey+ , runTKGen+ , setAEADPreferences+ , setCompressionPreferences+ , setFeatures+ , setHashPreferences+ , setKeySize+ , setSEIPDv1SymmetricPreferences+ )+import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)+import Codec.Encryption.OpenPGP.Message+ ( EncryptMessageOptions (..)+ , RecoveredSessionMaterial (..)+ , SessionMaterialExposure (..)+ , encryptMessage+ , encryptedPayloadBytes+ , mkClearPayload+ )+import Codec.Encryption.OpenPGP.Ontology+ ( isKUF+ , isPKBindingSig+ , isSKBindingSig+ )+import Codec.Encryption.OpenPGP.Policy+ ( defaultDecryptPolicy+ , defaultPolicy+ , defaultVerificationPolicy+ , lenientDecryptPolicy+ )+import Codec.Encryption.OpenPGP.S2K+ ( decodeOpenPGPEncodedSessionKey+ , renderS2KError+ , skesk2Key+ , skesk2SessionKey+ , string2Key+ )+import Codec.Encryption.OpenPGP.SecretKey+ ( SecretKeyEncryptOptions (..)+ , decryptSecretKeyAddendum+ , encryptSecretKeyWithPolicy+ , reencryptSecretKey+ , renderSecretKeyError+ )+import Codec.Encryption.OpenPGP.Serialize+ ( parsePkts+ , putSKeyForPKPayload+ )+import Codec.Encryption.OpenPGP.Signatures+ ( SignError (..)+ , renderSignError+ , signDataWithEd25519+ , signDataWithEd25519Legacy+ , signDataWithEd25519V6+ , signDataWithEd448+ , signDataWithEd448V6+ , signDataWithRSABuilder+ , signDataWithRSAV6Builder+ , signDirectKey+ , signSubkeyBinding+ , signSubkeyRevocation+ , signUat+ , signUserId+ )+import qualified Codec.Encryption.OpenPGP.Subpackets as SP+import Codec.Encryption.OpenPGP.Types+import qualified Codec.Encryption.OpenPGP.Version as HOV+import Control.Applicative (many, optional, some, (<|>))+import Control.Error.Util (note)+import Control.Exception+ ( IOException+ , SomeException+ , catch+ , displayException+ , evaluate+ , throwIO+ )+import Control.Lens ((^..))+import Control.Monad (forM, forM_, unless, when, (>=>))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.State.Lazy ()+import Control.Monad.Trans.Except ()+import Crypto.Error (eitherCryptoError)+import qualified Crypto.Hash as CH+import qualified Crypto.Hash.Algorithms as CHA+import Crypto.Number.Serialize (i2ospOf_, os2ip)+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448+import qualified Crypto.PubKey.RSA as RSA+import qualified Crypto.PubKey.RSA.PKCS15 as P15+import Crypto.Random.Types (getRandomBytes)+import qualified Data.Aeson as A+import Data.Bifunctor (first)+import qualified Data.Binary as Bin+import Data.Binary.Get (runGet)+import Data.Binary.Put+ ( runPut+ )+import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC8+import Data.Char (digitToInt, isHexDigit, isSpace, toLower)+import Data.Conduit (fuseBoth, runConduitRes, (.|))+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.List as CL+import Data.Conduit.OpenPGP.Decrypt+ ( DecryptKeyResolution (..)+ , DecryptOutcome (..)+ , PKESKRecipientKey (..)+ , renderDecryptStructureError+ )+import qualified Data.Conduit.OpenPGP.Decrypt as Decrypt+import Data.Conduit.OpenPGP.Keyring+ ( conduitDropErrorsAndNothings+ , conduitToSomeTKsDroppingEither+ , sinkPublicKeyringMap+ )+import Data.Conduit.OpenPGP.Verify+ ( conduitVerify+ , verifyPacketsBatch+ )+import Data.Data.Lens (biplate)+import Data.Either (fromRight, isLeft, isRight, rights)+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.List+ ( find+ , findIndex+ , intercalate+ , isInfixOf+ , isPrefixOf+ , isSuffixOf+ , nub+ , partition+ , stripPrefix+ )+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe+ ( catMaybes+ , fromMaybe+ , isJust+ , listToMaybe+ , mapMaybe+ , maybeToList+ )+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Text.Encoding.Error (lenientDecode)+import Data.Time.Clock (NominalDiffTime, UTCTime)+import Data.Time.Clock.POSIX+ ( POSIXTime+ , getPOSIXTime+ , posixSecondsToUTCTime+ , utcTimeToPOSIXSeconds+ )+import Data.Time.Format (defaultTimeLocale, formatTime)+import Data.Time.Format.ISO8601 (iso8601ParseM)+import qualified Data.Vector as V+import Data.Version (showVersion)+import Data.Word (Word8)+import GHC.Generics+import Options.Applicative.Builder+ ( argument+ , command+ , eitherReader+ , footerDoc+ , headerDoc+ , help+ , helpDoc+ , info+ , long+ , metavar+ , option+ , prefs+ , progDesc+ , showHelpOnError+ , str+ , strArgument+ , strOption+ , switch+ , value+ )+import Options.Applicative.Extra+ ( execParserPure+ , helper+ , hsubparser+ , renderFailure+ )+import Options.Applicative.Types+ ( CompletionResult (..)+ , Parser+ , ParserResult (..)+ )+import Prettyprinter+ ( list+ , pretty+ , softline+ )+import Prettyprinter.Render.Text (hPutDoc)+import System.Directory (doesFileExist)+import System.Environment (getArgs, getProgName, lookupEnv)+import System.Exit+ ( ExitCode (..)+ , exitSuccess+ , exitWith+ )+import System.IO+ ( BufferMode (..)+ , Handle+ , hPutStrLn+ , hSetBuffering+ , stderr+ , stdin+ )+import Text.Read (readMaybe)++import HOpenPGP.Tools.Common.Armor (doDeArmor)+import HOpenPGP.Tools.Common.Common+ ( banner+ , keyMatchesEightOctetKeyId+ , keyMatchesFingerprint+ , versioner+ , warranty+ )+import HOpenPGP.Tools.Common.TKUtils+ ( processTK+ , verifyTKWithTyped+ )+import Paths_hopenpgp_tools (version)++data Command+ = VersionC VersionOptions+ | ListProfilesC ListProfilesOptions+ | GenerateKeyC KeyGenOptions+ | ChangeKeyPasswordC ChangeKeyPasswordOptions+ | MergeCertsC MergeCertsOptions+ | ValidateUserIdC ValidateUserIdOptions+ | CertifyUserIdC CertifyUserIdOptions+ | RevokeKeyC RevokeKeyOptions+ | UpdateKeyC UpdateKeyOptions+ | VerifyC VerifyOptions+ | InlineVerifyC InlineVerifyOptions+ | EncryptC EncryptOptions+ | DecryptC DecryptOptions+ | InlineSignC InlineSignOptions+ | InlineDetachC InlineDetachOptions+ | ExtractCertC ExtractCertOptions+ | SignC SignOptions+ | UnsupportedC String+ | DeArmorC+ | ArmorC++data OutputFormat+ = Unstructured+ | JSON+ | YAML+ deriving (Eq, Read, Show)++data VerifyOptions+ = VerifyOptions+ { verifyNotBefore :: Maybe String+ , verifyNotAfter :: Maybe String+ , verifySigFile :: String+ , verifyCertFiles :: [String]+ }++data InlineVerifyOptions+ = InlineVerifyOptions+ { inlineNotBefore :: Maybe String+ , inlineNotAfter :: Maybe String+ , verificationsOut :: Maybe String+ , inlineCertFiles :: [String]+ }++data EncryptOptions+ = EncryptOptions+ { encNoArmor :: Bool+ , encProfile :: Maybe String+ , encAs :: AsBinaryText+ , encSignWithKeyFiles :: [String]+ , encSignWithKeyPasswords :: [String]+ , encSessionKeyOutFile :: Maybe String+ , encFor :: EncryptFor+ , encPasswords :: [String]+ , encRecipientCerts :: [String]+ }++data EncryptProfile+ = EncryptProfileRFC9580+ | EncryptProfileRFC4880+ deriving (Eq)++data Profile p = Profile+ { profileName :: String+ , profileDescription :: String+ , profileValue :: p+ , profileAliases :: [String]+ }++encryptProfiles :: [Profile EncryptProfile]+encryptProfiles =+ [ Profile+ "rfc9580"+ "SEIPDv2"+ EncryptProfileRFC9580+ ["default", "security", "performance"]+ , Profile+ "rfc4880"+ "SEIPDv1"+ EncryptProfileRFC4880+ ["compatibility"]+ ]++data DecryptOptions+ = DecryptOptions+ { decNoArmor :: Bool+ , decVerifyNotBefore :: Maybe String+ , decVerifyNotAfter :: Maybe String+ , decSessionKeys :: [String]+ , decSessionKeyOutFile :: Maybe String+ , decPasswords :: [String]+ , decKeyPasswords :: [String]+ , decKeyFiles :: [String]+ , decVerifyCerts :: [String]+ , decVerificationsOutFile :: Maybe String+ }++data InlineSignOptions+ = InlineSignOptions+ { inlineSignNoArmor :: Bool+ , inlineSignAs :: Maybe InlineSignMode+ , inlineSignKeyFiles :: [String]+ , inlineSignKeyPasswords :: [String]+ }++data InlineDetachOptions+ = InlineDetachOptions+ { inlineDetachNoArmor :: Bool+ , inlineDetachOutputSigs :: String+ }++data ChangeKeyPasswordOptions+ = ChangeKeyPasswordOptions+ { changeKeyPasswordNoArmor :: Bool+ , changeKeyPasswordOldPasswords :: [String]+ , changeKeyPasswordNewPassword :: Maybe String+ }++data MergeCertsOptions+ = MergeCertsOptions+ { mergeCertsNoArmor :: Bool+ , mergeCertsFiles :: [String]+ }++data ValidateUserIdOptions+ = ValidateUserIdOptions+ { validateUserIdAddrSpecOnly :: Bool+ , validateUserIdAt :: Maybe String+ , validateUserIdString :: String+ , validateUserIdAuthorityFiles :: [String]+ }++data CertifyUserIdOptions+ = CertifyUserIdOptions+ { certifyUserIds :: [String]+ , certifyUserIdNoArmor :: Bool+ , certifyUserIdNoRequireSelfSig :: Bool+ , certifyUserIdKeyPasswordFiles :: [String]+ , certifyUserIdSignerFiles :: [String]+ }++data RevokeKeyOptions+ = RevokeKeyOptions+ { revokeKeyNoArmor :: Bool+ , revokeKeyPasswordFiles :: [String]+ }++data UpdateKeyOptions+ = UpdateKeyOptions+ { updateKeyNoArmor :: Bool+ , updateKeySigningOnly :: Bool+ , updateKeyRevokeDeprecatedKeys :: Bool+ , updateKeyNoAddedCapabilities :: Bool+ , updateKeyPasswordFiles :: [String]+ , updateKeyMergeCerts :: [String]+ }++newtype ListProfilesOptions+ = ListProfilesOptions+ { profileSubcommand :: String+ }++data VersionOptions+ = VersionOptions+ { vBackend :: Bool+ , vExtended :: Bool+ , vSopSpec :: Bool+ , vSopv :: Bool+ }++data CliOptions+ = CliOptions+ { cliDebug :: Bool+ , cliCommand :: Command+ }++data SopFailure+ = MissingArg+ | IncompleteVerification+ | BadData+ | PasswordNotHumanReadable+ | ExpectedText+ | CannotDecrypt+ | UnsupportedAsymmetricAlgo+ | CertCannotEncrypt+ | UnsupportedOption+ | OutputExists+ | MissingInput+ | NoSignature+ | KeyIsProtected+ | KeyCannotSign+ | UnsupportedSpecialPrefix+ | IncompatibleOptions+ | UnsupportedProfile+ | UnsupportedSubcommand+ | PrimaryKeyBad+ | CertUserIdNoMatch+ | KeyCannotCertify++failureCode :: SopFailure -> Int+failureCode MissingArg = 19+failureCode IncompleteVerification = 23+failureCode BadData = 41+failureCode PasswordNotHumanReadable = 31+failureCode ExpectedText = 53+failureCode CannotDecrypt = 29+failureCode UnsupportedAsymmetricAlgo = 13+failureCode CertCannotEncrypt = 17+failureCode UnsupportedOption = 37+failureCode OutputExists = 59+failureCode MissingInput = 61+failureCode NoSignature = 3+failureCode KeyIsProtected = 67+failureCode KeyCannotSign = 79+failureCode UnsupportedSpecialPrefix = 71+failureCode IncompatibleOptions = 83+failureCode UnsupportedProfile = 89+failureCode UnsupportedSubcommand = 69+failureCode PrimaryKeyBad = 103+failureCode CertUserIdNoMatch = 107+failureCode KeyCannotCertify = 109++failWith :: MonadIO m => SopFailure -> String -> m a+failWith f msg = liftIO $ do+ BLC8.hPutStrLn stderr (BLC8.pack msg)+ exitWith (ExitFailure (failureCode f))++voP :: Parser VerifyOptions+voP =+ VerifyOptions+ <$> optional+ ( strOption+ ( long "not-before"+ <> metavar "DATE"+ <> help "ignore signatures before DATE"+ )+ )+ <*> optional+ ( strOption+ ( long "not-after"+ <> metavar "DATE"+ <> help "ignore signatures after DATE"+ )+ )+ <*> argument str (metavar "SIGNATURES" <> sigHelp)+ <*> some (strArgument (metavar "CERTS..." <> certHelp))+ where+ sigHelp =+ helpDoc . Just $+ pretty "file containing OpenPGP signatures"+ certHelp =+ helpDoc . Just $+ pretty "one or more certificate files"++ivoP :: Parser InlineVerifyOptions+ivoP =+ InlineVerifyOptions+ <$> optional+ ( strOption+ ( long "not-before"+ <> metavar "DATE"+ <> help "ignore signatures before DATE"+ )+ )+ <*> optional+ ( strOption+ ( long "not-after"+ <> metavar "DATE"+ <> help "ignore signatures after DATE"+ )+ )+ <*> optional+ ( strOption+ ( long "verifications-out"+ <> metavar "VERIFICATIONS"+ <> help "write verification records to file"+ )+ )+ <*> some (strArgument (metavar "CERTS..." <> certHelp))+ where+ certHelp =+ helpDoc . Just $+ pretty "one or more certificate files"++lpoP :: Parser ListProfilesOptions+lpoP =+ ListProfilesOptions+ <$> strArgument+ (metavar "SUBCOMMAND" <> help "subcommand to list profiles for")++vopP :: Parser VersionOptions+vopP =+ VersionOptions+ <$> switch+ (long "backend" <> help "show backend implementation version")+ <*> switch+ (long "extended" <> help "show extended version information")+ <*> switch (long "sop-spec" <> help "show targeted sop draft")+ <*> switch+ (long "sopv" <> help "show implemented sopv subset version")++encP :: Parser EncryptOptions+encP =+ EncryptOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> optional+ (strOption (long "profile" <> help "encryption profile"))+ <*> option+ (eitherReader asTypeReader)+ (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)+ <*> many+ (strOption (long "sign-with" <> help "signing key material"))+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking signing key material"+ )+ )+ <*> optional+ ( strOption+ ( long "session-key-out"+ <> metavar "SESSIONKEY"+ <> help "write generated session key to file"+ )+ )+ <*> option+ (eitherReader encryptForReader)+ ( long "for"+ <> metavar "ENCRYPTION_PURPOSE"+ <> help+ "select recipient key purpose (any, storage, communications)"+ <> value EncryptForAny+ )+ <*> many+ ( strOption+ (long "with-password" <> help "symmetric encryption password")+ )+ <*> many+ ( strArgument+ (metavar "CERT" <> help "recipient certificate files")+ )+ where+ astypeHelp =+ helpDoc . Just $+ pretty "what to treat the input as"+ <> softline+ <> list (map (pretty . fst) asTypes)++decP :: Parser DecryptOptions+decP =+ DecryptOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> optional+ ( strOption+ ( long "verify-not-before"+ <> metavar "DATE"+ <> help "ignore signatures before DATE when decrypting"+ )+ )+ <*> optional+ ( strOption+ ( long "verify-not-after"+ <> metavar "DATE"+ <> help "ignore signatures after DATE when decrypting"+ )+ )+ <*> many+ ( strOption+ (long "with-session-key" <> help "session key for decryption")+ )+ <*> optional+ ( strOption+ (long "session-key-out" <> help "write recovered session key")+ )+ <*> many+ ( strOption+ (long "with-password" <> help "password for SKESK decryption")+ )+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking decryption key material"+ )+ )+ <*> many (strArgument (metavar "KEY" <> help "secret key material"))+ <*> many+ ( strOption+ ( long "verify-with"+ <> help "certificate(s) to verify signatures with"+ )+ )+ <*> optional+ ( strOption+ ( long "verifications-out"+ <> help "write verification results to file"+ )+ )++inlineSignP :: Parser InlineSignOptions+inlineSignP =+ InlineSignOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> optional+ ( option+ (eitherReader inlineSignModeReader)+ (long "as" <> metavar "DATATYPE" <> inlineSignAsHelp)+ )+ <*> some (strArgument (metavar "KEY" <> help "signing key file(s)"))+ <*> many+ ( strOption+ ( long "with-key-password"+ <> metavar "PASSWORD"+ <> help "password for encrypted signing key"+ )+ )+ where+ inlineSignAsHelp =+ helpDoc . Just $+ pretty "what to treat the input as"+ <> softline+ <> list [pretty "binary", pretty "text", pretty "clearsigned"]++inlineDetachP :: Parser InlineDetachOptions+inlineDetachP =+ InlineDetachOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> strOption+ ( long "signatures-out"+ <> metavar "SIGNATURES"+ <> help "write detached signatures to file"+ )++mergeCertsP :: Parser MergeCertsOptions+mergeCertsP =+ MergeCertsOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> some+ ( strArgument+ (metavar "CERTS..." <> help "one or more certificate files")+ )++validateUserIdP :: Parser ValidateUserIdOptions+validateUserIdP =+ ValidateUserIdOptions+ <$> switch+ ( long "addr-spec-only"+ <> help+ "match only the addr-spec portion of conventional OpenPGP User IDs"+ )+ <*> optional+ ( strOption+ ( long "validate-at"+ <> metavar "DATE"+ <> help "evaluate certifications at DATE"+ )+ )+ <*> argument str (metavar "USERID" <> help "user ID to validate")+ <*> some+ ( strArgument+ ( metavar "CERTS..."+ <> help "one or more authority certificate files"+ )+ )++certifyUserIdP :: Parser CertifyUserIdOptions+certifyUserIdP =+ CertifyUserIdOptions+ <$> some+ ( strOption+ ( long "userid"+ <> metavar "USERID"+ <> help "user ID to certify (repeatable)"+ )+ )+ <*> switch+ ( long "no-armor"+ <> help "output binary"+ )+ <*> switch+ ( long "no-require-self-sig"+ <> help "allow certifying user IDs that do not have self-signatures"+ )+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking signer key material"+ )+ )+ <*> some+ ( strArgument+ (metavar "KEYS..." <> help "one or more signer key files")+ )++revokeKeyP :: Parser RevokeKeyOptions+revokeKeyP =+ RevokeKeyOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking secret key material"+ )+ )++updateKeyP :: Parser UpdateKeyOptions+updateKeyP =+ UpdateKeyOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> switch+ ( long "signing-only"+ <> help "limit updated material to signing-capable key material"+ )+ <*> switch+ ( long "revoke-deprecated-keys"+ <> help+ "emit revocations for deprecated key material when supported"+ )+ <*> switch+ ( long "no-added-capabilities"+ <> help+ "do not add capabilities beyond existing target key material"+ )+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking key material"+ )+ )+ <*> many+ ( strOption+ ( long "merge-certs"+ <> metavar "CERTS"+ <> help "additional certificate files to merge into target keys"+ )+ )++changeKeyPasswordP :: Parser ChangeKeyPasswordOptions+changeKeyPasswordP =+ ChangeKeyPasswordOptions+ <$> switch (long "no-armor" <> help "output binary")+ <*> many+ ( strOption+ ( long "old-key-password"+ <> help "password(s) used to unlock existing secret key material"+ )+ )+ <*> optional+ ( strOption+ ( long "new-key-password"+ <> help "password used to protect rewritten secret key material"+ )+ )++dispatch :: POSIXTime -> Command -> IO ()+dispatch cpt cmd' = dispatch' cpt cmd'+ where+ dispatch' _ (VersionC o') = doVersion o'+ dispatch' _ (ListProfilesC o') = doListProfiles o'+ dispatch' t (GenerateKeyC o) = doGenerateKey t o+ dispatch' _ (ChangeKeyPasswordC o) = doChangeKeyPassword o+ dispatch' _ (MergeCertsC o) = doMergeCerts o+ dispatch' t (ValidateUserIdC o) = doValidateUserId t o+ dispatch' t (CertifyUserIdC o) = doCertifyUserId t o+ dispatch' t (RevokeKeyC o) = doRevokeKey t o+ dispatch' t (UpdateKeyC o) = doUpdateKey t o+ dispatch' t (VerifyC o') = doVerify t o'+ dispatch' t (InlineVerifyC o') = doInlineVerify t o'+ dispatch' t (EncryptC o') = doEncrypt t o'+ dispatch' t (DecryptC o') = doDecrypt t o'+ dispatch' t (InlineSignC o') = doInlineSign t o'+ dispatch' t (InlineDetachC o') = doInlineDetach t o'+ dispatch' _ (ExtractCertC o) = doExtractCert o+ dispatch' t (SignC o) = doSign t o+ dispatch' _ (UnsupportedC c) =+ failWith+ UnsupportedSubcommand+ ("command not yet implemented: " ++ c)+ dispatch' _ DeArmorC = doDeArmor+ dispatch' _ ArmorC = doArmor++main :: IO ()+main = do+ hSetBuffering stderr LineBuffering+ args <- getArgs+ ensureKnownSubcommand knownSopSubcommands args+ cpt <- getPOSIXTime+ let result =+ execParserPure+ (prefs showHelpOnError)+ ( info+ (helper <*> versioner "hop" <*> cliP)+ ( headerDoc (Just (banner "hop"))+ <> progDesc "hOpenPGP SOP Tool"+ <> footerDoc (Just (warranty "hop"))+ )+ )+ args+ case result of+ Success cliOptions -> do+ let _ = cliDebug cliOptions+ dispatch cpt (cliCommand cliOptions)+ Failure f -> do+ let (msg, ec) = renderFailure f "hop"+ case ec of+ ExitSuccess -> putStrLn msg >> exitSuccess+ ExitFailure 1+ | "Invalid option" `isInfixOf` msg+ || "Invalid argument" `isInfixOf` msg ->+ hPutStrLn stderr msg >> exitWith (ExitFailure 37)+ | otherwise ->+ hPutStrLn stderr msg >> exitWith (ExitFailure 19)+ _ -> hPutStrLn stderr msg >> exitWith ec+ CompletionInvoked compl -> do+ progn <- getProgName+ msg <- execCompletion compl progn+ putStr msg+ exitSuccess++knownSopSubcommands :: [String]+knownSopSubcommands =+ [ "armor"+ , "dearmor"+ , "change-key-password"+ , "decrypt"+ , "encrypt"+ , "certify-userid"+ , "extract-cert"+ , "generate-key"+ , "inline-detach"+ , "inline-sign"+ , "inline-verify"+ , "list-profiles"+ , "merge-certs"+ , "revoke-key"+ , "sign"+ , "update-key"+ , "validate-userid"+ , "verify"+ , "version"+ ]++ensureKnownSubcommand :: [String] -> [String] -> IO ()+ensureKnownSubcommand knownSubcommands args =+ if any (`elem` ["-h", "--help", "--version"]) args+ then pure ()+ else case find (not . isPrefixOf "-") args of+ Just subcommand+ | subcommand `notElem` knownSubcommands ->+ failWith+ UnsupportedSubcommand+ ("unsupported subcommand: " ++ subcommand)+ _ -> pure ()++cliP :: Parser CliOptions+cliP =+ CliOptions+ <$> switch (long "debug" <> help "emit more verbose output")+ <*> cmd++data Vrf+ = Vrf+ { _vrfmsg :: String+ , _vrfmfpr :: Maybe Fingerprint+ }+ deriving (Eq, Generic, Show)++instance A.ToJSON Vrf++cmd :: Parser Command+cmd =+ hsubparser+ ( command+ "armor"+ (info (pure ArmorC) (progDesc "Armor stdin to stdout"))+ <> command+ "dearmor"+ (info (pure DeArmorC) (progDesc "Dearmor stdin to stdout"))+ <> command+ "change-key-password"+ ( info+ (ChangeKeyPasswordC <$> changeKeyPasswordP)+ (progDesc "Update a key password")+ )+ <> command+ "decrypt"+ (info (DecryptC <$> decP) (progDesc "Decrypt a message"))+ <> command+ "encrypt"+ (info (EncryptC <$> encP) (progDesc "Encrypt a message"))+ <> command+ "certify-userid"+ ( info+ (CertifyUserIdC <$> certifyUserIdP)+ (progDesc "Certify user IDs in a certificate")+ )+ <> command+ "extract-cert"+ ( info+ (ExtractCertC <$> ecoP)+ ( progDesc+ "Extract a certificate from a secret key and output it to stdout"+ )+ )+ <> command+ "generate-key"+ ( info+ (GenerateKeyC <$> gkoP)+ (progDesc "Generate a secret key and output it to stdout")+ )+ <> command+ "inline-detach"+ ( info+ (InlineDetachC <$> inlineDetachP)+ (progDesc "Create inline detached signatures")+ )+ <> command+ "inline-sign"+ ( info+ (InlineSignC <$> inlineSignP)+ (progDesc "Create inline signatures")+ )+ <> command+ "inline-verify"+ ( info+ (InlineVerifyC <$> ivoP)+ (progDesc "Verify inline-signed data")+ )+ <> command+ "list-profiles"+ (info (ListProfilesC <$> lpoP) (progDesc "List SOP profiles"))+ <> command+ "merge-certs"+ ( info+ (MergeCertsC <$> mergeCertsP)+ (progDesc "Merge OpenPGP certificates")+ )+ <> command+ "revoke-key"+ ( info+ (RevokeKeyC <$> revokeKeyP)+ (progDesc "Create a key revocation certificate")+ )+ <> command+ "sign"+ ( info+ (SignC <$> soP)+ (progDesc "Create detached signatures and output them to stdout")+ )+ <> command+ "update-key"+ (info (UpdateKeyC <$> updateKeyP) (progDesc "Update key material"))+ <> command+ "validate-userid"+ ( info+ (ValidateUserIdC <$> validateUserIdP)+ (progDesc "Validate a certificate user ID")+ )+ <> command+ "verify"+ (info (VerifyC <$> voP) (progDesc "Verify signatures"))+ <> command+ "version"+ ( info+ (VersionC <$> vopP)+ (progDesc "output hop version to stdout")+ )+ )++doArmor :: IO ()+doArmor = do+ m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume+ let lbs = BL.fromChunks m+ armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs+ if armoredAlready+ then BL.putStr lbs+ else do+ let label' = guessLabel (decodeAllPackets lbs) lbs+ a = Armor label' [] lbs+ BL.putStr $ AA.encodeLazy [a]+ where+ decodeAllPackets lbs = runGet (many Bin.get) lbs+ guessLabel [] _ = ArmorMessage+ guessLabel (pkt : _) lbs =+ case pkt of+ SignaturePkt _ ->+ if all isSignaturePacket (decodeAllPackets lbs)+ then ArmorSignature+ else ArmorMessage+ SecretKeyPkt _ _ -> ArmorPrivateKeyBlock+ PublicKeyPkt _ -> ArmorPublicKeyBlock+ _ -> ArmorMessage+ isSignaturePacket SignaturePkt {} = True+ isSignaturePacket _ = False++doVersion :: VersionOptions -> IO ()+doVersion VersionOptions {..} = do+ let selected = length (filter id [vBackend, vExtended, vSopSpec, vSopv])+ when (selected > 1) $+ failWith+ IncompatibleOptions+ "version: --backend, --extended, --sop-spec, and --sopv are mutually exclusive"+ when vBackend $+ putStrLn $+ "hOpenPGP " ++ HOV.version+ when vExtended $ do+ mapM_ putStrLn $+ [ "hop " ++ showVersion version+ , ""+ , "This is hop, from hopenpgp-tools " ++ showVersion version ++ ","+ , "built with hOpenPGP " ++ HOV.version+ ]+ when vSopSpec $+ putStrLn "draft-dkg-openpgp-stateless-cli-16"+ when vSopv $+ putStrLn "1.0"+ unless (vBackend || vExtended || vSopSpec || vSopv) $+ putStrLn $+ "hop " ++ showVersion version++gkoP :: Parser KeyGenOptions+gkoP =+ KeyGenOptions+ <$> switch (long "no-armor" <> help "don't armor the output")+ <*> optional+ ( strOption+ ( long "with-key-password"+ <> help "password used to protect generated secret key material"+ )+ )+ <*> optional+ ( strOption+ ( long "profile"+ <> metavar "PROFILE"+ <> help+ "key generation profile (default, rfc4880, compatibility, security, performance)"+ )+ )+ <*> switch+ (long "signing-only" <> help "generate signing-only key material")+ <*> many+ ( strArgument+ (metavar "USERID" <> help "User ID associated with this key")+ )++data KeyGenOptions+ = KeyGenOptions+ { noArmor :: Bool+ , keyPassword :: Maybe String+ , keyProfile :: Maybe String+ , keySigningOnly :: Bool+ , userIds :: [String]+ }++doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()+doGenerateKey pt KeyGenOptions {..} = do+ profile <- parseKeyGenProfile keyProfile+ password <- parseGenerateKeyPassword keyPassword+ let ts = ThirtyTwoBitTimeStamp (floor pt)+ keyVersion = keyVersionForProfile profile+ result <- runTKGen (keyVersion, ts) $ do+ case profile of+ KeyGenRFC4880 -> do+ setKeySize RSA 4096+ newKey RSA+ _ -> newKey Ed25519+ case userIds of+ (primaryUid : restUids) -> do+ addUID (T.pack primaryUid)+ mapM_ (addUID . T.pack) restUids+ [] -> pure ()+ addSubkeysForProfile profile keySigningOnly+ setSEIPDv1SymmetricPreferences+ [AES256, AES192, AES128]+ setHashPreferences+ [SHA512, SHA384, SHA256, SHA224]+ setCompressionPreferences+ [ZLIB, ZIP, BZip2, Uncompressed]+ when (profile /= KeyGenRFC4880) $+ setAEADPreferences+ [ (AES256, GCM)+ , (AES256, OCB)+ , (AES128, GCM)+ , (AES128, OCB)+ ]+ setFeatures $ S.singleton FeatureSEIPDv2+ pure ()+ tk <- either (failWith BadData . show) (pure . snd) result+ tk' <-+ encryptTransferableSecretKey+ password+ tk+ let lbs = runPut $ Bin.put (someTKToUnknown (SomeSecretTK tk'))+ BL.putStr $+ if not noArmor+ then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs]+ else lbs++modifyTKSecretKeysM+ :: Monad m+ => TK 'SecretTK+ -> (SomePKPayload -> SKAddendum -> m SKAddendum)+ -> m (TK 'SecretTK)+modifyTKSecretKeysM tk cb = do+ let keys = tkSecretKeyPairs tk+ newSkas <- mapM (uncurry cb) keys+ let index = zip (map fst keys) newSkas+ pure $+ modifyTKSecretKeys tk $+ \pkp ska -> (pkp, fromMaybe ska (lookup pkp index))++modifyTKSecretKeysE+ :: TK 'SecretTK+ -> (SomePKPayload -> SKAddendum -> IO (Either String SKAddendum))+ -> IO (Either String (TK 'SecretTK))+modifyTKSecretKeysE tk cb = do+ let keys = tkSecretKeyPairs tk+ result <- mapM (uncurry cb) keys+ case sequence result of+ Left err -> pure (Left err)+ Right skas ->+ let index = zip (map fst keys) skas+ in pure $+ Right $+ modifyTKSecretKeys tk $+ \pkp ska -> (pkp, fromMaybe ska (lookup pkp index))++data KeyGenProfile+ = KeyGenRFC4880+ | KeyGenSecurity+ | KeyGenSigningOnly+ deriving (Eq)++keyGenProfiles :: [Profile KeyGenProfile]+keyGenProfiles =+ [ Profile+ "security"+ "Ed25519 signing key, X25519 encryption subkey"+ KeyGenSecurity+ ["default", "performance", "rfc9580"]+ , Profile+ "rfc4880"+ "RSA-4096 (v4 keys)"+ KeyGenRFC4880+ ["compatibility"]+ ]++resolveProfile :: String -> [Profile p] -> Maybe p+resolveProfile name profiles =+ lookup name [(profileName p, profileValue p) | p <- profiles]+ <|> profileValue+ <$> find (\p -> name `elem` profileAliases p) profiles++parseKeyGenProfile :: Maybe String -> IO KeyGenProfile+parseKeyGenProfile Nothing = pure KeyGenSecurity+parseKeyGenProfile (Just name) =+ case resolveProfile name keyGenProfiles of+ Just p -> pure p+ Nothing ->+ failWith+ UnsupportedProfile+ ("generate-key: unsupported profile " ++ name)++keyVersionForProfile :: KeyGenProfile -> KeyVersion+keyVersionForProfile KeyGenRFC4880 = V4+keyVersionForProfile KeyGenSecurity = V6+keyVersionForProfile KeyGenSigningOnly = V6++parseGenerateKeyPassword+ :: Maybe String -> IO (Maybe Passphrase)+parseGenerateKeyPassword Nothing = pure Nothing+parseGenerateKeyPassword (Just passwordFile) =+ Just+ <$> ( loadPasswordFromFile+ "generate-key"+ "--with-key-password"+ passwordFile+ >>= normalizeHumanReadablePassword+ "generate-key"+ "--with-key-password"+ . BL.toStrict+ )++loadPasswordFiles+ :: String -> String -> [String] -> IO [BL.ByteString]+loadPasswordFiles context optionName = mapM (loadPasswordFromFile context optionName)++loadPasswordFromFile+ :: String -> String -> FilePath -> IO BL.ByteString+loadPasswordFromFile = loadFromFile "password file"++loadInputFromFile+ :: String -> String -> FilePath -> IO BL.ByteString+loadInputFromFile = loadFromFile "file"++loadFromFile+ :: String -> String -> String -> FilePath -> IO BL.ByteString+loadFromFile fileKind context optionName path = do+ case stripPrefix "@ENV:" path of+ Just varName+ | null varName ->+ failWith+ BadData+ (context ++ ": empty environment variable name in " ++ optionName)+ | otherwise -> do+ envValue <- lookupEnv varName+ case envValue of+ Nothing ->+ failWith+ MissingInput+ ( context+ ++ ": environment variable not found for "+ ++ optionName+ ++ ": "+ ++ varName+ )+ Just envVal -> pure (BLC8.pack envVal)+ Nothing ->+ case stripPrefix "@FD:" path of+ Just fdSpec -> loadFromFD 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+ ++ ": "+ ++ fileKind+ ++ " does not exist for "+ ++ optionName+ ++ ": "+ ++ path+ )+ BL.readFile path++loadFromFD+ :: String -> String -> String -> IO BL.ByteString+loadFromFD 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+ )++loadOpenPGPPackets+ :: String -> FilePath -> IO [Pkt]+loadOpenPGPPackets context path = do+ lbs <- loadInputFromFile context "file" path+ decodeOpenPGPInput path lbs++normalizeHumanReadablePassword+ :: String -> String -> B.ByteString -> IO Passphrase+normalizeHumanReadablePassword context optionName passwordBytes =+ case TE.decodeUtf8' passwordBytes of+ Left _ ->+ failWith+ PasswordNotHumanReadable+ ( context+ ++ ": password is not human-readable UTF-8 for "+ ++ optionName+ )+ Right txt ->+ pure+ (Passphrase (TE.encodeUtf8 (T.dropWhileEnd isSpace txt)))++passwordRetryCandidates :: B.ByteString -> [B.ByteString]+passwordRetryCandidates passwordBytes =+ case TE.decodeUtf8' passwordBytes of+ Left _ -> [passwordBytes]+ Right txt ->+ let trimmed = TE.encodeUtf8 (T.dropWhileEnd isSpace txt)+ in if trimmed == passwordBytes+ then [passwordBytes]+ else [passwordBytes, trimmed]++addSubkeysForProfile+ :: KeyGenProfile+ -> Bool+ -> TKGen IO 'SecretTK ()+addSubkeysForProfile KeyGenRFC4880 signingOnly = do+ _ <- addSubkey RSA [SignDataKey]+ unless signingOnly $ do+ _ <- addSubkey RSA [EncryptStorageKey, EncryptCommunicationsKey]+ _ <- addSubkey RSA [AuthKey]+ pure ()+addSubkeysForProfile KeyGenSecurity signingOnly = do+ _ <- addSubkey Ed25519 [SignDataKey]+ unless signingOnly $ do+ _ <-+ addSubkey X25519 [EncryptStorageKey, EncryptCommunicationsKey]+ _ <- addSubkey Ed25519 [AuthKey]+ pure ()+addSubkeysForProfile KeyGenSigningOnly _ = do+ _ <- addSubkey Ed25519 [SignDataKey]+ pure ()++encryptUnencryptedV4SecretKey+ :: SomePKPayload+ -> SKey+ -> B.ByteString+ -> IO (Either String SKAddendum)+encryptUnencryptedV4SecretKey pkp skey passphrase = do+ saltBytes <- getRandomBytes 8+ ivBytes <- getRandomBytes 16+ let sa = AES256+ keyLen = 32+ s2k = IteratedSalted SHA256 (Salt8 saltBytes) 65536+ iv = IV ivBytes+ pure $+ case string2Key s2k keyLen passphrase of+ Left err -> Left (renderS2KError err)+ Right keyMaterial ->+ case putSKeyForPKPayload pkp skey of+ Left err -> Left err+ Right putAction ->+ let cleartext = runPut putAction+ sha1Checksum =+ BA.convert+ (CH.hash (BL.toStrict cleartext) :: CH.Digest CHA.SHA1)+ clearWithChecksum =+ BL.toStrict (cleartext <> BL.fromStrict sha1Checksum)+ in case encryptNoNonce sa s2k iv clearWithChecksum keyMaterial of+ Left err -> Left (show err)+ Right encrypted ->+ Right (SUSCFB sa s2k iv (BL.fromStrict encrypted))++encryptTransferableSecretKey+ :: Maybe Passphrase -> TK 'SecretTK -> IO (TK 'SecretTK)+encryptTransferableSecretKey mPassword tk =+ maybe+ (pure tk)+ (modifyTKSecretKeysM tk . encryptSecretAddendumForOutput)+ mPassword+ where+ encryptSecretAddendumForOutput+ :: Passphrase -> SomePKPayload -> SKAddendum -> IO SKAddendum+ encryptSecretAddendumForOutput (Passphrase password) pkp ska =+ case ska of+ SUSUnprotected skey _+ | _keyVersion pkp == V4 -> do+ result <- encryptUnencryptedV4SecretKey pkp skey password+ case result of+ Left err ->+ failWith+ BadData+ ( "generate-key: failed to protect V4 secret key material: "+ ++ err+ )+ Right val -> pure val+ SUSUnprotected skey _ ->+ encryptSecretKeyWithPolicy+ defaultPolicy+ pkp+ skey+ (Passphrase password)+ >>= \result -> case result of+ Left err ->+ failWith+ BadData+ ( "generate-key: failed to protect secret key material: "+ ++ show err+ )+ Right val -> pure val+ _ -> pure ska++changeTKPassword+ :: [Passphrase]+ -> Maybe Passphrase+ -> TK 'SecretTK+ -> IO (Either String (TK 'SecretTK))+changeTKPassword oldPasswords mNewPassword tk = do+ result <-+ modifyTKSecretKeysE+ tk+ (changeSKAddendum oldPasswords mNewPassword)+ case result of+ Left err -> pure (Left err)+ Right tk' -> pure (Right tk')+ where+ changeSKAddendum+ :: [Passphrase]+ -> Maybe Passphrase+ -> SomePKPayload+ -> SKAddendum+ -> IO (Either String SKAddendum)+ changeSKAddendum oldPasswords mNewPassword pkp ska =+ case ska of+ SUSUnprotected skey _ ->+ case _keyVersion pkp of+ V4 ->+ case mNewPassword of+ Just newPassword -> do+ result <-+ encryptUnencryptedV4SecretKey pkp skey (unPassphrase newPassword)+ case result of+ Right newSka -> pure $ Right newSka+ Left err -> pure $ Left err+ Nothing -> pure $ Right ska+ _ ->+ case mNewPassword of+ Just newPassword -> do+ encryptedResult <-+ encryptSecretKeyWithPolicy+ defaultPolicy+ pkp+ skey+ newPassword+ case encryptedResult of+ Right newSka -> pure $ Right newSka+ Left err -> pure $ Left (renderSecretKeyError err)+ Nothing -> pure $ Right ska+ _ ->+ case mNewPassword of+ Just newPassword ->+ tryReencrypt oldPasswords newPassword pkp ska+ Nothing ->+ tryDecrypt oldPasswords pkp ska++ tryReencrypt [] _ _ _ = pure $ Left "no usable password for encrypted key material"+ tryReencrypt (old : rest) newPassword pkp ska = do+ if _keyVersion pkp == V4+ then do+ case decryptSecretKeyAddendum pkp ska old of+ Left _ -> tryReencrypt rest newPassword pkp ska+ Right (skey, SUSUnprotected _ _) -> do+ result <-+ encryptUnencryptedV4SecretKey pkp skey (unPassphrase newPassword)+ case result of+ Right newSka -> pure $ Right newSka+ Left _ -> tryReencrypt rest newPassword pkp ska+ Right _ -> tryReencrypt rest newPassword pkp ska+ else do+ result <-+ reencryptSecretKey+ ( SecretKey+ { _secretKeyPKPayload = pkp+ , _secretKeySKAddendum = ska+ }+ )+ old+ newPassword+ SecretKeyEncryptOptions+ { skeoPolicy = defaultPolicy+ , skeoGenerateSaltAndIV = True+ , skeoSalt = Nothing+ , skeoIV = Nothing+ }+ case result of+ Right (SecretKey {_secretKeySKAddendum = newSka}) ->+ pure $ Right newSka+ Left _ -> tryReencrypt rest newPassword pkp ska++ tryDecrypt [] _ _ = pure $ Left "no usable password for encrypted key material"+ tryDecrypt (old : rest) pkp ska =+ case decryptSecretKeyAddendum pkp ska old of+ Right (_, decrypted) -> pure $ Right decrypted+ Left _ -> tryDecrypt rest pkp ska++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)]++issuerFingerprintVersionFor+ :: SomePKPayload -> IssuerFingerprintVersion+issuerFingerprintVersionFor pkp =+ case _keyVersion pkp of+ V6 -> IssuerFingerprintV6+ _ -> IssuerFingerprintV4++ecoP :: Parser ExtractCertOptions+ecoP =+ ExtractCertOptions+ <$> switch (long "no-armor" <> help "don't armor the output")++data ExtractCertOptions+ = ExtractCertOptions+ { ecNoArmor :: Bool+ }++doExtractCert :: ExtractCertOptions -> IO ()+doExtractCert ExtractCertOptions {..} = do+ kbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume+ let lbs = BL.fromChunks kbs+ pkts <- decodeOpenPGPInput "stdin" lbs+ tks <-+ runConduitRes $+ CL.sourceList pkts+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList+ when (null tks) $+ failWith+ MissingInput+ "extract-cert: no transferable secret key found on standard input"+ let output = runPut $ mapM_ (Bin.put . someTKToUnknown . pubToSecret) tks+ BL.putStr $+ if not ecNoArmor+ then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]+ else output+ where+ pubToSecret tk =+ case tk of+ SomeSecretTK _ -> SomePublicTK (someTKToPublicViewTK tk)+ SomePublicTK publicTk -> SomePublicTK publicTk++doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO ()+doChangeKeyPassword ChangeKeyPasswordOptions {..} = do+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ packets <- decodeOpenPGPInput "stdin" input+ tks <-+ runConduitRes $+ CL.sourceList packets+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList+ when (null tks) $+ failWith+ MissingInput+ "change-key-password: no transferable secret key found on standard input"+ when (any (not . hasSecretKeyMaterial) tks) $+ failWith+ MissingInput+ "change-key-password: expected transferable secret key input on standard input"+ oldPasswordsRaw <-+ loadPasswordFiles+ "change-key-password"+ "--old-key-password"+ changeKeyPasswordOldPasswords+ let oldPasswords =+ map+ Passphrase+ (concatMap (passwordRetryCandidates . BL.toStrict) oldPasswordsRaw)+ newPassword <-+ parseChangeKeyPasswordNewPassword changeKeyPasswordNewPassword+ let changeSome (SomePublicTK pk) = pure (Right (SomePublicTK pk))+ changeSome (SomeSecretTK sk) = do+ er <- changeTKPassword oldPasswords newPassword sk+ case er of+ Left err -> pure (Left err)+ Right tk' -> pure (Right (SomeSecretTK tk'))+ changed <- mapM changeSome tks+ case sequence changed of+ Left err ->+ failWith+ BadData+ err+ Right rewrittenTks ->+ let output = runPut (mapM_ (Bin.put . someTKToUnknown) rewrittenTks)+ in BL.putStr $+ if changeKeyPasswordNoArmor || BL.null output+ then output+ else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output]++parseChangeKeyPasswordNewPassword+ :: Maybe String -> IO (Maybe Passphrase)+parseChangeKeyPasswordNewPassword Nothing = pure Nothing+parseChangeKeyPasswordNewPassword (Just passwordFile) =+ Just+ <$> ( loadPasswordFromFile+ "change-key-password"+ "--new-key-password"+ passwordFile+ >>= normalizeHumanReadablePassword+ "change-key-password"+ "--new-key-password"+ . BL.toStrict+ )++hasSecretKeyMaterial :: SomeTK -> Bool+hasSecretKeyMaterial tk =+ case tk of+ SomeSecretTK _ -> True+ SomePublicTK _ -> False++onlySecretTKs :: [SomeTK] -> [TK 'SecretTK]+onlySecretTKs =+ mapMaybe+ ( \t -> case t of SomeSecretTK tk -> Just tk; SomePublicTK _ -> Nothing+ )++secretTKFromSome :: SomeTK -> TK 'SecretTK+secretTKFromSome (SomeSecretTK tk) = tk+secretTKFromSome SomePublicTK {} = error "secretTKFromSome: expected secret key"++onSecretTKM+ :: Monad m+ => (TK 'SecretTK -> m (TK 'SecretTK)) -> SomeTK -> m SomeTK+onSecretTKM _ (SomePublicTK pk) = pure (SomePublicTK pk)+onSecretTKM f (SomeSecretTK sk) = SomeSecretTK <$> f sk++doValidateUserId :: POSIXTime -> ValidateUserIdOptions -> IO ()+doValidateUserId cpt ValidateUserIdOptions {..} = do+ authorityTks <-+ concat+ <$> mapM+ (loadCertTKsFromFile "validate-userid")+ validateUserIdAuthorityFiles+ validateAtTime <- verificationUpperBound cpt validateUserIdAt+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ certPkts <- decodeOpenPGPInput "standard input" input+ certTks <-+ runConduitRes $+ CL.sourceList certPkts+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList+ when (null certTks) $+ failWith+ MissingInput+ "validate-userid: no certificate found on standard input"+ let targetUserId = T.pack validateUserIdString+ forM_ certTks $ \certTk ->+ when+ ( not+ ( certificateHasMatchingValidatedUserId+ authorityTks+ validateAtTime+ validateUserIdAddrSpecOnly+ targetUserId+ certTk+ )+ )+ $ failWith+ CertUserIdNoMatch+ ( "validate-userid: certificate has no correctly bound user ID matching "+ ++ validateUserIdString+ )++certificateHasMatchingValidatedUserId+ :: [SomeTK] -> Maybe UTCTime -> Bool -> Text -> SomeTK -> Bool+certificateHasMatchingValidatedUserId authorityTks validateAtTime addrSpecOnly targetUserId certTk =+ case verifyTKWithTyped+ defaultVerificationPolicy+ (certTk : authorityTks)+ validateAtTime+ certTk of+ Left _ -> False+ Right verifiedTk ->+ any matchingBoundUid (_tkUIDs (someTKToPublicViewTK verifiedTk))+ where+ matchingBoundUid (uid, sigs) =+ useridMatches addrSpecOnly targetUserId uid+ && any (signatureMatchesSigner certTk) sigs+ && any+ (\sig -> any (`signatureMatchesSigner` sig) authorityTks)+ sigs++useridMatches :: Bool -> Text -> Text -> Bool+useridMatches False targetUserId uid = uid == targetUserId+useridMatches True targetUserId uid =+ case conventionalAddrSpec uid of+ Just addrSpec -> addrSpec == targetUserId+ Nothing -> False++conventionalAddrSpec :: Text -> Maybe Text+conventionalAddrSpec uid =+ let (prefix, suffix) = T.breakOnEnd (T.pack "<") uid+ in if T.null prefix+ then Nothing+ else case T.unsnoc suffix of+ Just (addrSpec, '>')+ | T.any (== '<') addrSpec -> Nothing+ | otherwise -> guardNonEmpty (T.strip addrSpec)+ _ -> Nothing+ where+ guardNonEmpty text+ | T.null text = Nothing+ | otherwise = Just text++signatureMatchesSigner :: SomeTK -> SignaturePayload -> Bool+signatureMatchesSigner signer sig =+ maybe+ False+ (keyMatchesFingerprint False signer)+ (signatureIssuerFingerprint sig)+ || maybe+ False+ (keyMatchesEightOctetKeyId False signer . Right)+ (signatureIssuerKeyId sig)++signatureIssuerFingerprint+ :: SignaturePayload -> Maybe Fingerprint+signatureIssuerFingerprint =+ listToMaybe . mapMaybe getIssuerFingerprint . signatureSubpackets+ where+ getIssuerFingerprint (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) =+ Just issuerFingerprint+ getIssuerFingerprint _ = Nothing++signatureIssuerKeyId :: SignaturePayload -> Maybe EightOctetKeyId+signatureIssuerKeyId = listToMaybe . mapMaybe getIssuerKeyId . signatureSubpackets+ where+ getIssuerKeyId (SigSubPacket _ (Issuer issuerKeyId)) = Just issuerKeyId+ getIssuerKeyId _ = Nothing++signatureSubpackets :: SignaturePayload -> [SigSubPacket]+signatureSubpackets (SigV4 _ _ _ hashed unhashed _ _) = hashed ++ unhashed+signatureSubpackets (SigV6 _ _ _ _ hashed unhashed _ _) = hashed ++ unhashed+signatureSubpackets _ = []++doCertifyUserId :: POSIXTime -> CertifyUserIdOptions -> IO ()+doCertifyUserId _cpt CertifyUserIdOptions {..} = do+ signerPasswordsRaw <-+ loadPasswordFiles+ "certify-userid"+ "--with-key-password"+ certifyUserIdKeyPasswordFiles+ let signerPasswords =+ map+ Passphrase+ ( concatMap+ (passwordRetryCandidates . BL.toStrict)+ signerPasswordsRaw+ )+ signerTks <-+ concat+ <$> mapM+ ( \p ->+ loadCertifySignerTKsFromFile signerPasswords "certify-userid" p+ )+ certifyUserIdSignerFiles+ when (null signerTks) $+ failWith+ MissingInput+ "certify-userid: no signer certificate found"+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ certPkts <- decodeOpenPGPInput "standard input" input+ targetTks <-+ runConduitRes $+ CL.sourceList certPkts+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList+ when (null targetTks) $+ failWith+ MissingInput+ "certify-userid: no certificate found on standard input"+ let targetUserIds = map T.pack certifyUserIds+ requireSelfSig = not certifyUserIdNoRequireSelfSig+ updatedTargets <-+ mapM+ ( \targetTk ->+ addUserIdCertifications+ targetTk+ targetUserIds+ requireSelfSig+ signerTks+ )+ targetTks+ let output = runPut (mapM_ (Bin.put . someTKToUnknown) updatedTargets)+ BL.putStr $+ if certifyUserIdNoArmor+ then output+ else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]++loadCertifySignerTKsFromFile+ :: [Passphrase] -> String -> String -> IO [TK 'SecretTK]+loadCertifySignerTKsFromFile signerPasswords context path = do+ lbs <- loadInputFromFile context "file" path+ packets <- decodeOpenPGPInput path lbs+ tks <-+ runConduitRes $+ CL.sourceList packets+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList+ let fallbackTks = signingFallbackTKs packets+ when (null tks && null fallbackTks) $+ failWith+ MissingInput+ ("certify-userid: no signer key material found in " ++ path)+ let secretTks =+ if null tks+ then map secretTKFromSome fallbackTks+ else onlySecretTKs tks+ mapM+ ( \tk -> do+ tk' <-+ unlockTransferableSecretKeyMaterial+ "certify-userid failed"+ path+ "--with-key-password"+ signerPasswords+ tk+ pure tk'+ )+ secretTks++addUserIdCertifications+ :: SomeTK -> [Text] -> Bool -> [TK 'SecretTK] -> IO SomeTK+addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks = do+ forM_ targetUserIds $ \targetUserId ->+ case find+ ((== targetUserId) . fst)+ (_tkUIDs (someTKToPublicViewTK targetTk)) of+ Nothing ->+ failWith+ CertUserIdNoMatch+ ( "certify-userid: target certificate has no user ID matching "+ ++ T.unpack targetUserId+ )+ Just (_, sigs) ->+ when+ ( requireSelfSig+ && not (any (signatureMatchesSigner targetTk) sigs)+ )+ $ failWith+ CertUserIdNoMatch+ ( "certify-userid: target user ID has no self-signature: "+ ++ T.unpack targetUserId+ )+ newSigs <-+ concat+ <$> forM+ signerTks+ ( \signerTk ->+ forM+ targetUserIds+ ( \targetUserId -> do+ let signerPkp =+ keyPktPKPayload+ ( _tkPrimaryKey+ ( someTKToPublicViewTK+ (SomeSecretTK signerTk)+ )+ )+ isSelf =+ certificatePrimaryFingerprint targetTk+ == certificatePrimaryFingerprint+ (SomeSecretTK signerTk)+ certType =+ if isSelf then PositiveCert else GenericCert+ signerKp =+ _tkPrimaryKey signerTk+ ska =+ ( case signerKp of+ KeyPktSecretPrimary _ ska -> ska+ _ -> error "certify-userid: unexpected primary key type"+ )+ unless (hasSecretKeyMaterial (SomeSecretTK signerTk)) $+ failWith+ KeyCannotCertify+ "certify-userid: signer certificate has no secret key material"+ issuer <- issuerSubpacketsFor "certify-userid" signerPkp+ let hashed =+ [ SigSubPacket+ False+ (SigCreationTime (_timestamp signerPkp))+ ]+ result <- case ska of+ SUSUnprotected (RSAPrivateKey (RSA_PrivateKey k)) _ ->+ signUserId+ SHA512+ certType+ signerKp+ (UserId targetUserId)+ hashed+ issuer+ (k {RSA.private_p = 0, RSA.private_q = 0})+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve25519 rawBytes) _ ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith+ BadData+ ("certify-userid: bad Ed25519 key: " ++ show err)+ Right sk ->+ signUserId+ SHA512+ certType+ signerKp+ (UserId targetUserId)+ hashed+ issuer+ sk+ SUSUnprotected (Ed25519PrivateKey rawBytes) _ ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith+ BadData+ ("certify-userid: bad Ed25519 key: " ++ show err)+ Right sk ->+ signUserId+ SHA512+ certType+ signerKp+ (UserId targetUserId)+ hashed+ issuer+ sk+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve448 rawBytes) _ ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err ->+ failWith BadData ("certify-userid: bad Ed448 key: " ++ show err)+ Right sk ->+ signUserId+ SHA512+ certType+ signerKp+ (UserId targetUserId)+ hashed+ issuer+ sk+ SUSUnprotected (Ed448PrivateKey rawBytes) _ ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err ->+ failWith BadData ("certify-userid: bad Ed448 key: " ++ show err)+ Right sk ->+ signUserId+ SHA512+ certType+ signerKp+ (UserId targetUserId)+ hashed+ issuer+ sk+ _ ->+ failWith+ BadData+ "certify-userid: unsupported secret key type"+ case result of+ Left err ->+ failWith+ BadData+ ("certify-userid: failed: " ++ show err)+ Right sig -> pure (targetUserId, sig)+ )+ )+ let updateUID (uid, sigs) =+ if uid `elem` targetUserIds+ then (uid, sigs ++ map snd (filter ((== uid) . fst) newSigs))+ else (uid, sigs)+ pure $ case targetTk of+ SomePublicTK tk -> SomePublicTK tk {_tkUIDs = map updateUID (_tkUIDs tk)}+ SomeSecretTK tk -> SomeSecretTK tk {_tkUIDs = map updateUID (_tkUIDs tk)}++doRevokeKey :: POSIXTime -> RevokeKeyOptions -> IO ()+doRevokeKey _cpt RevokeKeyOptions {..} = do+ keyPasswordsRaw <-+ loadPasswordFiles+ "revoke-key"+ "--with-key-password"+ revokeKeyPasswordFiles+ let keyPasswords =+ map+ Passphrase+ (concatMap (passwordRetryCandidates . BL.toStrict) keyPasswordsRaw)+ input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ keyPkts <- decodeOpenPGPInput "standard input" input+ keyTks <-+ runConduitRes $+ CL.sourceList keyPkts+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList+ when (null keyTks) $+ failWith+ MissingInput+ "revoke-key: no key found on standard input"+ when (any (not . hasSecretKeyMaterial) keyTks) $+ failWith+ MissingInput+ "revoke-key: expected transferable secret key input on standard input"+ let secretKeyTks = onlySecretTKs keyTks+ revocationSigPkts <-+ forM secretKeyTks $ \secretTk -> do+ unlocked <-+ unlockTransferableSecretKeyMaterial+ "revoke-key failed"+ "standard input"+ "--with-key-password"+ keyPasswords+ secretTk+ let kp = _tkPrimaryKey unlocked+ issuer <- issuerSubpacketsFor "revoke-key" (keyPktPKPayload kp)+ let hashed =+ [ SigSubPacket+ False+ (SigCreationTime (_timestamp (keyPktPKPayload kp)))+ ]+ result <- case kp of+ KeyPktSecretPrimary+ _+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey k)) _) ->+ signDirectKey+ SHA512+ KeyRevocationSig+ kp+ hashed+ issuer+ (k {RSA.private_p = 0, RSA.private_q = 0})+ KeyPktSecretPrimary+ _+ (SUSUnprotected (EdDSAPrivateKey EdSigningCurve25519 rawBytes) _) ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith BadData ("revoke-key: bad Ed25519 key: " ++ show err)+ Right sk -> signDirectKey SHA512 KeyRevocationSig kp hashed issuer sk+ KeyPktSecretPrimary+ _+ (SUSUnprotected (Ed25519PrivateKey rawBytes) _) ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith BadData ("revoke-key: bad Ed25519 key: " ++ show err)+ Right sk -> signDirectKey SHA512 KeyRevocationSig kp hashed issuer sk+ KeyPktSecretPrimary+ _+ (SUSUnprotected (EdDSAPrivateKey EdSigningCurve448 rawBytes) _) ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err -> failWith BadData ("revoke-key: bad Ed448 key: " ++ show err)+ Right sk -> signDirectKey SHA512 KeyRevocationSig kp hashed issuer sk+ KeyPktSecretPrimary+ _+ (SUSUnprotected (Ed448PrivateKey rawBytes) _) ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err -> failWith BadData ("revoke-key: bad Ed448 key: " ++ show err)+ Right sk -> signDirectKey SHA512 KeyRevocationSig kp hashed issuer sk+ _ ->+ failWith+ BadData+ "revoke-key: unsupported secret key type"+ case result of+ Left err ->+ failWith+ BadData+ ("revoke-key: failed: " ++ show err)+ Right sig -> pure sig+ let output = runPut (mapM_ Bin.put revocationSigPkts)+ BL.putStr $+ if revokeKeyNoArmor+ then output+ else AA.encodeLazy [Armor ArmorSignature [] output]++hasBadPrimaryKey :: TK 'SecretTK -> Bool+hasBadPrimaryKey tk =+ primaryKeyTooSmallForVerification (SomeSecretTK tk)+ || hasHardPrimaryKeyRevocation (SomeSecretTK tk)++hasHardPrimaryKeyRevocation :: SomeTK -> Bool+hasHardPrimaryKeyRevocation stk =+ any isHardKeyRevocation (_tkRevs (someTKToPublicViewTK stk))+ where+ isHardKeyRevocation sig = case sig of+ SigV4 KeyRevocationSig _ _ hashedSubs _ _ _ ->+ any hasHardReason hashedSubs+ SigV6 KeyRevocationSig _ _ _ hashedSubs _ _ _ ->+ any hasHardReason hashedSubs+ _ -> False+ where+ hasHardReason (SigSubPacket _ (ReasonForRevocation reason _)) =+ not (reason `elem` [KeySuperseded, KeyRetiredAndNoLongerUsed])+ hasHardReason _ = False++doUpdateKey :: POSIXTime -> UpdateKeyOptions -> IO ()+doUpdateKey cpt UpdateKeyOptions {..} = do+ keyPasswordsRaw <-+ loadPasswordFiles+ "update-key"+ "--with-key-password"+ updateKeyPasswordFiles+ let keyPasswords =+ map+ Passphrase+ (concatMap (passwordRetryCandidates . BL.toStrict) keyPasswordsRaw)+ stdinInput <-+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ stdinPkts <- decodeOpenPGPInput "stdin" stdinInput+ stdinTks <-+ runConduitRes $+ CL.sourceList stdinPkts+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CL.mapMaybe someTKToSecretTK+ .| CC.sinkList+ when (null stdinTks) $+ failWith+ MissingInput+ "update-key: no key found on standard input"+ updateSourceTks <-+ concat+ <$> mapM+ (\p -> loadVerifyTKsFromFile "update-key" p)+ updateKeyMergeCerts+ when (null updateSourceTks) $+ failWith MissingInput "update-key: no update keys found"+ stdinUnlocked <-+ mapM+ (unlockUpdateKeyMaterial "standard input" keyPasswords)+ stdinTks+ when (any hasBadPrimaryKey stdinUnlocked) $+ failWith+ PrimaryKeyBad+ "update-key: primary key is too weak or hard-revoked"+ updateUnlocked <-+ mapM+ (onSecretTKM (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 mergedTks =+ map+ ( \targetTk ->+ let mergedTkUnknown =+ foldl'+ (<>)+ (someTKToUnknown (SomeSecretTK targetTk))+ ( map+ someTKToUnknown+ ( selectUpdateMergeInputs+ cpt+ updateKeyNoAddedCapabilities+ (SomeSecretTK targetTk)+ updateTks+ )+ )+ in case fromUnknownToTKEither mergedTkUnknown of+ Right mergedStk -> mergedStk+ Left _ -> SomeSecretTK targetTk+ )+ stdinUnlocked+ strippedTks =+ if updateKeySigningOnly+ then map stripNonSigningSubkeys mergedTks+ else mergedTks+ secretTks = map SomeSecretTK (mapMaybe someTKToSecretTK strippedTks)+ when (null secretTks) $+ failWith+ PrimaryKeyBad+ "update-key: no secret key material available for output"+ modernizedTks <- mapM (modernizeSignatures cpt) secretTks+ when (any (not . hasSigningCapability cpt) modernizedTks) $+ failWith+ PrimaryKeyBad+ "update-key: output key has no signing capability"+ unless updateKeySigningOnly $+ when (any (not . hasDecryptionCapability cpt) modernizedTks) $+ failWith+ PrimaryKeyBad+ "update-key: output key has no decryption capability"+ let armorType =+ if any hasSecretKeyMaterial modernizedTks+ then ArmorPrivateKeyBlock+ else ArmorPublicKeyBlock+ output = runPut (mapM_ (Bin.put . someTKToUnknown) modernizedTks)+ BL.putStr $+ if updateKeyNoArmor+ then output+ else AA.encodeLazy [Armor armorType [] output]++doMergeCerts :: MergeCertsOptions -> IO ()+doMergeCerts MergeCertsOptions {..} = do+ stdinInput <-+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ stdinPkts <- decodeOpenPGPInput "stdin" stdinInput+ stdinTks <-+ runConduitRes $+ CL.sourceList stdinPkts+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList+ mergeInTks <-+ concat+ <$> mapM+ (\p -> loadVerifyTKsFromFile "merge-certs" p)+ mergeCertsFiles+ let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks+ output = runPut (mapM_ (Bin.put . someTKToUnknown) mergedTks)+ BL.putStr $+ if mergeCertsNoArmor || BL.null output+ then output+ else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]++mergeCertificatesForOutput+ :: [SomeTK] -> [SomeTK] -> [SomeTK]+mergeCertificatesForOutput stdinTks mergeInTks =+ map mergeGroup (groupByPrimaryKey stdinTks)+ where+ -- Upstream could expose this as a dedicated helper over TKWithWireRep+ -- so downstreams can keep packet provenance while merging certs.+ mergeGroup (base, rest) =+ let primary = certificatePrimaryFingerprint base+ mergedStdin =+ case fromUnknownToTKEither+ (foldl' (<>) (someTKToUnknown base) (map someTKToUnknown rest)) of+ Right mergedStk -> mergedStk+ Left _ -> base+ matchingMergeInputs =+ filter ((== primary) . certificatePrimaryFingerprint) mergeInTks+ mergedAll =+ case fromUnknownToTKEither+ ( foldl'+ (<>)+ (someTKToUnknown mergedStdin)+ (map someTKToUnknown matchingMergeInputs)+ ) of+ Right mergedStk -> mergedStk+ Left _ -> mergedStdin+ in mergedAll++groupByPrimaryKey :: [SomeTK] -> [(SomeTK, [SomeTK])]+groupByPrimaryKey [] = []+groupByPrimaryKey (tk : rest) =+ let primary = certificatePrimaryFingerprint tk+ (samePrimary, differentPrimary) =+ partition ((== primary) . certificatePrimaryFingerprint) rest+ in (tk, samePrimary) : groupByPrimaryKey differentPrimary++certificatePrimaryFingerprint :: SomeTK -> B.ByteString+certificatePrimaryFingerprint =+ unFingerprint+ . fingerprint+ . keyPktPKPayload+ . _tkPrimaryKey+ . someTKToPublicViewTK++unlockUpdateKeyMaterial+ :: String -> [Passphrase] -> TK 'SecretTK -> IO (TK 'SecretTK)+unlockUpdateKeyMaterial source keyPasswords tk =+ unlockTransferableSecretKeyMaterial+ "update-key failed"+ source+ "--with-key-password"+ keyPasswords+ tk++updateKeyHasSigningCapability :: POSIXTime -> SomeTK -> Bool+updateKeyHasSigningCapability cpt tk =+ any+ ( \funKey ->+ S.null (fkufs funKey) || S.member SignDataKey (fkufs funKey)+ )+ (tkToFunKeysAt cpt tk)++subkeyHasSigningCapability+ :: (KeyPkt k, [SignaturePayload]) -> Bool+subkeyHasSigningCapability (_, sigs) =+ case listToMaybe sigs >>= sig2KUFs of+ Just kfs -> S.null kfs || S.member SignDataKey kfs+ Nothing -> True+ where+ sig2KUFs = getHasheds >=> find isKUF >=> getKUFs+ getHasheds (SigV4 _ _ _ hasheds _ _ _) = Just hasheds+ getHasheds (SigV6 _ _ _ _ hasheds _ _ _) = Just hasheds+ getHasheds _ = Nothing+ getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs+ getKUFs _ = Nothing++selectUpdateMergeInputs+ :: POSIXTime+ -> Bool+ -> SomeTK+ -> [SomeTK]+ -> [SomeTK]+selectUpdateMergeInputs cpt noAddedCaps targetTk updateTks =+ filteredByCaps+ where+ targetPrimary = certificatePrimaryFingerprint targetTk+ mergeCandidates =+ filter+ ((== targetPrimary) . certificatePrimaryFingerprint)+ updateTks+ targetCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt targetTk))+ addsCapabilities updateTk =+ let updateCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt updateTk))+ in not (S.null (updateCapabilities S.\\ targetCapabilities))+ filteredByCaps =+ if noAddedCaps+ then filter (not . addsCapabilities) mergeCandidates+ else mergeCandidates++soP :: Parser SignOptions+soP =+ SignOptions+ <$> switch (long "no-armor" <> help "don't armor the output")+ <*> optional+ ( strOption+ ( long "micalg-out"+ <> metavar "MICALG"+ <> help "write MIME micalg parameter value to file"+ )+ )+ <*> many+ ( strOption+ ( long "with-key-password"+ <> help "password for unlocking signing key material"+ )+ )+ <*> option+ (eitherReader asTypeReader)+ (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)+ <*> some+ ( strArgument+ ( metavar "KEYS..."+ <> help "paths to at least one secret key, one key per filename"+ )+ )+ where+ astypeHelp =+ helpDoc . Just $+ pretty "what to treat the input as"+ <> softline+ <> list (map (pretty . fst) asTypes)++data SignOptions+ = SignOptions+ { sNoArmor :: Bool+ , sMicalgOut :: Maybe String+ , sKeyPasswords :: [String]+ , sAs :: AsBinaryText+ , sKeyFiles :: [String]+ }++asTypes :: [(String, AsBinaryText)]+asTypes = [("binary", AsBinary), ("text", AsText)]++data AsBinaryText+ = AsBinary+ | AsText+ deriving (Eq)++data InlineSignMode+ = InlineSignAsBinary+ | InlineSignAsText+ | InlineSignAsClearSigned+ deriving (Eq)++data EncryptFor+ = EncryptForAny+ | EncryptForStorage+ | EncryptForCommunications+ deriving (Eq)++asTypeReader :: String -> Either String AsBinaryText+asTypeReader = note "unknown as type" . flip lookup asTypes++encryptForReader :: String -> Either String EncryptFor+encryptForReader "any" = Right EncryptForAny+encryptForReader "storage" = Right EncryptForStorage+encryptForReader "communications" = Right EncryptForCommunications+encryptForReader _ =+ Left+ "encryption purpose must be one of: any, storage, communications"++doSign :: POSIXTime -> SignOptions -> IO ()+doSign pt SignOptions {..} = do+ forM_ sMicalgOut (ensureOutputPathAvailable "sign")+ mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume+ when (sAs == AsText) $+ ensureUTF8TextInput "sign" (BL.fromChunks mbs)+ forM_+ sMicalgOut+ (\_ -> ensureCanonicalMIMETextInput (BL.fromChunks mbs))+ signingPasswordsRaw <-+ loadPasswordFiles "sign" "--with-key-password" sKeyPasswords+ let signingPasswords =+ map+ Passphrase+ ( concatMap+ (passwordRetryCandidates . BL.toStrict)+ signingPasswordsRaw+ )+ ks <- loadSigningKeys "sign" sKeyFiles signingPasswords+ let ts = ThirtyTwoBitTimeStamp (floor pt)+ payload' = BL.fromChunks mbs+ payload = payload'+ processedKeys <- mapM (normalizeSigningKey pt) ks+ let perTransferKeySigners = map (signingCapableRSAFunKeys pt . SomeSecretTK) processedKeys+ signingHash =+ selectSigningHash+ (concat perTransferKeySigners)+ []+ legacySigningHashFallbackOrder+ when (any null perTransferKeySigners) $+ failWith+ KeyCannotSign+ "sign: supplied key cannot produce detached signatures"+ signatures <-+ mapM+ (signData sAs ts signingHash payload)+ (concat perTransferKeySigners)+ let output = runPut (mapM_ (Bin.put . SignaturePkt) signatures)+ case sMicalgOut of+ Just outPath ->+ writeFileWithOutputExistsCheck+ "sign"+ outPath+ (renderMicalg signatures)+ Nothing -> pure ()+ BL.putStr $+ if not sNoArmor+ then AA.encodeLazy [Armor ArmorSignature [] output]+ else output+ where+ signData+ :: AsBinaryText+ -> ThirtyTwoBitTimeStamp+ -> HashAlgorithm+ -> BL.ByteString+ -> FunKey+ -> IO SignaturePayload+ signData mode t signHash d k = do+ let st = case mode of+ AsBinary -> BinarySig+ AsText -> CanonicalTextSig+ payload = d+ issuerPackets <- unhashed (fpkp k)+ signWithKey+ "sign"+ (fpkp k)+ st+ signHash+ (hashed (fpkp k) t)+ issuerPackets+ payload+ (fmska k)+ hashed pkp ct =+ [ SigSubPacket False (SigCreationTime ct)+ , SigSubPacket+ False+ ( IssuerFingerprint+ (issuerFingerprintVersionFor pkp)+ (fingerprint pkp)+ )+ ]+ unhashed pkp = issuerSubpacketsFor "sign" pkp+loadSigningKeys+ :: String -> [String] -> [Passphrase] -> IO [TK 'SecretTK]+loadSigningKeys context keyFiles keyPasswords = concat <$> mapM loadSigningKeyFile keyFiles+ where+ loadSigningKeyFile path = do+ packets <- loadOpenPGPPackets context path+ tks <-+ runConduitRes $+ CL.sourceList packets+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList+ let fallbackTks = signingFallbackTKs packets+ when (null tks && null fallbackTks) $+ failWith+ MissingInput+ ("sign: no secret key material found in " ++ path)+ let secretTks =+ if null tks+ then map secretTKFromSome fallbackTks+ else onlySecretTKs tks+ mapM+ (decryptSigningKeyMaterial path keyPasswords)+ secretTks++decryptSigningKeyMaterial+ :: FilePath -> [Passphrase] -> TK 'SecretTK -> IO (TK 'SecretTK)+decryptSigningKeyMaterial path keyPasswords tk =+ unlockTransferableSecretKeyMaterial+ "sign failed"+ path+ "--with-key-password"+ keyPasswords+ tk++unlockTransferableSecretKeyMaterial+ :: String+ -> FilePath+ -> String+ -> [Passphrase]+ -> TK 'SecretTK+ -> IO (TK 'SecretTK)+unlockTransferableSecretKeyMaterial context path passwordOption keyPasswords tk =+ modifyTKSecretKeysM+ tk+ (unlockSecretAddendum context path passwordOption keyPasswords)++unlockSecretAddendum+ :: MonadIO m+ => String+ -> FilePath+ -> String+ -> [Passphrase]+ -> SomePKPayload+ -> SKAddendum+ -> m SKAddendum+unlockSecretAddendum _ _ _ _ _ sk@(SUSUnprotected _ _) = 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 decryptSecretKeyAddendum pkp sk password of+ Left _ -> tryDecrypt rest+ Right (_, decrypted) -> Right decrypted++normalizeSigningKey+ :: POSIXTime -> TK 'SecretTK -> IO (TK 'SecretTK)+normalizeSigningKey pt tk =+ case processTK (Just pt) (SomeSecretTK tk) of+ Left err ->+ failWith+ BadData+ ("sign: invalid signing key material: " ++ show err)+ Right normalized ->+ case normalized of+ SomeSecretTK tk' -> pure tk'+ SomePublicTK {} -> error "normalizeSigningKey: expected secret key"++signPayloadWithKeys+ :: POSIXTime+ -> AsBinaryText+ -> BL.ByteString+ -> [TK 'SecretTK]+ -> [HashAlgorithm]+ -> [HashAlgorithm]+ -> IO [SignaturePayload]+signPayloadWithKeys pt asMode payload keys recipientHashPrefs fallbackOrder = do+ processedKeys <- mapM (normalizeSigningKey pt) keys+ let perTransferKeySigners = map (signingCapableRSAFunKeys pt . SomeSecretTK) processedKeys+ signingHash =+ selectSigningHash+ (concat perTransferKeySigners)+ recipientHashPrefs+ fallbackOrder+ when (any null perTransferKeySigners) $+ failWith+ KeyCannotSign+ "encrypt: supplied key cannot produce signatures"+ mapM+ (signData asMode ts signingHash payload)+ (concat perTransferKeySigners)+ where+ ts = ThirtyTwoBitTimeStamp (floor pt)+ signData+ :: AsBinaryText+ -> ThirtyTwoBitTimeStamp+ -> HashAlgorithm+ -> BL.ByteString+ -> FunKey+ -> IO SignaturePayload+ signData mode t signHash d' k = do+ let st = case mode of+ AsBinary -> BinarySig+ AsText -> CanonicalTextSig+ payload' = d'+ issuerPackets <- unhashed (fpkp k)+ signWithKey+ "encrypt"+ (fpkp k)+ st+ signHash+ (hashed (fpkp k) t)+ issuerPackets+ payload'+ (fmska k)+ hashed pkp ct =+ [ SigSubPacket False (SigCreationTime ct)+ , SigSubPacket+ False+ ( IssuerFingerprint+ (issuerFingerprintVersionFor pkp)+ (fingerprint pkp)+ )+ ]+ unhashed pkp = issuerSubpacketsFor "encrypt" pkp++signingCapableFunKeys :: POSIXTime -> SomeTK -> [FunKey]+signingCapableFunKeys pt =+ filter canSign . tkToFunKeysAt pt+ where+ canSign k =+ canSignDataUsage (fkufs k)+ && case fmska k of+ Just (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey _)) _) -> True+ Just (SUSUnprotected (EdDSAPrivateKey _ _) _) -> True+ Just (SUSUnprotected (Ed25519PrivateKey _) _) -> True+ Just (SUSUnprotected (Ed448PrivateKey _) _) -> True+ Just (SUSUnprotected (UnknownSKey _) _) ->+ isEd25519PKA (_pkalgo (fpkp k))+ || isEdDSAPKA (_pkalgo (fpkp k))+ || isEd448PKA (_pkalgo (fpkp k))+ _ -> False+ canSignDataUsage keyFlags = S.null keyFlags || S.member SignDataKey keyFlags++-- Legacy alias kept for internal call sites that have not been updated.+signingCapableRSAFunKeys :: POSIXTime -> SomeTK -> [FunKey]+signingCapableRSAFunKeys = signingCapableFunKeys++{- | Algorithm-dispatching signature helper used by all sign paths.+Supports RSA (v4), Ed25519 (v4), and Ed448 (v4).+-}+signWithKey+ :: String+ -- ^ context for error messages+ -> SomePKPayload+ -> SigType+ -> HashAlgorithm+ -> [SigSubPacket]+ -- ^ hashed subpackets+ -> [SigSubPacket]+ -- ^ unhashed subpackets+ -> BL.ByteString+ -- ^ payload to sign+ -> Maybe SKAddendum+ -> IO SignaturePayload+signWithKey ctx signerPKP st signHash hsd usd payload mska =+ case mska of+ Just (SUSUnprotected (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+ (SUSUnprotected (EdDSAPrivateKey EdSigningCurve25519 rawBytes) _) ->+ signWithEd25519SecretKey+ ctx+ signerPKP+ st+ signHash+ hsd+ usd+ payload+ rawBytes+ Just+ (SUSUnprotected (Ed25519PrivateKey rawBytes) _) ->+ signWithEd25519SecretKey+ ctx+ signerPKP+ st+ signHash+ hsd+ usd+ payload+ rawBytes+ Just+ (SUSUnprotected (EdDSAPrivateKey EdSigningCurve448 rawBytes) _) ->+ signWithEd448SecretKey+ ctx+ signerPKP+ st+ signHash+ hsd+ usd+ payload+ rawBytes+ Just+ (SUSUnprotected (Ed448PrivateKey rawBytes) _) ->+ signWithEd448SecretKey+ ctx+ signerPKP+ st+ signHash+ hsd+ usd+ payload+ rawBytes+ Just (SUSUnprotected (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 signHash st sk hsd usd payload of+ Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')+ Right sig -> pure sig+ | otherwise ->+ case signDataWithEd25519 signHash 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 signHash 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 signHash st salt sk hsd usd payload+ )+ signEd448 sk =+ signWithV6Salt+ (\salt -> signDataWithEd448V6 signHash st salt sk hsd usd payload)+ signRSAWithV6Salt privateKey =+ signWithV6Salt+ ( \salt ->+ signDataWithRSAV6Builder+ ( SP.addUnhashedSubs+ (SubpacketList usd)+ ( SP.addHashedSubs+ (SubpacketList hsd)+ (SP.sigBuilderInitV6 st signHash salt)+ )+ )+ privateKey+ 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 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++ signWithEd25519SecretKey ctx signerPKP st signHash hsd usd payload 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 signHash st sk hsd usd payload of+ Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')+ Right sig -> pure sig+ | otherwise ->+ case signDataWithEd25519 signHash st sk hsd usd payload of+ Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')+ Right sig -> pure sig+ signWithEd448SecretKey ctx signerPKP st signHash hsd usd payload 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 signHash st sk hsd usd 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)++-- ==============================+-- update-key modernization helpers+-- ==============================++-- Deprecated algorithms that MUST be stripped from output+deprecatedHashAlgorithms :: [HashAlgorithm]+deprecatedHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160]++deprecatedSymmetricAlgorithms :: [SymmetricAlgorithm]+deprecatedSymmetricAlgorithms = [IDEA, TripleDES]++supportedCompression :: CompressionAlgorithm -> Bool+supportedCompression Uncompressed = True+supportedCompression ZIP = True+supportedCompression ZLIB = True+supportedCompression BZip2 = True+supportedCompression _ = False++supportedAEAD :: (SymmetricAlgorithm, AEADAlgorithm) -> Bool+supportedAEAD (_, OCB) = True+supportedAEAD (_, GCM) = True+supportedAEAD (_, EAX) = True+supportedAEAD _ = False++supportedFeature :: FeatureFlag -> Bool+supportedFeature FeatureSEIPDv2 = True+supportedFeature _ = False++{- | Remediate illegal or legacy Issuer subpackets:+ * Replace Issuer (0x10) with IssuerFingerprint (0x15) in unhashed subpackets+ * Move IssuerFingerprint from hashed to unhashed subpackets+-}+remediateIssuerSubpackets+ :: SomePKPayload+ -> Fingerprint+ -> [SigSubPacket]+ -> ([SigSubPacket], [SigSubPacket])+remediateIssuerSubpackets pkp fp sps =+ (cleanedHashed, cleanedUnhashed)+ where+ ifv =+ if _keyVersion pkp == V6+ then IssuerFingerprintV6+ else IssuerFingerprintV4+ isHashed (SigSubPacket False _) = False+ isHashed (SigSubPacket True _) = True+ (hashed, unhashed) = partition isHashed sps+ cleanedHashed = mapMaybe goHashed hashed+ cleanedUnhashed = mapMaybe goUnhashed unhashed+ goHashed (SigSubPacket _ (Issuer _)) = Nothing+ goHashed (SigSubPacket _ (IssuerFingerprint _ _)) = Nothing+ goHashed sp = Just sp+ goUnhashed (SigSubPacket crit (Issuer _)) =+ Just (SigSubPacket crit (IssuerFingerprint ifv fp))+ goUnhashed sp = Just sp++{- | Filter deprecated entries from a hashed-subpacket list.+Only strips; never adds new capabilities.+-}+cleanHashedSubpackets :: [SigSubPacket] -> [SigSubPacket]+cleanHashedSubpackets = mapMaybe keep+ where+ keep (SigSubPacket _ (PreferredHashAlgorithms hs)) =+ let hs' = filter (`notElem` deprecatedHashAlgorithms) hs+ in if null hs'+ then Nothing+ else Just (SigSubPacket False (PreferredHashAlgorithms hs'))+ keep (SigSubPacket _ (PreferredSymmetricAlgorithms sas)) =+ let sas' = filter (`notElem` deprecatedSymmetricAlgorithms) sas+ in if null sas'+ then Nothing+ else+ Just (SigSubPacket False (PreferredSymmetricAlgorithms sas'))+ keep (SigSubPacket _ (PreferredCompressionAlgorithms cas)) =+ let cas' = filter supportedCompression cas+ in if null cas'+ then Nothing+ else+ Just (SigSubPacket False (PreferredCompressionAlgorithms cas'))+ keep (SigSubPacket _ (PreferredAEADCiphersuites suites)) =+ let suites' = filter supportedAEAD suites+ in if null suites'+ then Nothing+ else+ Just (SigSubPacket False (PreferredAEADCiphersuites suites'))+ keep (SigSubPacket _ (Features flags)) =+ let flags' = S.filter supportedFeature flags+ in if S.null flags'+ then Nothing+ else Just (SigSubPacket False (Features flags'))+ keep other = Just other++-- | Re-sign a direct-key or revocation signature with cleaned subpackets.+resignDirectKey+ :: String+ -> KeyPkt 'SecretPkt+ -> SignaturePayload+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> IO SignaturePayload+resignDirectKey ctx kp origSig cleanedHashed unhashed = do+ let (hashAlgo, st) = case origSig of+ SigV4 st0 _pka ha0 _hsps _usps _w16 _mpis -> (ha0, st0)+ SigV6 st0 _pka ha0 _salt _hsps _usps _w16 _mpis -> (ha0, st0)+ _ -> error "resignDirectKey: unsupported signature version"+ case kp of+ KeyPktSecretPrimary _ ska ->+ case ska of+ SUSUnprotected (RSAPrivateKey (RSA_PrivateKey k)) _ -> do+ result <-+ signDirectKey+ hashAlgo+ st+ kp+ cleanedHashed+ unhashed+ (k {RSA.private_p = 0, RSA.private_q = 0})+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve25519 rawBytes) _ ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith+ BadData+ (ctx ++ " failed: bad Ed25519 key: " ++ show err)+ Right sk -> do+ result <- signDirectKey hashAlgo st kp cleanedHashed unhashed sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (Ed25519PrivateKey rawBytes) _ ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith+ BadData+ (ctx ++ " failed: bad Ed25519 key: " ++ show err)+ Right sk -> do+ result <- signDirectKey hashAlgo st kp cleanedHashed unhashed sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve448 rawBytes) _ ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err ->+ failWith BadData (ctx ++ " failed: bad Ed448 key: " ++ show err)+ Right sk -> do+ result <- signDirectKey hashAlgo st kp cleanedHashed unhashed sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (Ed448PrivateKey rawBytes) _ ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err ->+ failWith BadData (ctx ++ " failed: bad Ed448 key: " ++ show err)+ Right sk -> do+ result <- signDirectKey hashAlgo st kp cleanedHashed unhashed sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ _ ->+ failWith BadData (ctx ++ " failed: unsupported secret key type")+ _ ->+ failWith BadData (ctx ++ " failed: no signing key material")++-- | Re-sign a UID certification with cleaned subpackets.+resignCertification+ :: String+ -> KeyPkt 'SecretPkt+ -> UserId+ -> SignaturePayload+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> IO SignaturePayload+resignCertification ctx kp uid origSig cleanedHashed unhashed = do+ let (hashAlgo, st) = case origSig of+ SigV4 st0 _pka ha0 _hsps _usps _w16 _mpis -> (ha0, st0)+ SigV6 st0 _pka ha0 _salt _hsps _usps _w16 _mpis -> (ha0, st0)+ _ -> error "resignCertification: unsupported signature version"+ case kp of+ KeyPktSecretPrimary _ ska ->+ case ska of+ SUSUnprotected (RSAPrivateKey (RSA_PrivateKey k)) _ -> do+ result <-+ signUserId+ hashAlgo+ st+ kp+ uid+ cleanedHashed+ unhashed+ (k {RSA.private_p = 0, RSA.private_q = 0})+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve25519 rawBytes) _ ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith+ BadData+ (ctx ++ " failed: bad Ed25519 key: " ++ show err)+ Right sk -> do+ result <- signUserId hashAlgo st kp uid cleanedHashed unhashed sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (Ed25519PrivateKey rawBytes) _ ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith+ BadData+ (ctx ++ " failed: bad Ed25519 key: " ++ show err)+ Right sk -> do+ result <- signUserId hashAlgo st kp uid cleanedHashed unhashed sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve448 rawBytes) _ ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err ->+ failWith BadData (ctx ++ " failed: bad Ed448 key: " ++ show err)+ Right sk -> do+ result <- signUserId hashAlgo st kp uid cleanedHashed unhashed sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (Ed448PrivateKey rawBytes) _ ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err ->+ failWith BadData (ctx ++ " failed: bad Ed448 key: " ++ show err)+ Right sk -> do+ result <- signUserId hashAlgo st kp uid cleanedHashed unhashed sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ _ ->+ failWith BadData (ctx ++ " failed: unsupported secret key type")+ _ ->+ failWith BadData (ctx ++ " failed: no signing key material")++-- | Re-sign a user-attribute certification with cleaned subpackets.+resignUserAttributeCertification+ :: String+ -> KeyPkt 'SecretPkt+ -> [UserAttrSubPacket]+ -> SignaturePayload+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> IO SignaturePayload+resignUserAttributeCertification ctx kp uats origSig cleanedHashed unhashed = do+ let (hashAlgo, st) = case origSig of+ SigV4 st0 _pka ha0 _hsps _usps _w16 _mpis -> (ha0, st0)+ SigV6 st0 _pka ha0 _salt _hsps _usps _w16 _mpis -> (ha0, st0)+ _ ->+ error+ "resignUserAttributeCertification: unsupported signature version"+ case kp of+ KeyPktSecretPrimary _ ska ->+ case ska of+ SUSUnprotected (RSAPrivateKey (RSA_PrivateKey k)) _ -> do+ result <-+ signUat+ hashAlgo+ st+ kp+ (UserAttribute uats)+ cleanedHashed+ unhashed+ (k {RSA.private_p = 0, RSA.private_q = 0})+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve25519 rawBytes) _ ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith+ BadData+ (ctx ++ " failed: bad Ed25519 key: " ++ show err)+ Right sk -> do+ result <-+ signUat+ hashAlgo+ st+ kp+ (UserAttribute uats)+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (Ed25519PrivateKey rawBytes) _ ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith+ BadData+ (ctx ++ " failed: bad Ed25519 key: " ++ show err)+ Right sk -> do+ result <-+ signUat+ hashAlgo+ st+ kp+ (UserAttribute uats)+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve448 rawBytes) _ ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err ->+ failWith BadData (ctx ++ " failed: bad Ed448 key: " ++ show err)+ Right sk -> do+ result <-+ signUat+ hashAlgo+ st+ kp+ (UserAttribute uats)+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ SUSUnprotected (Ed448PrivateKey rawBytes) _ ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err ->+ failWith BadData (ctx ++ " failed: bad Ed448 key: " ++ show err)+ Right sk -> do+ result <-+ signUat+ hashAlgo+ st+ kp+ (UserAttribute uats)+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ _ ->+ failWith BadData (ctx ++ " failed: unsupported secret key type")+ _ ->+ failWith BadData (ctx ++ " failed: no signing key material")++{- | Re-sign a subkey binding or revocation signature with cleaned subpackets.+NOTE: EmbeddedSignature subpackets on signing-capable subkeys are not+re-signed; that requires re-signing the embedded signature payload and+is left as future work.+-}+resignSubkeyBinding+ :: String+ -> KeyPkt 'SecretPkt+ -> KeyPkt 'SecretPkt+ -> SignaturePayload+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> IO SignaturePayload+resignSubkeyBinding ctx primaryKp subkeyKp origSig cleanedHashed unhashed = do+ let (hashAlgo, st) = case origSig of+ SigV4 st0 _pka ha0 _hsps _usps _w16 _mpis -> (ha0, st0)+ SigV6 st0 _pka ha0 _salt _hsps _usps _w16 _mpis -> (ha0, st0)+ _ -> error "resignSubkeyBinding: unsupported signature version"+ case primaryKp of+ KeyPktSecretPrimary _ ska ->+ case ska of+ SUSUnprotected (RSAPrivateKey (RSA_PrivateKey k)) _ ->+ if st == SubkeyBindingSig+ then do+ result <-+ signSubkeyBinding+ hashAlgo+ primaryKp+ subkeyKp+ cleanedHashed+ unhashed+ (k {RSA.private_p = 0, RSA.private_q = 0})+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ else+ if st == SubkeyRevocationSig+ then do+ result <-+ signSubkeyRevocation+ hashAlgo+ primaryKp+ subkeyKp+ cleanedHashed+ unhashed+ (k {RSA.private_p = 0, RSA.private_q = 0})+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ else+ failWith BadData (ctx ++ " failed: unexpected signature type")+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve25519 rawBytes) _ ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith+ BadData+ (ctx ++ " failed: bad Ed25519 key: " ++ show err)+ Right sk ->+ if st == SubkeyBindingSig+ then do+ result <-+ signSubkeyBinding+ hashAlgo+ primaryKp+ subkeyKp+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ else+ if st == SubkeyRevocationSig+ then do+ result <-+ signSubkeyRevocation+ hashAlgo+ primaryKp+ subkeyKp+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ else+ failWith BadData (ctx ++ " failed: unexpected signature type")+ SUSUnprotected (Ed25519PrivateKey rawBytes) _ ->+ case eitherCryptoError (Ed25519.secretKey rawBytes) of+ Left err ->+ failWith+ BadData+ (ctx ++ " failed: bad Ed25519 key: " ++ show err)+ Right sk ->+ if st == SubkeyBindingSig+ then do+ result <-+ signSubkeyBinding+ hashAlgo+ primaryKp+ subkeyKp+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ else+ if st == SubkeyRevocationSig+ then do+ result <-+ signSubkeyRevocation+ hashAlgo+ primaryKp+ subkeyKp+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ else+ failWith BadData (ctx ++ " failed: unexpected signature type")+ SUSUnprotected (EdDSAPrivateKey EdSigningCurve448 rawBytes) _ ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err ->+ failWith BadData (ctx ++ " failed: bad Ed448 key: " ++ show err)+ Right sk ->+ if st == SubkeyBindingSig+ then do+ result <-+ signSubkeyBinding+ hashAlgo+ primaryKp+ subkeyKp+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ else+ if st == SubkeyRevocationSig+ then do+ result <-+ signSubkeyRevocation+ hashAlgo+ primaryKp+ subkeyKp+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ else+ failWith BadData (ctx ++ " failed: unexpected signature type")+ SUSUnprotected (Ed448PrivateKey rawBytes) _ ->+ case eitherCryptoError (Ed448.secretKey rawBytes) of+ Left err ->+ failWith BadData (ctx ++ " failed: bad Ed448 key: " ++ show err)+ Right sk ->+ if st == SubkeyBindingSig+ then do+ result <-+ signSubkeyBinding+ hashAlgo+ primaryKp+ subkeyKp+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ else+ if st == SubkeyRevocationSig+ then do+ result <-+ signSubkeyRevocation+ hashAlgo+ primaryKp+ subkeyKp+ cleanedHashed+ unhashed+ sk+ either+ (\err -> failWith BadData (ctx ++ " failed: " ++ show err))+ pure+ result+ else+ failWith BadData (ctx ++ " failed: unexpected signature type")+ _ ->+ failWith BadData (ctx ++ " failed: unsupported secret key type")+ _ ->+ failWith BadData (ctx ++ " failed: no signing key material")++{- | Check whether a signature should be refreshed due to expiry.+A signature that is already expired or will expire within 259200 seconds+(3 days) of runtime MUST be refreshed.+-}+expiryRefreshThreshold :: NominalDiffTime+expiryRefreshThreshold = 259200++isSignatureExpiredNearExpiry+ :: POSIXTime -> SignaturePayload -> Bool+isSignatureExpiredNearExpiry pt sig =+ case effectiveSignatureExpiry pt sig of+ Nothing -> False+ Just expiryEnd ->+ let remaining = expiryEnd - pt+ in remaining <= expiryRefreshThreshold || remaining < 0++{- | Compute the absolute expiry time of a signature, if any.+Falls back to the primary key's expiry if the signature itself has none.+-}+effectiveSignatureExpiry+ :: POSIXTime -> SignaturePayload -> Maybe POSIXTime+effectiveSignatureExpiry pt sig =+ case sigExpiryFromSubpackets sig of+ Just d -> Just (pt + realToFrac d)+ Nothing -> Nothing+ where+ sigExpiryFromSubpackets (SigV4 _ _ _ hashed _ _ _) = findSigExpiry hashed+ sigExpiryFromSubpackets (SigV6 _ _ _ _ hashed _ _ _) = findSigExpiry hashed+ sigExpiryFromSubpackets _ = Nothing+ findSigExpiry = foldr go Nothing+ where+ go (SigSubPacket _ (SigExpirationTime d)) _ = Just d+ go _ acc = acc++{- | Walk every signature in a key and re-sign those whose hashed subpackets+contain deprecated or unsupported algorithms, or that are expired/near-expiry.+Only secret keys can be re-signed; public keys are returned unchanged.+-}+modernizeSignatures :: POSIXTime -> SomeTK -> IO SomeTK+modernizeSignatures _cpt stk@(SomePublicTK _) = pure stk+modernizeSignatures cpt stk@(SomeSecretTK tk) = do+ cleanedRevs <- mapM (modernizeOne primaryKp) (_tkRevs publicView)+ cleanedDirectSigs <-+ mapM (modernizeOne primaryKp) (_tkDirectKeySigs publicView)+ cleanedUIDs <-+ mapM (modernizeOneUID primaryKp) (_tkUIDs publicView)+ cleanedUAts <-+ mapM (modernizeOneUAt primaryKp) (_tkUAts publicView)+ cleanedSubs <- mapM (modernizeOneSub primaryKp) (_tkSubs tk)+ pure $+ SomeSecretTK+ tk+ { _tkRevs = cleanedRevs+ , _tkDirectKeySigs = cleanedDirectSigs+ , _tkUIDs = cleanedUIDs+ , _tkUAts = cleanedUAts+ , _tkSubs = cleanedSubs+ }+ where+ publicView = someTKToPublicViewTK stk+ primaryKp = _tkPrimaryKey tk+ fp = fingerprint (keyPktPKPayload primaryKp)+ modernizeOne primaryKp sig = do+ let (hs, us) =+ remediateIssuerSubpackets+ (keyPktPKPayload primaryKp)+ fp+ (signatureSubpackets sig)+ hs' =+ if needsModernization hs || isSignatureExpiredNearExpiry cpt sig+ then cleanHashedSubpackets hs+ else hs+ if needsModernization hs || isSignatureExpiredNearExpiry cpt sig+ then resignDirectKey "update-key" primaryKp sig hs' us+ else pure sig+ modernizeOneUID primaryKp (uid, sigs) = do+ let allSubs = concatMap signatureSubpackets sigs+ (_, us) =+ remediateIssuerSubpackets (keyPktPKPayload primaryKp) fp allSubs+ hsPerSig =+ map+ ( \sig ->+ if needsModernization (signatureHashedSubpackets sig)+ || isSignatureExpiredNearExpiry cpt sig+ then cleanHashedSubpackets (signatureHashedSubpackets sig)+ else signatureHashedSubpackets sig+ )+ sigs+ newSigs <-+ mapM+ (\(sig, hsig, us) -> resignOne sig hsig us)+ (zip3 sigs hsPerSig (repeat us))+ pure (uid, newSigs)+ where+ resignOne sig hsig us =+ if needsModernization hsig || isSignatureExpiredNearExpiry cpt sig+ then+ resignCertification+ "update-key"+ primaryKp+ (UserId uid)+ sig+ hsig+ us+ else pure sig+ modernizeOneUAt primaryKp (uats, sigs) = do+ let allSubs = concatMap signatureSubpackets sigs+ (_, us) =+ remediateIssuerSubpackets (keyPktPKPayload primaryKp) fp allSubs+ hsPerSig =+ map+ ( \sig ->+ if needsModernization (signatureHashedSubpackets sig)+ || isSignatureExpiredNearExpiry cpt sig+ then cleanHashedSubpackets (signatureHashedSubpackets sig)+ else signatureHashedSubpackets sig+ )+ sigs+ newSigs <-+ mapM+ (\(sig, hsig, us) -> resignOne sig hsig us)+ (zip3 sigs hsPerSig (repeat us))+ pure (uats, newSigs)+ where+ resignOne sig hsig us =+ if needsModernization hsig || isSignatureExpiredNearExpiry cpt sig+ then+ resignUserAttributeCertification+ "update-key"+ primaryKp+ uats+ sig+ hsig+ us+ else pure sig+ modernizeOneSub primaryKp (kp, sigs) = do+ let allSubs = concatMap signatureSubpackets sigs+ (_, us) =+ remediateIssuerSubpackets (keyPktPKPayload primaryKp) fp allSubs+ hsPerSig =+ map+ ( \sig ->+ if needsModernization (signatureHashedSubpackets sig)+ || isSignatureExpiredNearExpiry cpt sig+ then cleanHashedSubpackets (signatureHashedSubpackets sig)+ else signatureHashedSubpackets sig+ )+ sigs+ newSigs <-+ mapM+ (\(sig, hsig, us) -> resignOne sig hsig us)+ (zip3 sigs hsPerSig (repeat us))+ pure (kp, newSigs)+ where+ resignOne sig hsig us =+ if needsModernization hsig || isSignatureExpiredNearExpiry cpt sig+ then resignSubkeyBinding "update-key" primaryKp kp sig hsig us+ else pure sig+ needsModernization hs = any isDeprecatedSubpacket hs+ isDeprecatedSubpacket (SigSubPacket _ (PreferredHashAlgorithms hs)) = any (`elem` deprecatedHashAlgorithms) hs+ isDeprecatedSubpacket (SigSubPacket _ (PreferredSymmetricAlgorithms sas)) = any (`elem` deprecatedSymmetricAlgorithms) sas+ isDeprecatedSubpacket (SigSubPacket _ (PreferredCompressionAlgorithms cas)) = any (not . supportedCompression) cas+ isDeprecatedSubpacket (SigSubPacket _ (PreferredAEADCiphersuites suites)) = any (not . supportedAEAD) suites+ isDeprecatedSubpacket (SigSubPacket _ (Features flags)) = any (not . supportedFeature) flags+ isDeprecatedSubpacket _ = False++-- | Verify that a key has at least one signing-capable component key.+hasSigningCapability :: POSIXTime -> SomeTK -> Bool+hasSigningCapability = updateKeyHasSigningCapability++-- | Verify that a key has at least one decryption-capable component key.+hasDecryptionCapability :: POSIXTime -> SomeTK -> Bool+hasDecryptionCapability cpt tk =+ any+ ( \funKey ->+ S.member EncryptStorageKey (fkufs funKey)+ || S.member EncryptCommunicationsKey (fkufs funKey)+ )+ (tkToFunKeysAt cpt tk)++{- | When --signing-only is set, strip subkeys that do not have signing+capability from the output key.+-}+stripNonSigningSubkeys :: SomeTK -> SomeTK+stripNonSigningSubkeys stk = case stk of+ SomePublicTK tk ->+ SomePublicTK+ tk {_tkSubs = filter subkeyHasSigningCapability (_tkSubs tk)}+ SomeSecretTK tk ->+ SomeSecretTK+ tk {_tkSubs = filter subkeyHasSigningCapability (_tkSubs tk)}++-- FIXME: clean this up+isEd25519PKA, isEd448PKA, isEdDSAPKA :: PubKeyAlgorithm -> Bool+isEd25519PKA pka = fromFVal pka == 27+isEdDSAPKA pka = fromFVal pka == 22+isEd448PKA pka = fromFVal pka == 28++selectSigningHash+ :: [FunKey] -> [HashAlgorithm] -> [HashAlgorithm] -> HashAlgorithm+selectSigningHash signerKeys recipientHashPrefs fallbackOrder =+ fromMaybe+ SHA512+ (find (hashSupportedByAllSigners signerKeys) candidateOrder)+ where+ requestedPrefs =+ if null recipientHashPrefs+ then signerPrefs+ else recipientHashPrefs+ signerPrefs = concatMap fpreferredHashes signerKeys+ filteredRequested = filter (hashSupportedByAllSigners signerKeys) requestedPrefs+ filteredSignerPrefs = filter (hashSupportedByAllSigners signerKeys) signerPrefs+ candidateOrder = filteredRequested ++ filteredSignerPrefs ++ fallbackOrder++legacySigningHashFallbackOrder :: [HashAlgorithm]+legacySigningHashFallbackOrder = [SHA512, SHA384, SHA256, SHA224]++rfc9580SigningHashFallbackOrder :: [HashAlgorithm]+rfc9580SigningHashFallbackOrder = [SHA3_512, SHA3_256, SHA512, SHA384, SHA256, SHA224]++hashSupportedByAllSigners :: [FunKey] -> HashAlgorithm -> Bool+hashSupportedByAllSigners signers ha =+ not (isDeprecatedHashAlgorithm ha)+ && all (`signerSupportsHashAlgorithm` ha) signers++signerSupportsHashAlgorithm :: FunKey -> HashAlgorithm -> Bool+signerSupportsHashAlgorithm signer ha =+ not (isDeprecatedHashAlgorithm ha)+ && case _pkalgo (fpkp signer) of+ RSA -> rsaPKCS15SupportedHash ha+ DeprecatedRSASignOnly -> rsaPKCS15SupportedHash ha+ DeprecatedRSAEncryptOnly -> rsaPKCS15SupportedHash ha+ _ -> not (isOtherHashAlgorithm ha)++rsaPKCS15SupportedHash :: HashAlgorithm -> Bool+rsaPKCS15SupportedHash SHA224 = True+rsaPKCS15SupportedHash SHA256 = True+rsaPKCS15SupportedHash SHA384 = True+rsaPKCS15SupportedHash SHA512 = True+rsaPKCS15SupportedHash _ = False++isDeprecatedHashAlgorithm :: HashAlgorithm -> Bool+isDeprecatedHashAlgorithm DeprecatedMD5 = True+isDeprecatedHashAlgorithm SHA1 = True+isDeprecatedHashAlgorithm RIPEMD160 = True+isDeprecatedHashAlgorithm _ = False++isOtherHashAlgorithm :: HashAlgorithm -> Bool+isOtherHashAlgorithm (OtherHA _) = True+isOtherHashAlgorithm _ = False++hashAlgorithmHeaderName :: HashAlgorithm -> String+hashAlgorithmHeaderName DeprecatedMD5 = "MD5"+hashAlgorithmHeaderName SHA1 = "SHA1"+hashAlgorithmHeaderName RIPEMD160 = "RIPEMD160"+hashAlgorithmHeaderName SHA224 = "SHA224"+hashAlgorithmHeaderName SHA256 = "SHA256"+hashAlgorithmHeaderName SHA384 = "SHA384"+hashAlgorithmHeaderName SHA512 = "SHA512"+hashAlgorithmHeaderName SHA3_256 = "SHA3-256"+hashAlgorithmHeaderName SHA3_512 = "SHA3-512"+hashAlgorithmHeaderName (OtherHA _) = "SHA512"++ensureCanonicalMIMETextInput :: BL.ByteString -> IO ()+ensureCanonicalMIMETextInput lbs = do+ let bs = BL.toStrict lbs+ when (B.any (> 0x7f) bs) $+ failWith+ ExpectedText+ "sign: --micalg-out requires canonical 7-bit text data on standard input"+ case TE.decodeUtf8' bs of+ Left _ ->+ failWith+ ExpectedText+ "sign: --micalg-out requires UTF-8 text data on standard input"+ Right _ -> pure ()+ when (not (canonicalCRLFLineEndings bs)) $+ failWith+ ExpectedText+ "sign: --micalg-out requires CRLF line endings on standard input"+ when (hasTrailingLineWhitespace bs) $+ failWith+ ExpectedText+ "sign: --micalg-out requires no trailing line whitespace on standard input"+ where+ canonicalCRLFLineEndings bytes = go (B.unpack bytes)+ where+ go [] = True+ go [13] = False+ go (13 : 10 : rest) = go rest+ go (13 : _) = False+ go (10 : _) = False+ go (_ : rest) = go rest+ hasTrailingLineWhitespace bytes =+ endsWithWhitespace bytes+ || trailingWhitespaceBeforeCRLF (B.unpack bytes)+ endsWithWhitespace bytes =+ case B.unsnoc bytes of+ Just (_, c) -> c == 32 || c == 9+ Nothing -> False+ trailingWhitespaceBeforeCRLF (a : 13 : 10 : rest)+ | a == 32 || a == 9 = True+ | otherwise = trailingWhitespaceBeforeCRLF (13 : 10 : rest)+ trailingWhitespaceBeforeCRLF (_ : rest) = trailingWhitespaceBeforeCRLF rest+ trailingWhitespaceBeforeCRLF _ = False++ensureUTF8TextInput :: String -> BL.ByteString -> IO ()+ensureUTF8TextInput subcommand lbs =+ case TE.decodeUtf8' (BL.toStrict lbs) of+ Left _ ->+ failWith+ ExpectedText+ (subcommand ++ ": --as=text requires UTF-8 text on standard input")+ Right _ -> pure ()++renderMicalg :: [SignaturePayload] -> String+renderMicalg signatures =+ case nub (mapMaybe signatureMicalg signatures) of+ [micalg] -> micalg+ _ -> ""+ where+ signatureMicalg (SigV4 _ _ ha _ _ _ _) = hashAlgorithmMicalg ha+ signatureMicalg _ = Nothing+ hashAlgorithmMicalg DeprecatedMD5 = Just "pgp-md5"+ hashAlgorithmMicalg SHA1 = Just "pgp-sha1"+ hashAlgorithmMicalg RIPEMD160 = Just "pgp-ripemd160"+ hashAlgorithmMicalg SHA224 = Just "pgp-sha224"+ hashAlgorithmMicalg SHA256 = Just "pgp-sha256"+ hashAlgorithmMicalg SHA384 = Just "pgp-sha384"+ hashAlgorithmMicalg SHA512 = Just "pgp-sha512"+ hashAlgorithmMicalg SHA3_256 = Just "pgp-sha3-256"+ hashAlgorithmMicalg SHA3_512 = Just "pgp-sha3-512"+ hashAlgorithmMicalg (OtherHA _) = Nothing++signingFallbackTKs :: [Pkt] -> [SomeTK]+signingFallbackTKs packets =+ [ SomeSecretTK+ TK+ { _tkPrimaryKey = KeyPktSecretPrimary pkp ska+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ | SecretKeyPkt pkp ska <- packets+ ]++data FunKey+ = FunKey+ { fpkp :: SomePKPayload+ , fmska :: Maybe SKAddendum+ , fkufs :: S.Set KeyFlag+ , fpreferredHashes :: [HashAlgorithm]+ , fpreferredSymmetricAlgorithms :: [SymmetricAlgorithm]+ , fsupportsSEIPDv2 :: Bool+ }+ deriving (Show)++tkToFunKeysAt :: POSIXTime -> SomeTK -> [FunKey]+tkToFunKeysAt pt stk =+ catMaybes+ ( mainKey : case stk of+ SomePublicTK _ -> map extractPublic (_tkSubs publicView)+ SomeSecretTK secretTk -> map extractSecret (_tkSubs secretTk)+ )+ where+ publicView = someTKToPublicViewTK stk+ pkp = keyPktPKPayload (_tkPrimaryKey publicView)+ mska = case stk of+ SomeSecretTK secretTk -> case _tkPrimaryKey secretTk of+ KeyPktSecretPrimary _ ska -> Just ska+ _ -> Nothing+ SomePublicTK _ -> Nothing+ uids = _tkUIDs publicView+ mainPreferredHashes = effectiveHashPreferencesAt pt stk+ mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt stk+ mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt stk+ mainKey =+ Just+ ( FunKey+ pkp+ mska+ (fromMaybe S.empty (grabASig uids >>= sig2KUFs))+ mainPreferredHashes+ mainPreferredSymmetricAlgorithms+ mainSupportsSEIPDv2+ )+ sig2KUFs = getHasheds >=> find isKUF >=> getKUFs+ grabASig :: [(a, [b])] -> Maybe b+ grabASig = (listToMaybe >=> listToMaybe) . map snd -- FIXME: this should grab the "best" sig+ getHasheds :: SignaturePayload -> Maybe [SigSubPacket]+ getHasheds (SigV4 _ _ _ hasheds _ _ _) = Just hasheds+ getHasheds (SigV6 _ _ _ _ hasheds _ _ _) = Just hasheds+ getHasheds _ = Nothing+ getKUFs :: SigSubPacket -> Maybe (S.Set KeyFlag)+ getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs+ getKUFs _ = Nothing+ extractPublic :: (KeyPkt k, [SignaturePayload]) -> Maybe FunKey+ extractPublic (KeyPktPublicSubkey spkp, sigs) =+ return+ ( FunKey+ spkp+ Nothing+ (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))+ mainPreferredHashes+ mainPreferredSymmetricAlgorithms+ mainSupportsSEIPDv2+ )+ extractPublic _ = Nothing+ extractSecret :: (KeyPkt k, [SignaturePayload]) -> Maybe FunKey+ extractSecret (KeyPktSecretSubkey spkp sska, sigs) =+ return+ ( FunKey+ spkp+ (Just sska)+ (fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))+ mainPreferredHashes+ mainPreferredSymmetricAlgorithms+ mainSupportsSEIPDv2+ )+ extractSecret _ = Nothing++effectiveHashPreferencesAt+ :: POSIXTime -> SomeTK -> [HashAlgorithm]+effectiveHashPreferencesAt pt tk =+ concatMap toHashes $+ fromMaybe+ []+ ( effectiveKeyPreferencesAt+ (posixSecondsToUTCTime (realToFrac pt))+ (someTKToPublicViewTK tk)+ )+ where+ toHashes (PreferredHashAlgorithms hashes) = hashes+ toHashes _ = []++effectiveSymmetricPreferencesAt+ :: POSIXTime -> SomeTK -> [SymmetricAlgorithm]+effectiveSymmetricPreferencesAt pt tk =+ concatMap toSymmetricAlgorithms $+ fromMaybe+ []+ ( effectiveKeyPreferencesAt+ (posixSecondsToUTCTime (realToFrac pt))+ (someTKToPublicViewTK tk)+ )+ where+ toSymmetricAlgorithms (PreferredSymmetricAlgorithms algorithms) = algorithms+ toSymmetricAlgorithms _ = []++effectiveSEIPDv2SupportAt :: POSIXTime -> SomeTK -> Bool+effectiveSEIPDv2SupportAt pt tk =+ any supportsSEIPDv2Flag $+ concatMap toFeatureFlags $+ fromMaybe+ []+ ( effectiveKeyPreferencesAt+ (posixSecondsToUTCTime (realToFrac pt))+ (someTKToPublicViewTK tk)+ )+ where+ toFeatureFlags (Features flags) = S.toList flags+ toFeatureFlags _ = []+ supportsSEIPDv2Flag FeatureSEIPDv2 = True+ supportsSEIPDv2Flag _ = False++-- SOP Handler Stubs+-- These implement the stateless OpenPGP CLI commands per draft-16++doVerify :: POSIXTime -> VerifyOptions -> IO ()+doVerify cpt VerifyOptions {..} = do+ (krs, verifyTks) <- loadVerifyContext cpt verifyCertFiles+ signatureInput <-+ runConduitRes $ CC.sourceFile verifySigFile .| CC.sinkLazy+ sigPkts <- decodeLikeSignaturePackets signatureInput+ let sigs = V.fromList (filter isDetachedVerificationSignaturePkt sigPkts)+ blob <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ upperBound <- verificationUpperBound cpt verifyNotAfter+ lowerBound <- verificationLowerBound cpt verifyNotBefore+ let sigsWithoutUnsupportedCritical =+ V.filter+ (not . detachedSignatureHasUnsupportedCriticalSubpackets)+ sigs+ binaryVerifications <-+ verifyWithLiteralData+ BinaryData+ blob+ sigsWithoutUnsupportedCritical+ krs+ upperBound+ verifications <-+ if any isRight binaryVerifications+ then pure binaryVerifications+ else+ verifyWithLiteralData+ TextData+ blob+ sigsWithoutUnsupportedCritical+ krs+ upperBound+ let decodedVerifications = map (first show) verifications+ signerPolicyAdjusted =+ map+ (enforceVerificationSignerPolicy cpt verifyTks)+ decodedVerifications+ let filtered =+ filterByVerificationBounds+ lowerBound+ upperBound+ signerPolicyAdjusted+ policyFiltered =+ filter (not . verificationResultUsesDeprecatedHash) filtered+ mapM_+ (putStrLn . renderSOPVerificationLine verifyTks)+ (rights policyFiltered)+ case any isRight policyFiltered of+ True -> exitSuccess+ _ -> failWith NoSignature "No acceptable signatures found"+ where+ decodeLikeSignaturePackets lbs = do+ decodedArmors <-+ decodeAsciiArmorInput+ ("signature input in " ++ verifySigFile)+ lbs+ case decodedArmors of+ Just armors ->+ case firstBy isDetachedSignatureArmor armors of+ Just (Armor ArmorSignature _ bs) ->+ parseOpenPGPPackets+ ("signature input in " ++ verifySigFile)+ (BL.fromStrict (BLC8.toStrict bs))+ _ ->+ case firstBy isDetachedSignatureUnsupportedArmor armors of+ Just (ClearSigned _ _ _) ->+ failWith+ BadData+ ("verify: expected detached signatures in " ++ verifySigFile)+ Just (Armor _ _ _) ->+ failWith+ BadData+ ("verify: expected signature armor in " ++ verifySigFile)+ _ ->+ parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs+ Nothing ->+ parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs+ verifyWithLiteralData format payload sigs keyring upperBound =+ runConduitRes $+ CC.yieldMany+ (V.cons (LiteralDataPkt format (FileName mempty) 0 payload) sigs)+ .| conduitVerify keyring upperBound+ .| CC.sinkList++detachedSignatureHasUnsupportedCriticalSubpackets :: Pkt -> Bool+detachedSignatureHasUnsupportedCriticalSubpackets (SignaturePkt sig) =+ any criticalUnsupported (signatureHashedSubpackets sig)+ where+ criticalUnsupported (SigSubPacket True (OtherSigSub _ _)) = True+ criticalUnsupported (SigSubPacket True (UserDefinedSigSub _ _)) = True+ criticalUnsupported (SigSubPacket True (NotationData _ _ _)) = True+ criticalUnsupported _ = False+detachedSignatureHasUnsupportedCriticalSubpackets _ = False++signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]+signatureHashedSubpackets (SigV4 _ _ _ hashed _ _ _) = hashed+signatureHashedSubpackets (SigV6 _ _ _ _ hashed _ _ _) = hashed+signatureHashedSubpackets _ = []++verificationResultUsesDeprecatedHash+ :: Either String Verification -> Bool+verificationResultUsesDeprecatedHash (Right verification) =+ verificationUsesDeprecatedHash verification+verificationResultUsesDeprecatedHash _ = False++verificationUsesDeprecatedHash :: Verification -> Bool+verificationUsesDeprecatedHash (Verification _ sigPayload _) =+ isDeprecatedHashAlgorithm (signatureHashAlgorithm sigPayload)++signatureHashAlgorithm :: SignaturePayload -> HashAlgorithm+signatureHashAlgorithm (SigV3 _ _ _ _ ha _ _) = ha+signatureHashAlgorithm (SigV4 _ _ ha _ _ _ _) = ha+signatureHashAlgorithm (SigV6 _ _ ha _ _ _ _ _) = ha+signatureHashAlgorithm (SigVOther _ _) = OtherHA 0++enforceVerificationSignerPolicy+ :: POSIXTime+ -> [SomeTK]+ -> Either String Verification+ -> Either String Verification+enforceVerificationSignerPolicy _ _ result@(Left _) = result+enforceVerificationSignerPolicy cpt verifyTks result@(Right verification)+ | signerAllowed = result+ | otherwise =+ Left+ "verification failed: signer key is not valid for signing at signature creation time"+ where+ signerAllowed = any signerMatchesProcessed verifyTks+ signerFp = fingerprint (_verificationSigner verification)+ verificationTimePosix =+ maybe+ cpt+ (realToFrac . utcTimeToPOSIXSeconds)+ (signatureCreationTime (_verificationSignature verification))+ verificationTime = posixSecondsToUTCTime verificationTimePosix+ signerMatchesProcessed tk+ | not (keyMatchesFingerprint True tk signerFp) = False+ | keyMatchesFingerprint False tk signerFp = True+ | otherwise =+ any+ (subkeyAllowsSigning verificationTime signerFp)+ ( map+ (\(kp, sigs) -> (keyPktToPkt kp, sigs))+ (_tkSubs (someTKToPublicViewTK tk))+ )++subkeyAllowsSigning+ :: UTCTime -> Fingerprint -> (Pkt, [SignaturePayload]) -> Bool+subkeyAllowsSigning t signerFp (pkt, sigs) =+ case subkeyPayload pkt of+ Just pkp+ | fingerprint pkp == signerFp ->+ any+ (bindingSignatureAllowsSigning t)+ (filter isSKBindingSig sigs)+ _ -> False+ where+ subkeyPayload (PublicSubkeyPkt pkp) = Just pkp+ subkeyPayload (SecretSubkeyPkt pkp _) = Just pkp+ subkeyPayload _ = Nothing++bindingSignatureAllowsSigning+ :: UTCTime -> SignaturePayload -> Bool+bindingSignatureAllowsSigning t sig =+ allowsSigning && hasValidBacksig+ where+ allowsSigning =+ let flagSets = signatureKeyFlagSets sig+ in null flagSets || any (S.member SignDataKey) flagSets+ hasValidBacksig =+ any+ ( \embedded ->+ isPKBindingSig embedded+ && not (signatureExpiredAt t embedded)+ )+ (signatureEmbeddedSignatures sig)++signatureEmbeddedSignatures+ :: SignaturePayload -> [SignaturePayload]+signatureEmbeddedSignatures sig =+ [ embedded+ | SigSubPacket _ (EmbeddedSignature embedded) <-+ signatureSubpackets sig+ ]++signatureKeyFlagSets :: SignaturePayload -> [S.Set KeyFlag]+signatureKeyFlagSets sig =+ [ flags+ | SigSubPacket _ (KeyFlags flags) <- signatureSubpackets sig+ ]++signatureExpiredAt :: UTCTime -> SignaturePayload -> Bool+signatureExpiredAt t sig =+ case (signatureCreationTime sig, signatureValiditySeconds sig) of+ (Just created, Just validitySeconds) ->+ utcTimeToPOSIXSeconds t+ >= utcTimeToPOSIXSeconds created + fromIntegral validitySeconds+ _ -> False++signatureValiditySeconds :: SignaturePayload -> Maybe Integer+signatureValiditySeconds sig =+ listToMaybe+ [ fromIntegral secs+ | SigSubPacket _ (SigExpirationTime (ThirtyTwoBitDuration secs)) <-+ signatureSubpackets sig+ ]+verificationUpperBound+ :: POSIXTime -> Maybe String -> IO (Maybe UTCTime)+verificationUpperBound cpt Nothing = return (Just (posixSecondsToUTCTime cpt))+verificationUpperBound _ (Just "-") = return Nothing+verificationUpperBound cpt (Just "now") =+ return (Just (posixSecondsToUTCTime cpt))+verificationUpperBound _ (Just s) = do+ let m = iso8601ParseM s :: Maybe UTCTime+ case m of+ Just t -> return (Just t)+ Nothing -> failWith BadData ("Invalid DATE value: " ++ s)++verificationLowerBound+ :: POSIXTime -> Maybe String -> IO (Maybe UTCTime)+verificationLowerBound _ Nothing = return Nothing+verificationLowerBound _ (Just "-") = return Nothing+verificationLowerBound cpt (Just "now") =+ return (Just (posixSecondsToUTCTime cpt))+verificationLowerBound _ (Just s) = do+ let m = iso8601ParseM s :: Maybe UTCTime+ case m of+ Just t -> return (Just t)+ Nothing -> failWith BadData ("Invalid DATE value: " ++ s)++filterByVerificationBounds+ :: Maybe UTCTime+ -> Maybe UTCTime+ -> [Either String Verification]+ -> [Either String Verification]+filterByVerificationBounds lower upper = map (>>= ensureBounds)+ where+ ensureBounds v =+ case signatureCreationTime (_verificationSignature v) of+ Nothing ->+ Left "verification failed: signature is missing creation time"+ Just sigTime+ | Just upperBound <- upper+ , sigTime > upperBound ->+ Left+ "verification failed: signature created after --not-after bound"+ | Just lowerBound <- lower+ , sigTime < lowerBound ->+ Left+ "verification failed: signature created before --not-before bound"+ | otherwise -> Right v++signatureCreationTime :: SignaturePayload -> Maybe UTCTime+signatureCreationTime (SigV4 _ _ _ hashed _ _ _) =+ firstCreationTime hashed+signatureCreationTime (SigV6 _ _ _ _ hashed _ _ _) =+ firstCreationTime hashed+signatureCreationTime _ = Nothing++firstCreationTime :: [SigSubPacket] -> Maybe UTCTime+firstCreationTime = listToMaybe . mapMaybe getCreation+ where+ getCreation (SigSubPacket _ (SigCreationTime (ThirtyTwoBitTimeStamp ts))) =+ Just (posixSecondsToUTCTime (fromIntegral ts))+ getCreation _ = Nothing++isDetachedVerificationSignaturePkt :: Pkt -> Bool+isDetachedVerificationSignaturePkt (SignaturePkt (SigV4 sigType _ _ _ _ _ _)) =+ sigType == BinarySig || sigType == CanonicalTextSig+isDetachedVerificationSignaturePkt (SignaturePkt (SigV6 sigType _ _ _ _ _ _ _)) =+ sigType == BinarySig || sigType == CanonicalTextSig+isDetachedVerificationSignaturePkt _ = False++doInlineVerify :: POSIXTime -> InlineVerifyOptions -> IO ()+doInlineVerify cpt InlineVerifyOptions {..} = do+ (krs, verifyTks) <- loadVerifyContext cpt inlineCertFiles+ signedInput <-+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ upperBound <- verificationUpperBound cpt inlineNotAfter+ lowerBound <- verificationLowerBound cpt inlineNotBefore+ (allowTrailingSignatures, parsedPackets) <-+ inlineVerifyPackets signedInput+ packets <-+ normalizeInlineVerifyPackets+ allowTrailingSignatures+ parsedPackets+ let verifications =+ map (first show) (verifyPacketsBatch krs upperBound packets)+ filtered = filterByVerificationBounds lowerBound upperBound verifications+ successLines = map (renderSOPVerificationLine verifyTks) (rights filtered)+ renderedOut =+ if null successLines+ then ""+ else unlines successLines+ case verificationsOut of+ Just outPath ->+ writeFileWithOutputExistsCheck+ "inline-verify"+ outPath+ renderedOut+ Nothing -> pure ()+ case any isRight filtered of+ True ->+ extractSingleLiteralPayload packets >>= BL.putStr >> exitSuccess+ _ -> failWith NoSignature "No acceptable signatures found"+ where+ inlineVerifyPackets :: BL.ByteString -> IO (Bool, [Pkt])+ inlineVerifyPackets lbs = do+ decodedArmors <- decodeAsciiArmorInput "inline-verify input" lbs+ case decodedArmors+ >>= listToMaybe . filter isInlineVerifyCandidateArmor 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+ (FileName B.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)++ parseInlineVerifyMessagePackets+ :: String -> BL.ByteString -> IO [Pkt]+ parseInlineVerifyMessagePackets context packetBytes = do+ rawPkts <- parseRawOpenPGPPackets context packetBytes+ when (any compressedPacketParseFailed rawPkts) $+ failWith+ BadData+ "inline-verify input has malformed compressed packet data"+ when (any compressedPacketIsEmpty rawPkts) $+ failWith+ BadData+ "inline-verify input has empty compressed packet data"+ expanded <- expandPacketsStrict context rawPkts+ when+ (any isMarkerPacket expanded && any isCompressedPacket rawPkts)+ $ failWith+ BadData+ "inline-verify input has malformed compressed packet sequence"+ pure expanded++ expandPacketsStrict :: String -> [Pkt] -> IO [Pkt]+ expandPacketsStrict context =+ fmap concat . mapM expandPacket+ where+ expandPacket pkt =+ case decompressPkt pkt of+ Left err ->+ failWith+ BadData+ ( context+ ++ ": failed to parse compressed packet: "+ ++ renderCompressionError err+ )+ Right packets -> pure packets++isInlineVerifyCandidateArmor :: Armor -> Bool+isInlineVerifyCandidateArmor (Armor ArmorMessage _ _) = True+isInlineVerifyCandidateArmor ClearSigned {} = True+isInlineVerifyCandidateArmor _ = False++clearSignedSignaturePackets :: Armor -> IO [Pkt]+clearSignedSignaturePackets (Armor ArmorSignature _ sigbs) =+ let sigPktsSource =+ parseOpenPGPPackets+ "cleartext signature block"+ (BL.fromStrict (BLC8.toStrict sigbs))+ in do+ parsed <- sigPktsSource+ let sigPkts = filter isSignaturePkt parsed+ if null sigPkts+ then+ failWith+ BadData+ "cleartext signature block has no signature packets"+ else return sigPkts+clearSignedSignaturePackets (Armor _ _ _) =+ failWith+ BadData+ "cleartext signed message does not contain an armored signature block"+clearSignedSignaturePackets (ClearSigned _ _ inner) =+ clearSignedSignaturePackets inner++isSignaturePkt :: Pkt -> Bool+isSignaturePkt SignaturePkt {} = True+isSignaturePkt _ = False++normalizeInlineVerifyPackets :: Bool -> [Pkt] -> IO [Pkt]+normalizeInlineVerifyPackets allowTrailingSignatures pkts+ | any isBrokenPacket relevantPkts =+ failWith+ BadData+ "inline-verify input contains malformed packet encoding"+ | any (not . isInlineVerificationPacket) filteredPkts =+ failWith+ BadData+ "inline-verify input contains unsupported packet types"+ | otherwise =+ case ( [pkt | pkt@LiteralDataPkt {} <- filteredPkts]+ , [pkt | pkt@SignaturePkt {} <- filteredPkts]+ ) of+ ([], _) ->+ failWith+ BadData+ "inline-verify input has no literal message payload"+ ([_], []) ->+ failWith+ BadData+ "inline-verify input has no signatures"+ ([lit], sigs)+ | not hasOnePass+ && ( null signaturePositions+ || not (all (< literalIndex) signaturePositions)+ )+ && ( not allowTrailingSignatures+ || not (all (> literalIndex) signaturePositions)+ ) ->+ failWith+ BadData+ "inline-verify input has malformed signed-message packet order"+ | otherwise -> pure (lit : sigs)+ (_, _) ->+ failWith+ BadData+ "inline-verify input contains multiple literal payloads"+ where+ relevantPkts = filter (not . isMarkerPacket) pkts+ filteredPkts = filter (not . isIgnorableInlineVerifyPacket) relevantPkts+ packetPositions = zip [0 :: Int ..] filteredPkts+ signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]+ onePassPositions = [i | (i, OnePassSignaturePkt {}) <- packetPositions]+ literalPositions = [i | (i, LiteralDataPkt {}) <- packetPositions]+ hasOnePass = not (null onePassPositions)+ literalIndex =+ case literalPositions of+ (i : _) -> i+ [] -> -1+ isBrokenPacket BrokenPacketPkt {} = True+ isBrokenPacket _ = False++isIgnorableInlineVerifyPacket :: Pkt -> Bool+isIgnorableInlineVerifyPacket (OtherPacketPkt tag _) = tag >= 40+isIgnorableInlineVerifyPacket _ = False++isInlineVerificationPacket :: Pkt -> Bool+isInlineVerificationPacket LiteralDataPkt {} = True+isInlineVerificationPacket SignaturePkt {} = True+isInlineVerificationPacket OnePassSignaturePkt {} = True+isInlineVerificationPacket (OtherPacketPkt tag _) = tag >= 40+isInlineVerificationPacket BrokenPacketPkt {} = False+isInlineVerificationPacket _ = False++doEncrypt :: POSIXTime -> EncryptOptions -> IO ()+doEncrypt cpt EncryptOptions {..} = do+ payload <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ when (encAs == AsText) $+ ensureUTF8TextInput "encrypt" payload+ symmetricPasswordsRaw <-+ loadPasswordFiles "encrypt" "--with-password" encPasswords+ symmetricPasswordsStrict <-+ mapM+ ( normalizeHumanReadablePassword "encrypt" "--with-password"+ . BL.toStrict+ )+ symmetricPasswordsRaw+ let symmetricPasswords = symmetricPasswordsStrict+ signingKeyPasswordsRaw <-+ loadPasswordFiles+ "encrypt"+ "--with-key-password"+ encSignWithKeyPasswords+ let signingKeyPasswords =+ map+ Passphrase+ ( concatMap+ (passwordRetryCandidates . BL.toStrict)+ signingKeyPasswordsRaw+ )+ encryptProfile <- parseEncryptProfile encProfile+ when+ (not (null encRecipientCerts) && not (null symmetricPasswords))+ $ failWith+ UnsupportedOption+ "encrypt: combining recipient certificates with --with-password is not yet supported"+ recipientKeys <-+ if null encRecipientCerts+ then pure []+ else loadEncryptRecipients cpt encFor encRecipientCerts+ recipientHashPrefs <-+ if null encRecipientCerts+ then pure []+ else loadRecipientPreferredHashes cpt encRecipientCerts+ signatures <-+ if null encSignWithKeyFiles+ then pure []+ else do+ signingKeys <-+ loadSigningKeys "encrypt" encSignWithKeyFiles signingKeyPasswords+ signPayloadWithKeys+ cpt+ encAs+ payload+ signingKeys+ recipientHashPrefs+ ( case encryptProfile of+ EncryptProfileRFC9580 -> rfc9580SigningHashFallbackOrder+ EncryptProfileRFC4880 -> legacySigningHashFallbackOrder+ )+ out <-+ case encRecipientCerts of+ [] ->+ doEncryptWithPassword+ encryptProfile+ payload+ symmetricPasswords+ encSessionKeyOutFile+ _ ->+ doEncryptForRecipients+ encryptProfile+ encAs+ payload+ signatures+ recipientKeys+ encSessionKeyOutFile+ BL.putStr $+ if encNoArmor+ then out+ else AA.encodeLazy [Armor ArmorMessage [] out]++doEncryptWithPassword+ :: EncryptProfile+ -> BL.ByteString+ -> [Passphrase]+ -> 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+ }+ 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+ }+ password+ (mkClearPayload payload)+ case encrypted of+ Left err -> failWith BadData ("encrypt failed: " ++ show err)+ Right (ciphertext, mRecoveredSession) -> do+ forM_ sessionKeyOutFile $ \path ->+ case mRecoveredSession of+ Just recoveredSession ->+ writeFileWithOutputExistsCheck+ "encrypt"+ path+ ( renderSessionKeyOutLine+ (fromFVal (recoveredSessionAlgorithm recoveredSession))+ (unSessionKey (recoveredSessionKey recoveredSession))+ ++ "\n"+ )+ Nothing ->+ failWith+ UnsupportedOption+ "encrypt: --session-key-out unavailable for this password encryption mode"+ pure (encryptedPayloadBytes ciphertext)++doEncryptForRecipients+ :: EncryptProfile+ -> AsBinaryText+ -> BL.ByteString+ -> [SignaturePayload]+ -> [FunKey]+ -> Maybe String+ -> IO BL.ByteString+doEncryptForRecipients encryptProfile asMode payload signatures recipients sessionKeyOutFile = do+ let targets = map recipientTargetFor recipients+ payloadShape =+ defaultRecipientPayloadShape+ { recipientPayloadDataType = literalDataType+ , recipientPayloadUseOnePassSignatures = not (null signatures)+ , recipientPayloadSignatures = signatures+ }+ result <-+ if useStrictEncryptProfile+ then+ encryptForRecipients+ RecipientEncryptRequest+ { recipientEncryptRequestTargets = targets+ , recipientEncryptRequestPayloadShape = payloadShape+ , recipientEncryptRequestPayload = BL.toStrict payload+ , recipientEncryptRequestSymmetricOverride = symmetricOverride+ , recipientEncryptRequestOverrides =+ RecipientEncryptRequestSEIPDv2Overrides+ { recipientEncryptRequestAEADOverride = Nothing+ , recipientEncryptRequestChunkSizeOverride = Nothing+ , recipientEncryptRequestSaltOverride = Nothing+ }+ }+ else+ encryptForRecipients+ RecipientEncryptRequest+ { recipientEncryptRequestTargets = targets+ , recipientEncryptRequestPayloadShape = payloadShape+ , recipientEncryptRequestPayload = BL.toStrict payload+ , recipientEncryptRequestSymmetricOverride = symmetricOverride+ , recipientEncryptRequestOverrides =+ RecipientEncryptRequestSEIPDv1Overrides+ { recipientEncryptRequestIVOverride = Nothing+ }+ }+ RecipientEncryptResult {..} <-+ case result of+ Left err ->+ failWith+ (sopFailureForPKESKEncryptError err)+ ("encrypt failed: " ++ renderPKESKEncryptError err)+ Right val -> pure val+ forM_ sessionKeyOutFile $ \path ->+ writeFileWithOutputExistsCheck+ "encrypt"+ path+ ( renderSessionKeyOutLine+ (fromFVal (pkeskSessionAlgorithm recipientEncryptSessionMaterial))+ (unSessionKey (pkeskSessionKey recipientEncryptSessionMaterial))+ ++ "\n"+ )+ pure (runPut (Bin.put (Block recipientEncryptPackets)))+ where+ literalDataType =+ case asMode of+ AsBinary -> BinaryData+ AsText -> UTF8Data+ anyRecipientSupportsSEIPDv2 = any fsupportsSEIPDv2 recipients+ symmetricOverride+ | useStrictEncryptProfile =+ preferredStrictSymmetric <|> Just AES256+ | otherwise = preferredLegacySymmetric+ isV6Recipient pkp = _keyVersion pkp == V6+ useStrictEncryptProfile =+ case encryptProfile of+ EncryptProfileRFC9580 ->+ anyRecipientSupportsSEIPDv2+ || any (isV6Recipient . fpkp) recipients+ EncryptProfileRFC4880 ->+ anyRecipientSupportsSEIPDv2+ || any (isV6Recipient . fpkp) recipients+ preferredStrictSymmetric =+ preferredRecipientSymmetric isSupportedStrictEncryptSymmetric+ preferredLegacySymmetric =+ preferredRecipientSymmetric isSupportedLegacyEncryptSymmetric+ preferredRecipientSymmetric isSupported =+ case filter+ (not . null)+ (map fpreferredSymmetricAlgorithms recipients) of+ [] -> Nothing+ (prefList : prefLists) ->+ listToMaybe+ [ candidate+ | candidate <- filter isSupported prefList+ , all (candidate `elem`) prefLists+ ]+ isSupportedStrictEncryptSymmetric algo =+ algo `elem` [AES128, AES192, AES256]+ -- Legacy profile fallback should not hard-fail on deprecated/unsupported+ -- recipient preferences (e.g. IDEA in AEADED interop fixtures).+ isSupportedLegacyEncryptSymmetric algo =+ algo `elem` [AES128, AES192, AES256]+ recipientTargetFor funkey =+ let recipient = fpkp funkey+ recipientNeedsV6PKESK =+ useStrictEncryptProfile+ && (fsupportsSEIPDv2 funkey || _keyVersion recipient == V6)+ in if _keyVersion recipient == V6+ then+ recipientEncryptionTargetWithStrategyTyped+ recipient+ RecipientPreferV6W+ else case _pkalgo recipient of+ ECDH ->+ -- Under strict (SEIPDv2) mode, keep Curve25519-compatible v4 ECDH keys on+ -- the X25519/v6 path so ESK/payload versions stay aligned.+ if recipientNeedsV6PKESK+ then case normalizeX25519CompatibleECDHRecipient recipient of+ Just x25519Recipient ->+ recipientEncryptionTargetWithStrategyTyped+ x25519Recipient+ RecipientPreferV6W+ Nothing ->+ recipientEncryptionTargetWithStrategyTyped+ recipient+ RecipientPreferV6W+ else+ recipientEncryptionTargetWithStrategyTyped+ recipient+ RecipientForceV3InteropW+ DeprecatedRSAEncryptOnly ->+ if recipientNeedsV6PKESK+ then+ recipientEncryptionTargetWithStrategyTyped+ recipient+ RecipientPreferV6W+ else+ recipientEncryptionTargetWithStrategyTyped+ recipient+ RecipientForceV3InteropW+ RSA ->+ if recipientNeedsV6PKESK+ then+ recipientEncryptionTargetWithStrategyTyped+ recipient+ RecipientPreferV6W+ else+ recipientEncryptionTargetWithStrategyTyped+ recipient+ RecipientForceV3InteropW+ _ ->+ if recipientNeedsV6PKESK+ then+ recipientEncryptionTargetWithStrategyTyped+ recipient+ RecipientPreferV6W+ else recipientEncryptionTarget recipient++ normalizeX25519CompatibleECDHRecipient pkp =+ case _pubkey pkp of+ ECDHPubKey (EdDSAPubKey EdSigningCurve25519 _) _ _ ->+ Just+ ( PKPayload+ (_keyVersion pkp)+ (_timestamp pkp)+ (_v3exp pkp)+ X25519+ (_pubkey pkp)+ )+ _ -> Nothing++parseEncryptProfile :: Maybe String -> IO EncryptProfile+parseEncryptProfile Nothing = pure EncryptProfileRFC9580+parseEncryptProfile (Just name) =+ case resolveProfile name encryptProfiles of+ Just p -> pure p+ Nothing ->+ failWith+ UnsupportedProfile+ ("encrypt: unsupported profile " ++ name)++doDecrypt :: POSIXTime -> DecryptOptions -> IO ()+doDecrypt cpt DecryptOptions {..} = do+ sessionKeys <- parseDecryptSessionKeys decSessionKeys+ verificationOutputPath <-+ resolveDecryptVerificationsOut decVerificationsOutFile+ let hasVerifyWith = not (null decVerifyCerts)+ hasVerifyOut = isJust verificationOutputPath+ hasVerifyBounds = isJust decVerifyNotBefore || isJust decVerifyNotAfter+ doingVerification = hasVerifyWith && hasVerifyOut+ when (hasVerifyWith /= hasVerifyOut) $+ failWith+ IncompleteVerification+ "decrypt: verification requires both --verify-with and --verifications-out"+ when (hasVerifyBounds && not doingVerification) $+ failWith+ IncompleteVerification+ "decrypt: --verify-not-before/--verify-not-after require both --verify-with and --verifications-out"+ passwords <-+ loadPasswordFiles "decrypt" "--with-password" decPasswords+ let symmetricPasswords =+ map+ Passphrase+ (concatMap (passwordRetryCandidates . BL.toStrict) passwords)+ keyPasswordsRaw <-+ loadPasswordFiles "decrypt" "--with-key-password" decKeyPasswords+ let keyPasswords =+ map+ Passphrase+ (concatMap (passwordRetryCandidates . BL.toStrict) keyPasswordsRaw)+ when+ (null symmetricPasswords && null sessionKeys && null decKeyFiles)+ $ failWith+ MissingArg+ "decrypt: supply KEYS, --with-password, or --with-session-key"+ ciphertextInput <-+ runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy+ ciphertext <- decodeCiphertextInput ciphertextInput+ validateDecryptPartialBodyEncoding ciphertext+ ciphertextPktsRaw <-+ parseRawOpenPGPPackets "decrypt input" ciphertext+ let ciphertextPkts =+ filter+ ( \pkt ->+ not+ ( isForwardCompatUnknownESKPacket pkt+ || isUnsupportedSKESKPacket pkt+ )+ )+ ciphertextPktsRaw+ -- Pre-flight: reject messages with no encrypted payload at all (upstream+ -- won't produce a useful DecryptMalformedStructure for the empty case).+ when (not (any isEncryptedPayloadPacket ciphertextPkts)) $+ failWith BadData "decrypt input: no encrypted data packet found"+ validateCiphertextPacketLayout ciphertextPkts+ recipientKeys <-+ loadDecryptRecipientKeys cpt "decrypt" decKeyFiles keyPasswords+ when+ ( null recipientKeys+ && not (null decKeyFiles)+ && null passwords+ && null sessionKeys+ )+ $ failWith+ CannotDecrypt+ "decrypt failed: no usable secret key material found in provided KEYS"+ let passwordAttempts =+ case symmetricPasswords of+ [] -> [[]]+ _ ->+ map+ (\password -> [password])+ symmetricPasswords+ 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 ->+ let reasonStr = renderDecryptStructureError reason+ in if shouldRetryLenientDecrypt reasonStr keyCandidates passwordBytes+ then do+ lenientOutcome <-+ runDecryptAttemptWithPolicy+ lenientDecryptPolicy+ keyCandidates+ passwordBytes+ case lenientOutcome of+ Right pkts -> pure pkts+ Left lenientReason ->+ failWith+ BadData+ ( "decrypt failed: malformed encrypted message structure ("+ ++ renderDecryptStructureError lenientReason+ ++ ")"+ )+ else+ failWith+ BadData+ ( "decrypt failed: malformed encrypted message structure ("+ ++ reasonStr+ ++ ")"+ )+ 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 . BL.toStrict) passwords)+ decryptedPkts <- do+ decompressed <-+ mapM+ ( either (\e -> failWith BadData (renderCompressionError e)) pure+ . recursivelyDecompressPacket+ )+ decryptedPktsRaw+ pure (concat decompressed)+ validateDecryptedMessageStructure decryptedPktsRaw decryptedPkts+ payload <- extractSingleLiteralPayload decryptedPkts+ BL.putStr payload+ case (decSessionKeyOutFile, sessionKeyOutLine) of+ (Just path, Just line) -> writeFileWithOutputExistsCheck "decrypt" path (line ++ "\n")+ _ -> pure ()+ when doingVerification $+ doDecryptVerifyOutput+ cpt+ decVerifyCerts+ verificationOutputPath+ decVerifyNotBefore+ decVerifyNotAfter+ decryptedPkts++data DecryptSessionKey+ = DecryptSessionKey+ { decryptSessionKeyMaterial :: BL.ByteString+ , decryptSessionKeyOutLine :: Maybe String+ }++decryptInputCallback+ :: IORef [Passphrase]+ -> IORef [BL.ByteString]+ -> String+ -> IO B.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 (BL.toStrict 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 (unPassphrase 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]+ -> [B.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]+ -> [B.ByteString]+ -> IO (Maybe String)+recoverSessionKeyOutFromCiphertext ciphertextPkts recipientKeys passwordCandidates =+ case recoverFromSKESK of+ Just line -> pure (Just line)+ Nothing -> recoverFromLegacyRSAPKESK+ where+ recoverFromSKESK =+ listToMaybe $+ mapMaybe+ ( \(SKESKPayloadV4 sa s2k maybeEsk, passphrase) ->+ case maybeEsk of+ Nothing ->+ case skesk2Key (SKESK4Packet sa s2k Nothing) passphrase of+ Left _ -> Nothing+ Right sessionKey ->+ Just (renderSessionKeyOutLine (fromFVal sa) sessionKey)+ Just esk ->+ case skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase of+ Left _ -> Nothing+ Right (algo, sessionKey) ->+ Just (renderSessionKeyOutLine (fromFVal algo) sessionKey)+ )+ [ (payload, passphrase)+ | payload <- skeskPayloadsV4+ , passphrase <- passwordCandidates+ ]+ skeskPayloadsV4 =+ mapMaybe+ ( \pkt ->+ case pkt of+ SKESKPkt (SKESKPayloadV4Packet payload) -> Just payload+ _ -> Nothing+ )+ ciphertextPkts+ recoverFromLegacyRSAPKESK =+ recoverRSACombos+ [(mpi, rsaKey) | mpi <- rsaPKESKMPIs, rsaKey <- rsaRecipientKeys]+ recoverRSACombos [] = pure Nothing+ recoverRSACombos ((mpi, rsaKey) : rest) = do+ encodedResult <- decryptLegacyRSAPKESK rsaKey mpi+ case encodedResult of+ Left _ -> recoverRSACombos rest+ Right encoded ->+ case decodeOpenPGPEncodedSessionKey encoded of+ Right (algo, keyBytes) ->+ pure (Just (renderSessionKeyOutLine (fromFVal algo) keyBytes))+ Left _ -> recoverRSACombos rest+ rsaPKESKMPIs =+ mapMaybe+ ( \pkt ->+ case pkt of+ PKESKPkt+ (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka (mpi :| [])))+ | pka == RSA || pka == DeprecatedRSAEncryptOnly ->+ Just mpi+ _ -> Nothing+ )+ ciphertextPkts+ rsaRecipientKeys =+ mapMaybe+ ( \keyInfo ->+ case pkeskRecipientSKey keyInfo of+ RSAPrivateKey (RSA_PrivateKey privateKey) -> Just privateKey+ _ -> Nothing+ )+ recipientKeys++decryptLegacyRSAPKESK+ :: RSA.PrivateKey -> MPI -> IO (Either String B.ByteString)+decryptLegacyRSAPKESK privateKey mpi = do+ attempted <-+ P15.decryptSafer privateKey (mpiToCiphertext privateKey mpi)+ pure (first show attempted)+ where+ mpiToCiphertext rsaKey (MPI encodedMPI) =+ let modulusBytes = rsaModulusOctets rsaKey+ in i2ospOf_ modulusBytes encodedMPI+ rsaModulusOctets rsaKey =+ let modulusBits = integerBitLength (RSA.public_n (RSA.private_pub rsaKey))+ in max 1 ((modulusBits + 7) `div` 8)+ integerBitLength n+ | n <= 0 = 0+ | otherwise = go n 0+ where+ go 0 bits = bits+ go val bits = go (val `div` 2) (bits + 1)++parseAlgorithmOctet :: String -> IO Word8+parseAlgorithmOctet algoSpec =+ case readMaybe algoSpec :: Maybe Int of+ Just octet+ | octet >= 0 && octet <= 255 ->+ case toFVal (fromIntegral octet) :: SymmetricAlgorithm of+ OtherSA _ ->+ failWith+ BadData+ ("decrypt: unsupported --with-session-key algorithm: " ++ algoSpec)+ _ -> pure (fromIntegral octet)+ _ ->+ failWith+ BadData+ ("decrypt: invalid --with-session-key algorithm: " ++ algoSpec)++decodeHexBytes :: String -> IO B.ByteString+decodeHexBytes hex =+ if odd (length hex)+ then+ failWith+ BadData+ "decrypt: hex key material must have an even number of digits"+ else B.pack <$> go hex+ where+ go [] = pure []+ go (a : b : rest) = do+ hi <- nibble a+ lo <- nibble b+ (fromIntegral (hi * 16 + lo) :) <$> go rest+ go _ = failWith BadData "decrypt: malformed hex key material"+ nibble c =+ if isHexDigit c+ then pure (digitToInt c)+ else failWith BadData "decrypt: key material must be hexadecimal"++isEncryptedPayloadPacket :: Pkt -> Bool+isEncryptedPayloadPacket SymEncIntegrityProtectedDataPkt {} = True+isEncryptedPayloadPacket SymEncDataPkt {} = True+isEncryptedPayloadPacket _ = False++isForwardCompatUnknownESKPacket :: Pkt -> Bool+isForwardCompatUnknownESKPacket (OtherPacketPkt tag _) = tag == 1 || tag == 3+isForwardCompatUnknownESKPacket (BrokenPacketPkt _ tag _) = tag == 1 || tag == 3+isForwardCompatUnknownESKPacket _ = False++isUnsupportedSKESKPacket :: Pkt -> Bool+isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ s2k _))) = isUnknownS2K s2k+isUnsupportedSKESKPacket (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ s2k _ _ _))) = isUnknownS2K s2k+isUnsupportedSKESKPacket _ = False++isUnknownS2K :: S2K -> Bool+isUnknownS2K OtherS2K {} = True+isUnknownS2K _ = False++validateCiphertextPacketLayout :: [Pkt] -> IO ()+validateCiphertextPacketLayout pkts =+ case findIndex isEncryptedPayloadPacket pkts of+ Nothing -> pure ()+ Just payloadIndex ->+ let trailing =+ filter+ (not . isMarkerPacketPacket)+ (drop (payloadIndex + 1) pkts)+ in when (not (null trailing)) $+ failWith+ BadData+ "decrypt input: malformed encrypted message structure (unexpected packets after encrypted data)"++isMarkerPacketPacket :: Pkt -> Bool+isMarkerPacketPacket MarkerPkt {} = True+isMarkerPacketPacket _ = False++validateDecryptedMessageStructure :: [Pkt] -> [Pkt] -> IO ()+validateDecryptedMessageStructure rawPkts pkts = do+ let literalCount = length [() | LiteralDataPkt {} <- pkts]+ signatureCount = length [() | SignaturePkt {} <- pkts]+ onePassCount = length [() | OnePassSignaturePkt {} <- pkts]+ hasCompressedRaw = any isCompressedPacket rawPkts+ hasUnknownPackets = any isUnknownPacket rawPkts || any isUnknownPacket pkts+ maxCompressionDepth = maximum (0 : map compressionDepth rawPkts)+ when (any compressedPacketParseFailed rawPkts) $+ failWith+ BadData+ "decrypt failed: malformed compressed data stream"+ when (maxCompressionDepth > 2) $+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (excessive compression nesting)"+ when (hasCompressedRaw && any isMarkerPacket pkts) $+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (compressed marker packet)"+ when (any isDisallowedDecryptedPacketType pkts) $+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (unexpected packet type in plaintext)"+ when (literalCount == 0) $+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (no literal data payload found)"+ when (literalCount > 1) $+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (multiple literal payloads)"+ when+ (not hasUnknownPackets && onePassCount > 0 && signatureCount == 0)+ $ failWith+ BadData+ "decrypt failed: malformed signed message structure (one-pass signature without trailing signature)"+ when+ ( not hasUnknownPackets+ && signatureCount > 0+ && onePassCount == 0+ && not isOldStyleSignedMessage+ )+ $ failWith+ BadData+ "decrypt failed: malformed signed message structure (trailing signature without one-pass signature)"+ where+ isOldStyleSignedMessage =+ case [i | (i, LiteralDataPkt {}) <- packetPositions] of+ [literalIndex] ->+ not (null signaturePositions)+ && all (< literalIndex) signaturePositions+ _ -> False+ packetPositions = zip [0 :: Int ..] (filter (not . isMarkerPacket) pkts)+ signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]++compressedPacketParseFailed :: Pkt -> Bool+compressedPacketParseFailed pkt@CompressedDataPkt {} = isLeft (decompressPkt pkt)+compressedPacketParseFailed _ = False++recursivelyDecompressPacket+ :: Pkt -> Either CompressionError [Pkt]+recursivelyDecompressPacket pkt@CompressedDataPkt {} = do+ inner <- decompressPkt pkt+ concat <$> mapM recursivelyDecompressPacket inner+recursivelyDecompressPacket pkt = Right [pkt]++compressedPacketIsEmpty :: Pkt -> Bool+compressedPacketIsEmpty pkt@CompressedDataPkt {} =+ case decompressPkt pkt of+ Right [] -> True+ _ -> False+compressedPacketIsEmpty _ = False++isCompressedPacket :: Pkt -> Bool+isCompressedPacket CompressedDataPkt {} = True+isCompressedPacket _ = False++compressionDepth :: Pkt -> Int+compressionDepth pkt@CompressedDataPkt {} =+ let inner = either (const []) id (decompressPkt pkt)+ in if null inner+ then 1+ else 1 + maximum (0 : map compressionDepth inner)+compressionDepth _ = 0++isMarkerPacket :: Pkt -> Bool+isMarkerPacket MarkerPkt {} = True+isMarkerPacket _ = False++isUnknownPacket :: Pkt -> Bool+isUnknownPacket OtherPacketPkt {} = True+isUnknownPacket BrokenPacketPkt {} = True+isUnknownPacket _ = False++isDisallowedDecryptedPacketType :: Pkt -> Bool+isDisallowedDecryptedPacketType PKESKPkt {} = True+isDisallowedDecryptedPacketType SKESKPkt {} = True+isDisallowedDecryptedPacketType PublicKeyPkt {} = True+isDisallowedDecryptedPacketType PublicSubkeyPkt {} = True+isDisallowedDecryptedPacketType SecretKeyPkt {} = True+isDisallowedDecryptedPacketType SecretSubkeyPkt {} = True+isDisallowedDecryptedPacketType SymEncDataPkt {} = True+isDisallowedDecryptedPacketType SymEncIntegrityProtectedDataPkt {} = True+isDisallowedDecryptedPacketType _ = False++encodeOpenPGPSessionKey :: Word8 -> B.ByteString -> B.ByteString+encodeOpenPGPSessionKey algo keyBytes =+ B.cons+ algo+ ( keyBytes+ <> B.pack [fromIntegral (checksum `div` 256), fromIntegral checksum]+ )+ where+ checksum :: Int+ checksum =+ B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536++sessionKeyOutLineFromMaterial :: B.ByteString -> Maybe String+sessionKeyOutLineFromMaterial raw = do+ (algo, keyBytes) <- decodeOpenPGPSessionKeyMaterial raw+ pure (renderSessionKeyOutLine algo keyBytes)++decodeOpenPGPSessionKeyMaterial+ :: B.ByteString -> Maybe (Word8, B.ByteString)+decodeOpenPGPSessionKeyMaterial raw = do+ (algo, body) <- B.uncons raw+ case toFVal (fromIntegral algo) :: SymmetricAlgorithm of+ OtherSA _ -> Nothing+ _ -> do+ let bodyLen = B.length body+ if bodyLen < 3+ then Nothing+ else do+ let keyBytes = B.take (bodyLen - 2) body+ checksumHi = fromIntegral (B.index body (bodyLen - 2)) :: Int+ checksumLo = fromIntegral (B.index body (bodyLen - 1)) :: Int+ checksumExpected = checksumHi * 256 + checksumLo+ checksumActual =+ B.foldl' (\acc w -> acc + fromIntegral w) 0 keyBytes `mod` 65536+ if B.null keyBytes || checksumActual /= checksumExpected+ then Nothing+ else Just (algo, keyBytes)++renderSessionKeyOutLine :: Word8 -> B.ByteString -> String+renderSessionKeyOutLine algo keyBytes =+ show algo ++ ":" ++ hexEncodeBytes keyBytes++hexEncodeBytes :: B.ByteString -> String+hexEncodeBytes = concatMap encodeByte . B.unpack+ where+ encodeByte w =+ [ nibble (w `shiftR` 4)+ , nibble (w .&. 0x0f)+ ]+ nibble n = "0123456789abcdef" !! fromIntegral n++extractSingleLiteralPayload :: [Pkt] -> IO BL.ByteString+extractSingleLiteralPayload pkts =+ case [p | LiteralDataPkt _ _ _ p <- pkts] of+ [payload] -> pure payload+ [] ->+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (no literal data payload found)"+ _ ->+ failWith+ BadData+ "decrypt failed: malformed encrypted message structure (multiple literal data payloads found)"++doDecryptVerifyOutput+ :: POSIXTime+ -> [String]+ -> Maybe String+ -> Maybe String+ -> Maybe String+ -> [Pkt]+ -> IO ()+doDecryptVerifyOutput cpt certFiles outFile notBeforeArg notAfterArg decryptedPkts = do+ when (null certFiles) $+ failWith+ IncompleteVerification+ "decrypt: verification requires at least one --verify-with cert"+ (krs, verifyTks) <- loadVerifyContext cpt certFiles+ upperBound <- verificationUpperBound cpt notAfterArg+ lowerBound <- verificationLowerBound cpt notBeforeArg+ verificationPkts <-+ normalizeDecryptVerificationPackets decryptedPkts+ let verifications =+ map+ (first show)+ (verifyPacketsBatch krs upperBound verificationPkts)+ filtered = filterByVerificationBounds lowerBound upperBound verifications+ successLines =+ map (renderSOPVerificationLine verifyTks) (rights filtered)+ renderedOut =+ if null successLines+ then ""+ else unlines successLines+ case outFile of+ Just path -> writeFileWithOutputExistsCheck "decrypt" path renderedOut+ Nothing -> pure ()++normalizeDecryptVerificationPackets :: [Pkt] -> IO [Pkt]+normalizeDecryptVerificationPackets pkts =+ case ( [pkt | pkt@LiteralDataPkt {} <- pkts]+ , [pkt | pkt@SignaturePkt {} <- pkts]+ ) of+ ([], _) ->+ failWith+ CannotDecrypt+ "decrypt failed: no literal data payload found"+ ([lit], []) -> pure [lit]+ ([lit], sigs) -> pure (lit : sigs)+ (_, _) ->+ failWith+ BadData+ "decrypt failed: malformed signed message structure (multiple literal payloads)"++resolveDecryptVerificationsOut+ :: Maybe String -> IO (Maybe String)+resolveDecryptVerificationsOut newPath =+ pure $ case newPath of+ Just p -> Just p+ Nothing -> Nothing++renderSOPVerificationLine+ :: [SomeTK] -> Verification -> String+renderSOPVerificationLine verifyTks v =+ ts+ ++ " "+ ++ signerFp+ ++ " "+ ++ certFp+ ++ " "+ ++ modeLabel+ ++ " "+ ++ jsonTrailer+ where+ sig = _verificationSignature v+ ts = renderSOPVerificationTimestamp sig+ signer = fingerprint (_verificationSigner v)+ signerFp = hexEncodeBytes (unFingerprint signer)+ modeLabel = signatureModeField sig+ certFp =+ case find (\tk -> keyMatchesFingerprint True tk signer) verifyTks of+ Just tk ->+ hexEncodeBytes+ ( ( unFingerprint+ ( fingerprint+ (keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk)))+ )+ )+ )+ Nothing -> signerFp+ jsonTrailer = "{\"signers\":[{\"fingerprint\":\"" ++ signerFp ++ "\"}]}"++signatureModeField :: SignaturePayload -> String+signatureModeField sig =+ case sig of+ SigV4 CanonicalTextSig _ _ _ _ _ _ -> "mode:text"+ SigV6 CanonicalTextSig _ _ _ _ _ _ _ -> "mode:text"+ _ -> "mode:binary"++renderSOPVerificationTimestamp :: SignaturePayload -> String+renderSOPVerificationTimestamp sig =+ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" $+ case signatureCreationTime sig of+ Just t -> t+ Nothing -> posixSecondsToUTCTime 0++writeFileWithOutputExistsCheck+ :: String -> FilePath -> String -> IO ()+writeFileWithOutputExistsCheck subcommand path content = do+ ensureOutputPathAvailable subcommand path+ writeFile path content++parseOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]+parseOpenPGPPackets context bytes =+ ( do+ let packets =+ concatMap+ (either (const []) id . decompressPkt)+ (parsePkts bytes)+ _ <- evaluate (length packets)+ pure packets+ )+ `catch` parseFailure+ where+ parseFailure :: SomeException -> IO [Pkt]+ parseFailure err =+ failWith+ BadData+ ( context+ ++ ": failed to parse OpenPGP packets: "+ ++ displayException err+ )++parseRawOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]+parseRawOpenPGPPackets context bytes =+ ( do+ let packets = parsePkts bytes+ _ <- evaluate (length packets)+ pure packets+ )+ `catch` parseFailure+ where+ parseFailure :: SomeException -> IO [Pkt]+ parseFailure err =+ failWith+ BadData+ ( context+ ++ ": failed to parse OpenPGP packets: "+ ++ displayException err+ )++validateDecryptPartialBodyEncoding :: BL.ByteString -> IO ()+validateDecryptPartialBodyEncoding ciphertext =+ case ensureNoShortFirstPartialBodyChunk (BL.toStrict ciphertext) of+ Left err ->+ failWith+ BadData+ ("decrypt input: invalid partial body encoding (" ++ err ++ ")")+ Right () -> pure ()++ensureNoShortFirstPartialBodyChunk+ :: B.ByteString -> Either String ()+ensureNoShortFirstPartialBodyChunk = parsePackets+ where+ parsePackets bs+ | B.null bs = Right ()+ | otherwise = do+ (header, rest) <-+ noteLeft "truncated packet header" (B.uncons bs)+ if header .&. 0x80 /= 0x80+ then Left "invalid packet header octet"+ else do+ remaining <-+ if header .&. 0x40 == 0x40+ then parseNewPacketBody rest+ else parseOldPacketBody (header .&. 0x03) rest+ parsePackets remaining++ parseOldPacketBody lengthType bs =+ case lengthType of+ 0 -> do+ (lenOctet, rest) <-+ noteLeft "truncated old-format one-octet length" (B.uncons bs)+ dropExact+ "truncated old-format packet body"+ (fromIntegral lenOctet)+ rest+ 1 -> do+ (hi, afterHi) <-+ noteLeft "truncated old-format two-octet length" (B.uncons bs)+ (lo, rest) <-+ noteLeft+ "truncated old-format two-octet length"+ (B.uncons afterHi)+ let len = fromIntegral hi * 256 + fromIntegral lo+ dropExact "truncated old-format packet body" len rest+ 2 -> do+ (b1, afterB1) <-+ noteLeft "truncated old-format four-octet length" (B.uncons bs)+ (b2, afterB2) <-+ noteLeft+ "truncated old-format four-octet length"+ (B.uncons afterB1)+ (b3, afterB3) <-+ noteLeft+ "truncated old-format four-octet length"+ (B.uncons afterB2)+ (b4, rest) <-+ noteLeft+ "truncated old-format four-octet length"+ (B.uncons afterB3)+ let len =+ (fromIntegral b1 `shiftL` 24)+ + (fromIntegral b2 `shiftL` 16)+ + (fromIntegral b3 `shiftL` 8)+ + fromIntegral b4+ dropExact "truncated old-format packet body" len rest+ 3 -> Right B.empty+ _ -> Left "invalid old-format length type"++ parseNewPacketBody = parseNewLengthChunks True++ parseNewLengthChunks isFirstChunk bs = do+ (chunkLength, isPartial, afterLength) <- parseNewLength bs+ when (isFirstChunk && isPartial && chunkLength < 512) $+ Left+ ( "first partial chunk is too short ("+ ++ show chunkLength+ ++ " octets, minimum is 512)"+ )+ afterChunk <-+ dropExact+ "truncated new-format packet body chunk"+ chunkLength+ afterLength+ if isPartial+ then parseNewLengthChunks False afterChunk+ else Right afterChunk++ parseNewLength bs = do+ (lengthOctet, rest) <-+ noteLeft "truncated new-format length" (B.uncons bs)+ case lengthOctet of+ _+ | lengthOctet < 192 ->+ Right (fromIntegral lengthOctet, False, rest)+ | lengthOctet < 224 -> do+ (nextOctet, afterNext) <-+ noteLeft "truncated new-format two-octet length" (B.uncons rest)+ let len =+ ((fromIntegral lengthOctet - 192) `shiftL` 8)+ + fromIntegral nextOctet+ + 192+ Right (len, False, afterNext)+ | lengthOctet < 255 ->+ Right+ ( 1 `shiftL` fromIntegral (lengthOctet .&. 0x1f)+ , True+ , rest+ )+ | otherwise -> do+ (b1, afterB1) <-+ noteLeft "truncated new-format five-octet length" (B.uncons rest)+ (b2, afterB2) <-+ noteLeft+ "truncated new-format five-octet length"+ (B.uncons afterB1)+ (b3, afterB3) <-+ noteLeft+ "truncated new-format five-octet length"+ (B.uncons afterB2)+ (b4, afterB4) <-+ noteLeft+ "truncated new-format five-octet length"+ (B.uncons afterB3)+ let len =+ (fromIntegral b1 `shiftL` 24)+ + (fromIntegral b2 `shiftL` 16)+ + (fromIntegral b3 `shiftL` 8)+ + fromIntegral b4+ Right (len, False, afterB4)++ dropExact context n bs+ | B.length bs < n = Left context+ | otherwise = Right (B.drop n bs)++ noteLeft err = maybe (Left err) Right++ensureOutputPathAvailable :: String -> FilePath -> IO ()+ensureOutputPathAvailable subcommand path = do+ exists <- doesFileExist path+ when exists $+ failWith+ OutputExists+ (subcommand ++ ": output path already exists: " ++ path)++loadVerifyContext+ :: POSIXTime -> [String] -> IO (PublicKeyring, [SomeTK])+loadVerifyContext _ certFiles = do+ allTks <-+ mapMaybe enforceVerifyPrimaryKeyPolicy+ . map sanitizeVerifyTK+ . concat+ <$> mapM (loadCertTKsFromFile "verify") certFiles+ let publicTks =+ mapMaybe+ ( \tk ->+ case tk of+ SomePublicTK publicTk -> Just publicTk+ SomeSecretTK secretTk -> Just (publicViewTK secretTk)+ )+ allTks+ keyring <-+ runConduitRes $ CL.sourceList publicTks .| sinkPublicKeyringMap+ pure (keyring, allTks)++loadVerifyTKsFromFile :: String -> String -> IO [SomeTK]+loadVerifyTKsFromFile context path = do+ lbs <- loadInputFromFile context "file" path+ certPkts <- decodeOpenPGPInput path lbs+ runConduitRes $+ CL.sourceList certPkts+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList++loadCertTKsFromFile :: String -> String -> IO [SomeTK]+loadCertTKsFromFile context path = do+ lbs <- loadInputFromFile context "file" path+ certPkts <- decodeOpenPGPInput path lbs+ rejectSecretKeyPackets context path certPkts+ runConduitRes $+ CL.sourceList certPkts+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList++rejectSecretKeyPackets :: String -> String -> [Pkt] -> IO ()+rejectSecretKeyPackets context path packets =+ when (any isSecretKeyPacket packets) $+ failWith+ BadData+ ( context+ ++ ": certificate input contains secret key material in "+ ++ path+ )+ where+ isSecretKeyPacket SecretKeyPkt {} = True+ isSecretKeyPacket SecretSubkeyPkt {} = True+ isSecretKeyPacket _ = False++sanitizeVerifyTK :: SomeTK -> SomeTK+sanitizeVerifyTK stk =+ case primaryKeyIdentity stk of+ Nothing -> stk+ Just _ ->+ case stk of+ SomePublicTK tk -> SomePublicTK tk {_tkSubs = map sanitize (_tkSubs tk)}+ SomeSecretTK tk -> SomeSecretTK tk {_tkSubs = map sanitize (_tkSubs tk)}+ where+ publicView = someTKToPublicViewTK stk+ pkp = keyPktPKPayload (_tkPrimaryKey publicView)+ primaryFp = fingerprint pkp+ primaryKeyId =+ either+ (error "sanitizeVerifyTK: no key ID")+ id+ (eightOctetKeyID pkp)+ sanitize+ :: (KeyPkt k, [SignaturePayload]) -> (KeyPkt k, [SignaturePayload])+ sanitize (kp, sigs) =+ let sanitized =+ mapMaybe (sanitizeBindingSignature primaryFp primaryKeyId) sigs+ in if isSubkeyPacket (keyPktToPkt kp)+ then (kp, sanitized)+ else (kp, sigs)+ isSubkeyPacket (PublicSubkeyPkt {}) = True+ isSubkeyPacket (SecretSubkeyPkt {}) = True+ isSubkeyPacket _ = False++enforceVerifyPrimaryKeyPolicy :: SomeTK -> Maybe SomeTK+enforceVerifyPrimaryKeyPolicy tk =+ if primaryKeyTooSmallForVerification tk+ then Nothing+ else Just tk++primaryKeyTooSmallForVerification :: SomeTK -> Bool+primaryKeyTooSmallForVerification stk =+ case _pkalgo pkp of+ RSA -> rsaTooSmall+ DeprecatedRSASignOnly -> rsaTooSmall+ DeprecatedRSAEncryptOnly -> rsaTooSmall+ _ -> False+ where+ pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk))+ rsaTooSmall =+ case pubkeySize (_pubkey pkp) of+ Right bits -> bits < 2048+ Left _ -> False++primaryKeyIdentity+ :: SomeTK -> Maybe (Fingerprint, EightOctetKeyId)+primaryKeyIdentity stk = do+ let pkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK stk))+ keyId <- either (const Nothing) Just (eightOctetKeyID pkp)+ pure (fingerprint pkp, keyId)++sanitizeBindingSignature+ :: Fingerprint+ -> EightOctetKeyId+ -> SignaturePayload+ -> Maybe SignaturePayload+sanitizeBindingSignature _ _ sig+ | hasUnsupportedCriticalSubpacket sig = Nothing+ | hasUnsupportedCriticalEmbeddedBacksig sig = Nothing+ | otherwise = Just sig+ where+ hasUnsupportedCriticalSubpacket sp =+ any isUnsupportedCriticalSubpacket (signatureHashedSubpackets sp)+ hasUnsupportedCriticalEmbeddedBacksig sp =+ any+ ( \ssp ->+ case _sspPayload ssp of+ EmbeddedSignature embedded ->+ any+ isUnsupportedCriticalSubpacket+ (signatureHashedSubpackets embedded)+ _ -> False+ )+ (signatureHashedSubpackets sp)+ isUnsupportedCriticalSubpacket (SigSubPacket isCritical payload) =+ isCritical+ && case payload of+ UserDefinedSigSub {} -> True+ OtherSigSub {} -> True+ NotationData {} -> True+ _ -> False++loadDecryptRecipientKeys+ :: POSIXTime+ -> String+ -> [String]+ -> [Passphrase]+ -> IO [PKESKRecipientKey]+loadDecryptRecipientKeys _ _ [] _ = pure []+loadDecryptRecipientKeys cpt context keyFiles passwords = concat <$> mapM loadRecipientKeyFile keyFiles+ where+ loadRecipientKeyFile path = do+ packets <- loadOpenPGPPackets context path+ -- Build the set of fingerprints that are explicitly non-encryption-capable.+ -- Keys not resolvable via TK (processTK failure, bare material) are allowed.+ nonEncFps <- buildNonEncryptionFingerprintSet packets+ keys <-+ mapM (packetRecipientKey path nonEncFps) packets+ >>= pure . catMaybes+ let brokenSecretKeyErrors =+ nub+ [ err+ | BrokenPacketPkt err tag _ <- packets+ , tag == 5 || tag == 7+ ]+ when (null keys && not (null brokenSecretKeyErrors)) $+ failWith+ CannotDecrypt+ ( "decrypt failed: could not load usable secret key material from "+ ++ path+ ++ " ("+ ++ intercalate "; " brokenSecretKeyErrors+ ++ ")"+ )+ pure keys+ -- Build a set of fingerprints that are EXPLICITLY non-encryption-capable.+ -- Only keys whose binding signature carries a KeyFlags subpacket that does+ -- NOT include any encryption bit are added. Keys with no binding-sig TK+ -- (processTK failed, bare secret material, etc.) are NOT blocked — we fall+ -- back to allowing them so that newly-generated or unusual keys still work.+ buildNonEncryptionFingerprintSet packets = do+ tks <-+ runConduitRes $+ CL.sourceList packets+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList+ let normTks = rights (map (processTK (Just cpt)) tks)+ let tkDerived = S.fromList (concatMap nonEncryptionFingerprints normTks)+ rawDerived = S.fromList (explicitNonEncryptionSubkeyFingerprints packets)+ return (S.union tkDerived rawDerived)+ nonEncryptionFingerprints tk =+ -- Primary key: add to blocklist only if explicit key-flags are present+ -- and all of them exclude encryption usage.+ let primaryPkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk))+ primaryFp = unFingerprint (fingerprint primaryPkp)+ publicView = someTKToPublicViewTK tk+ primarySigs =+ concatMap snd (_tkUIDs publicView)+ ++ concatMap snd (_tkUAts publicView)+ ++ _tkRevs publicView+ primaryEntry = [primaryFp | not (sigsAllowEncryption primarySigs)]+ -- Subkeys: same rule as primary.+ subEntries =+ [ unFingerprint (fingerprint pkp)+ | (kp, sigs) <- _tkSubs publicView+ , let pkp = keyPktPKPayload kp+ , not (sigsAllowEncryption sigs)+ ]+ blocked = primaryEntry ++ subEntries+ in if tkHasAnyEncryptionCapableKey tk+ then blocked+ else []+ explicitNonEncryptionSubkeyFingerprints packets =+ let (mPending, blocked) = foldl' step (Nothing, []) packets+ in maybe+ blocked+ ( \(fp, hasEnc, sawKeyFlags) -> finalize fp hasEnc sawKeyFlags blocked+ )+ mPending+ where+ step (mPending, blocked) pkt =+ case pkt of+ PublicSubkeyPkt pkp ->+ ( Just (unFingerprint (fingerprint pkp), False, False)+ , finalizePending mPending blocked+ )+ SecretSubkeyPkt pkp _ ->+ ( Just (unFingerprint (fingerprint pkp), False, False)+ , finalizePending mPending blocked+ )+ SignaturePkt sig ->+ case mPending of+ Nothing -> (Nothing, blocked)+ Just (fp, hasEnc, sawKeyFlags) ->+ let usableSig =+ if signatureHasUnsupportedCriticalSubpackets sig+ then []+ else keyFlagsFromSig sig+ hasEnc' = hasEnc || any hasEncryptionFlag usableSig+ sawKeyFlags' = sawKeyFlags || not (null usableSig)+ in (Just (fp, hasEnc', sawKeyFlags'), blocked)+ _ -> (Nothing, finalizePending mPending blocked)+ finalizePending Nothing blocked = blocked+ finalizePending (Just (fp, hasEnc, sawKeyFlags)) blocked =+ finalize fp hasEnc sawKeyFlags blocked+ finalize fp hasEnc sawKeyFlags blocked+ | sawKeyFlags && not hasEnc = fp : blocked+ | otherwise = blocked+ tkHasAnyEncryptionCapableKey tk =+ let primaryPkp = keyPktPKPayload (_tkPrimaryKey (someTKToPublicViewTK tk))+ publicView = someTKToPublicViewTK tk+ primarySigs =+ concatMap snd (_tkUIDs publicView)+ ++ concatMap snd (_tkUAts publicView)+ ++ _tkRevs publicView+ primaryAllows =+ supportsRecipientPKESKAlgorithm primaryPkp+ && sigsAllowEncryption primarySigs+ subAllows =+ any+ ( \(kp, sigs) ->+ supportsRecipientPKESKAlgorithm (keyPktPKPayload kp)+ && sigsAllowEncryption sigs+ )+ (_tkSubs publicView)+ in primaryAllows || subAllows+ sigsAllowEncryption [] = True+ sigsAllowEncryption sigs =+ let usableSigs = filter (not . signatureHasUnsupportedCriticalSubpackets) sigs+ flagSets = concatMap keyFlagsFromSig usableSigs+ in if null usableSigs+ then False+ else null flagSets || any hasEncryptionFlag flagSets+ hasEncryptionFlag flags =+ S.member EncryptCommunicationsKey flags+ || S.member EncryptStorageKey flags+ keyFlagsFromSig sig =+ case sig of+ SigV4 _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds+ SigV6 _ _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds+ _ -> []+ signatureHasUnsupportedCriticalSubpackets sig =+ let hasheds =+ case sig of+ SigV4 _ _ _ hs _ _ _ -> hs+ SigV6 _ _ _ _ hs _ _ _ -> hs+ _ -> []+ in any isUnsupportedCritical hasheds+ isUnsupportedCritical (SigSubPacket isCritical payload) =+ isCritical+ && case payload of+ OtherSigSub {} -> True+ UserDefinedSigSub {} -> True+ NotationData {} -> True+ _ -> False+ keyFlagsFromSubpackets subpackets =+ [ flags+ | SigSubPacket _ (KeyFlags flags) <- subpackets+ ]+ packetRecipientKey path nonEncFps (SecretKeyPkt pkp ska) =+ let fp = unFingerprint (fingerprint pkp)+ in if S.member fp nonEncFps+ then pure Nothing+ else decryptRecipientKey path pkp ska+ packetRecipientKey path nonEncFps (SecretSubkeyPkt pkp ska) =+ let fp = unFingerprint (fingerprint pkp)+ in if S.member fp nonEncFps+ then pure Nothing+ else decryptRecipientKey path pkp ska+ packetRecipientKey _ _ _ = pure Nothing+ decryptRecipientKey path pkp ska =+ case secretKeyProtectionPolicyViolation pkp ska of+ Just violation ->+ failWith+ KeyIsProtected+ ( "decrypt failed: unsupported secret key protection in "+ ++ path+ ++ " ("+ ++ violation+ ++ ")"+ )+ Nothing ->+ case ska of+ SUSUnprotected 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 (SUSUnprotected 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+ SUSMalleableCFB _ s2k _ _ ->+ case _keyVersion recipientPkp of+ V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k+ _ -> rejectArgon2WithoutAEAD s2k+ SUSCFB _ s2k _ _ ->+ case _keyVersion recipientPkp of+ V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k+ _ -> rejectArgon2WithoutAEAD s2k+ SUSLegacyCFB {} ->+ 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 decryptSecretKeyAddendum 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 loadRecipientCertFile certFiles+ where+ loadRecipientCertFile path = do+ pkts <- loadOpenPGPPackets "encrypt" path+ rejectSecretKeyPackets "encrypt" path pkts+ tks <-+ runConduitRes $+ CL.sourceList pkts+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList+ normalized <- mapM (normalizeRecipient path) tks+ pure+ (concatMap (effectiveHashPreferencesAt cpt) normalized)+ normalizeRecipient path tk =+ case processTK (Just cpt) tk of+ Left err ->+ failWith+ BadData+ ( "encrypt: invalid recipient certificate in "+ ++ path+ ++ ": "+ ++ show err+ )+ Right normalized -> pure normalized++loadEncryptRecipients+ :: POSIXTime -> EncryptFor -> [String] -> IO [FunKey]+loadEncryptRecipients cpt encPurpose certFiles = do+ recipients <- concat <$> mapM loadRecipientsFromFile certFiles+ if null recipients+ then+ failWith+ CertCannotEncrypt+ "encrypt: no supported recipient encryption keys found in provided certificates"+ else pure recipients+ where+ loadRecipientsFromFile path = do+ lbs <- loadInputFromFile "encrypt" "file" path+ pkts <- decodeOpenPGPInput path lbs+ rejectSecretKeyPackets "encrypt" path pkts+ rejectCriticalUnknownRecipientPackets path pkts+ tks <-+ runConduitRes $+ CL.sourceList pkts+ .| conduitToSomeTKsDroppingEither+ .| conduitDropErrorsAndNothings+ .| CC.sinkList+ normalized <- mapM (normalizeEncryptRecipientTK path) tks+ let selected =+ selectEncryptRecipients+ encPurpose+ (concatMap (tkToFunKeysAt cpt) normalized)+ packetFallback =+ nub+ ( concatMap tkToEncryptPayloads normalized+ ++ mapMaybe extractEncryptRecipientPayload pkts+ )+ pure $+ case encPurpose of+ EncryptForAny+ | null selected -> map payloadToFunKey packetFallback+ _ -> selected+ normalizeEncryptRecipientTK path tk =+ case processTK (Just cpt) tk of+ Left err ->+ failWith+ BadData+ ( "encrypt: invalid recipient certificate in "+ ++ path+ ++ ": "+ ++ show err+ )+ Right normalized ->+ if not+ ( isTKTimeValid+ (posixSecondsToUTCTime (realToFrac cpt))+ (someTKToPublicViewTK normalized)+ )+ then+ failWith+ CertCannotEncrypt+ ("encrypt: recipient certificate in " ++ path ++ " is expired")+ else+ if not (primaryUserIDExpirationAllowsAt cpt normalized)+ then+ failWith+ CertCannotEncrypt+ ("encrypt: recipient certificate in " ++ path ++ " is expired")+ else pure normalized+ rejectCriticalUnknownRecipientPackets path =+ mapM_+ ( \pkt ->+ case pkt of+ OtherPacketPkt tag _+ | tag < 40 ->+ if isForwardCompatRecipientPacketTag tag+ then pure ()+ else+ failWith+ BadData+ ( "encrypt: invalid recipient certificate in "+ ++ path+ ++ ": critical unknown packet tag "+ ++ show tag+ )+ BrokenPacketPkt _ tag _+ | tag < 40 ->+ if isForwardCompatRecipientPacketTag tag+ then pure ()+ else+ failWith+ BadData+ ( "encrypt: invalid recipient certificate in "+ ++ path+ ++ ": critical unknown packet tag "+ ++ show tag+ )+ _ -> pure ()+ )+ isForwardCompatRecipientPacketTag tag = tag `elem` [5, 6, 7, 14]+ payloadToFunKey pkp = FunKey pkp Nothing S.empty [] [] False++primaryUserIDExpirationAllowsAt :: POSIXTime -> SomeTK -> Bool+primaryUserIDExpirationAllowsAt now tk =+ case primaryUidSigs of+ [] -> True+ _ ->+ any+ (signatureKeyExpirationAllowsAt now primaryCreatedAt)+ primaryUidSigs+ where+ publicView = someTKToPublicViewTK tk+ primaryCreatedAt =+ fromIntegral+ (_timestamp (keyPktPKPayload (_tkPrimaryKey publicView)))+ primaryUidSigs =+ [ sig+ | (_, sigs) <- _tkUIDs publicView+ , sig <- sigs+ , signatureMarksPrimaryUserId sig+ ]++signatureMarksPrimaryUserId :: SignaturePayload -> Bool+signatureMarksPrimaryUserId sig =+ any isPrimaryUIDSubpacket (signatureSubpackets sig)+ where+ isPrimaryUIDSubpacket (SigSubPacket _ (PrimaryUserId True)) = True+ isPrimaryUIDSubpacket _ = False++signatureKeyExpirationAllowsAt+ :: POSIXTime -> POSIXTime -> SignaturePayload -> Bool+signatureKeyExpirationAllowsAt now createdAt sig =+ case signatureKeyValiditySeconds sig of+ Nothing -> True+ Just 0 -> True+ Just validitySeconds -> now < createdAt + fromIntegral validitySeconds++signatureKeyValiditySeconds :: SignaturePayload -> Maybe Integer+signatureKeyValiditySeconds sig =+ listToMaybe+ [ fromIntegral secs+ | SigSubPacket _ (KeyExpirationTime (ThirtyTwoBitDuration secs)) <-+ signatureSubpackets sig+ ]++selectEncryptRecipients :: EncryptFor -> [FunKey] -> [FunKey]+selectEncryptRecipients encPurpose keys =+ chosen+ where+ supported = filter (supportsRecipientPKESKAlgorithm . fpkp) keys+ (matchingPurpose, unrestrictedPurpose) =+ partition (keyMatchesEncryptPurpose encPurpose . fkufs) supported+ chosen =+ case encPurpose of+ EncryptForAny+ | null matchingPurpose -> unrestrictedPurpose+ _ -> matchingPurpose++tkToEncryptPayloads :: SomeTK -> [SomePKPayload]+tkToEncryptPayloads stk =+ filter+ supportsRecipientPKESKAlgorithm+ (someTKToUnknown stk ^.. biplate :: [SomePKPayload])++extractEncryptRecipientPayload :: Pkt -> Maybe SomePKPayload+extractEncryptRecipientPayload pkt =+ case pkt of+ PublicKeyPkt pkp+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp+ PublicSubkeyPkt pkp+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp+ SecretKeyPkt pkp _+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp+ SecretSubkeyPkt pkp _+ | supportsRecipientPKESKAlgorithm pkp -> Just pkp+ _ -> Nothing++keyMatchesEncryptPurpose :: EncryptFor -> S.Set KeyFlag -> Bool+keyMatchesEncryptPurpose encPurpose keyFlags =+ not (S.null (keyFlags `S.intersection` encryptUsageFlags))+ where+ encryptUsageFlags =+ case encPurpose of+ EncryptForAny -> S.fromList [EncryptStorageKey, EncryptCommunicationsKey]+ EncryptForStorage -> S.singleton EncryptStorageKey+ EncryptForCommunications -> S.singleton EncryptCommunicationsKey++supportsRecipientPKESKAlgorithm :: SomePKPayload -> Bool+supportsRecipientPKESKAlgorithm pkp =+ _pkalgo pkp+ `elem` [ RSA+ , DeprecatedRSAEncryptOnly+ , ElgamalEncryptOnly+ , ECDH+ , X25519+ , X448+ ]+ && hasSupportedRecipientIdentifierLength pkp++hasSupportedRecipientIdentifierLength :: SomePKPayload -> Bool+hasSupportedRecipientIdentifierLength pkp =+ let keyIdentifierLen = B.length (unFingerprint (fingerprint pkp))+ in keyIdentifierLen == 16+ || keyIdentifierLen == 20+ || keyIdentifierLen == 32++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+ :: B.ByteString -> PKESKRecipientKey -> Bool+matchesRecipientIdentifier rid keyInfo =+ case pkeskRecipientPKPayload keyInfo of+ Nothing -> False+ Just pkp ->+ let identifier = rid+ fps = recipientFingerprintsForMatch pkp+ in any (identifier `elem`) (map recipientIdMatchVariants fps)++recipientFingerprintsForMatch :: SomePKPayload -> [B.ByteString]+recipientFingerprintsForMatch pkp =+ baseFp : maybeToList normalizedX25519Fp+ where+ baseFp = (unFingerprint (fingerprint pkp))+ normalizedX25519Fp =+ unFingerprint . fingerprint+ <$> normalizeX25519CompatiblePKP pkp++normalizeX25519CompatiblePKP+ :: SomePKPayload -> Maybe SomePKPayload+normalizeX25519CompatiblePKP pkp =+ case _pubkey pkp of+ ECDHPubKey (EdDSAPubKey EdSigningCurve25519 _) _ _ ->+ Just+ ( PKPayload+ (_keyVersion pkp)+ (_timestamp pkp)+ (_v3exp pkp)+ X25519+ (_pubkey pkp)+ )+ _ -> Nothing++recipientIdMatchVariants :: B.ByteString -> [B.ByteString]+recipientIdMatchVariants fp =+ [ fp+ , B.cons 0x04 fp+ , B.cons 0x06 fp+ , B.cons 0xFE fp+ ]++matchesLegacyRecipientKeyId+ :: EightOctetKeyId -> PKESKRecipientKey -> Bool+matchesLegacyRecipientKeyId eoki keyInfo =+ case pkeskRecipientPKPayload keyInfo of+ Nothing -> False+ Just pkp ->+ case eightOctetKeyID pkp of+ Right keyId -> keyId == eoki+ Left _ -> False++decodeCiphertextInput :: BL.ByteString -> IO BL.ByteString+decodeCiphertextInput input = do+ decodedArmors <- decodeAsciiArmorInput "decrypt input" input+ case decodedArmors of+ Just armors ->+ case firstBy isArmorMessageBlock armors of+ Just (Armor ArmorMessage _ bs) -> return (BL.fromStrict (BLC8.toStrict bs))+ _ ->+ case firstBy isOpenPGPArmorBlock armors of+ Just _ ->+ failWith+ BadData+ "decrypt expects an armored OpenPGP message"+ _ -> return input+ Nothing -> return input++doInlineSign :: POSIXTime -> InlineSignOptions -> IO ()+doInlineSign pt InlineSignOptions {..} = do+ let inlineMode = fromMaybe InlineSignAsBinary inlineSignAs+ mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume+ when (inlineMode /= InlineSignAsBinary) $+ ensureUTF8TextInput "inline-sign" (BL.fromChunks mbs)+ signingPasswordsRaw <-+ loadPasswordFiles+ "inline-sign"+ "--with-key-password"+ inlineSignKeyPasswords+ let signingPasswords =+ map+ Passphrase+ ( concatMap+ (passwordRetryCandidates . BL.toStrict)+ signingPasswordsRaw+ )+ ks <-+ loadSigningKeys "inline-sign" inlineSignKeyFiles signingPasswords+ processedKeys <- mapM (normalizeSigningKey pt) ks+ let ts = ThirtyTwoBitTimeStamp (floor pt)+ payloadRaw = BL.fromChunks mbs+ funkeys = concatMap (tkToFunKeysAt pt . SomeSecretTK) 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 (FileName B.empty) 0 payloadRaw]+ )+ )+ BL.putStr $+ if not inlineSignNoArmor+ then AA.encodeLazy [Armor ArmorMessage [] pktBytes]+ else pktBytes++inlineSignModeReader :: String -> Either String InlineSignMode+inlineSignModeReader "binary" = Right InlineSignAsBinary+inlineSignModeReader "text" = Right InlineSignAsText+inlineSignModeReader "clearsigned" = Right InlineSignAsClearSigned+inlineSignModeReader _ =+ Left "signature mode must be one of: binary, text, clearsigned"++isInlineSigningCapable :: FunKey -> Bool+isInlineSigningCapable k =+ (S.null (fkufs k) || S.member SignDataKey (fkufs k))+ && case fmska k of+ Just (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey _)) _) -> True+ Just (SUSUnprotected (EdDSAPrivateKey _ _) _) -> True+ Just (SUSUnprotected (Ed25519PrivateKey _) _) -> True+ Just (SUSUnprotected (Ed448PrivateKey _) _) -> True+ Just (SUSUnprotected (UnknownSKey _) _) -> isEd25519PKA (_pkalgo (fpkp k)) || isEdDSAPKA (_pkalgo (fpkp k)) || isEd448PKA (_pkalgo (fpkp k))
hopenpgp-tools.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hopenpgp-tools-version: 0.25.8+version: 0.25.9 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: https://salsa.debian.org/clint/hOpenPGP-tools@@ -25,7 +25,7 @@ , bytestring , conduit >= 1.3 , errors- , hOpenPGP >= 3.4 && < 3.5+ , hOpenPGP >= 3.5 && < 3.6 , lens , optparse-applicative >= 0.18.1 , prettyprinter >= 1.7@@ -132,4 +132,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hopenpgp-tools.git- tag: hopenpgp-tools/0.25.8+ tag: hopenpgp-tools/0.25.9