diff --git a/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs b/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs --- a/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs +++ b/HOpenPGP/Tools/Hokey/InjectSSHAgent.hs @@ -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) diff --git a/HOpenPGP/Tools/Hokey/Lint/Policy.hs b/HOpenPGP/Tools/Hokey/Lint/Policy.hs --- a/HOpenPGP/Tools/Hokey/Lint/Policy.hs +++ b/HOpenPGP/Tools/Hokey/Lint/Policy.hs @@ -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) diff --git a/hop.hs b/hop.hs --- a/hop.hs +++ b/hop.hs @@ -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)) diff --git a/hopenpgp-tools.cabal b/hopenpgp-tools.cabal --- a/hopenpgp-tools.cabal +++ b/hopenpgp-tools.cabal @@ -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