-- hop.hs: hOpenPGP-stateless OpenPGP (sop) tool
-- Copyright © 2019-2026 Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
( Armor (..)
, ArmorType (..)
)
import Codec.Encryption.OpenPGP.Compression
( CompressionError
, decompressPkt
, renderCompressionError
)
import Codec.Encryption.OpenPGP.Encrypt
( PKESKEncryptError (..)
, PKESKSessionMaterial (..)
, RecipientEncryptRequest (..)
, RecipientEncryptRequestOverrides (..)
, RecipientEncryptResult (..)
, RecipientPKESKVersionStrategy (..)
, RecipientPayloadShape (..)
, defaultRecipientPayloadShape
, encryptForRecipients
, recipientEncryptionTarget
, recipientEncryptionTargetWithStrategy
)
import Codec.Encryption.OpenPGP.Expirations
( effectiveKeyPreferencesAt
, isTKTimeValid
)
import Codec.Encryption.OpenPGP.Fingerprint
( eightOctetKeyID
, fingerprint
)
import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
import Codec.Encryption.OpenPGP.Message
( EncryptMessageOptions (..)
, RecoveredSessionMaterial (..)
, SessionMaterialExposure (..)
, encryptMessage
, encryptedPayloadBytes
, mkClearPayload
, mkPassphrase
)
import Codec.Encryption.OpenPGP.Ontology
( isKUF
, isPKBindingSig
, isSKBindingSig
)
import Codec.Encryption.OpenPGP.Policy
( defaultDecryptPolicy
, defaultPolicy
, lenientDecryptPolicy
)
import Codec.Encryption.OpenPGP.S2K
( decodeOpenPGPEncodedSessionKey
, skesk2Key
, skesk2SessionKey
)
import Codec.Encryption.OpenPGP.SecretKey
( decryptPrivateKey
, encryptPrivateKey
)
import Codec.Encryption.OpenPGP.Serialize (parsePkts)
import Codec.Encryption.OpenPGP.Signatures
( SignError (..)
, renderSignError
, signCertRevocationWithRSA
, signDataWithEd25519
, signDataWithEd25519Legacy
, signDataWithEd25519V6
, signDataWithEd448
, signDataWithEd448V6
, signDataWithRSABuilder
, signDataWithRSAV6
, signKeyRevocationWithRSA
, signUserIDwithRSA
, verifyAgainstKeys
, verifySigWith
, verifyUnknownTKWith
)
import qualified Codec.Encryption.OpenPGP.Subpackets as SP
import Codec.Encryption.OpenPGP.Types
import Control.Applicative (many, optional, some, (<|>))
import Control.Error.Util (hush, note)
import Control.Exception
( IOException
, SomeException
, catch
, displayException
, evaluate
, throwIO
)
import Control.Monad (forM, forM_, join, unless, when, (>=>))
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State.Lazy (StateT, evalStateT, get, modify)
import Crypto.Error (eitherCryptoError)
import Crypto.Number.Serialize (i2ospOf_, os2ip)
import qualified Crypto.PubKey.Curve25519 as Curve25519
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import Crypto.Random.Types (getRandomBytes)
import qualified Data.Aeson as A
import Data.Bifunctor (first)
import qualified Data.Binary as Bin
import Data.Binary.Get (runGet)
import Data.Binary.Put
( putByteString
, putLazyByteString
, putWord16be
, putWord32be
, putWord8
, runPut
)
import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.Char (digitToInt, isHexDigit, isSpace, toLower)
import Data.Conduit (fuseBoth, runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.Combinators as CC
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Decrypt
( DecryptKeyResolution (..)
, DecryptOutcome (..)
, PKESKRecipientKey (..)
)
import qualified Data.Conduit.OpenPGP.Decrypt as Decrypt
import Data.Conduit.OpenPGP.Keyring
( conduitToTKsDroppingEither
, sinkPublicKeyringMap
)
import Data.Conduit.OpenPGP.Verify
( conduitVerify
, verifyPacketsBatch
)
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
( customExecParser
, helper
, hsubparser
)
import Options.Applicative.Types (Parser)
import Prettyprinter
( hardline
, list
, pretty
, softline
)
import Prettyprinter.Render.Text (hPutDoc)
import System.Directory (doesFileExist)
import System.Environment (getArgs, lookupEnv)
import System.Exit
( ExitCode (..)
, exitSuccess
, exitWith
)
import System.IO
( BufferMode (..)
, Handle
, hFlush
, hPutStrLn
, hSetBuffering
, stderr
, stdin
)
import Text.Read (readMaybe)
import HOpenPGP.Tools.Common.Armor (doDeArmor)
import HOpenPGP.Tools.Common.Common
( banner
, keyMatchesEightOctetKeyId
, keyMatchesFingerprint
, versioner
, warranty
)
import HOpenPGP.Tools.Common.TKUtils (processTK)
import Paths_hopenpgp_tools (version)
data Command
= VersionC VersionOptions
| ListProfilesC ListProfilesOptions
| GenerateKeyC KeyGenOptions
| ChangeKeyPasswordC ChangeKeyPasswordOptions
| MergeCertsC MergeCertsOptions
| ValidateUserIdC ValidateUserIdOptions
| CertifyUserIdC CertifyUserIdOptions
| RevokeKeyC RevokeKeyOptions
| RevokeUserIdC RevokeUserIdOptions
| UpdateKeyC UpdateKeyOptions
| VerifyC VerifyOptions
| InlineVerifyC InlineVerifyOptions
| EncryptC EncryptOptions
| DecryptC DecryptOptions
| InlineSignC InlineSignOptions
| InlineDetachC InlineDetachOptions
| ExtractCertC ExtractCertOptions
| SignC SignOptions
| UnsupportedC String
| DeArmorC
| ArmorC ArmoringOptions
data OutputFormat
= Unstructured
| JSON
| YAML
deriving (Eq, Read, Show)
data VerifyOptions
= VerifyOptions
{ verifyNotBefore :: Maybe String
, verifyNotAfter :: Maybe String
, verifySigFile :: String
, verifyCertFiles :: [String]
}
data InlineVerifyOptions
= InlineVerifyOptions
{ inlineNotBefore :: Maybe String
, inlineNotAfter :: Maybe String
, verificationsOut :: Maybe String
, inlineCertFiles :: [String]
}
data EncryptOptions
= EncryptOptions
{ encNoArmor :: Bool
, encArmor :: Bool
, encProfile :: Maybe String
, encAs :: AsBinaryText
, encSignWithKeyFiles :: [String]
, encSignWithKeyPasswords :: [String]
, encSessionKeyOutFile :: Maybe String
, encFor :: EncryptFor
, encWithoutIntegrityCheck :: Bool
, encPasswords :: [String]
, encRecipientCerts :: [String]
}
data EncryptProfile
= EncryptProfileRFC9580
| EncryptProfileRFC4880
deriving (Eq)
data DecryptOptions
= DecryptOptions
{ decNoArmor :: Bool
, decArmor :: Bool
, decWithoutIntegrityCheck :: Bool
, decVerifyNotBefore :: Maybe String
, decVerifyNotAfter :: Maybe String
, decSessionKeys :: [String]
, decSessionKeyOutFile :: Maybe String
, decPasswords :: [String]
, decKeyPasswords :: [String]
, decKeyFiles :: [String]
, decVerifyCerts :: [String]
, decVerificationsOutFile :: Maybe String
, decDeprecatedVerifyOutFile :: Maybe String
}
data InlineSignOptions
= InlineSignOptions
{ inlineSignNoArmor :: Bool
, inlineSignArmor :: Bool
, inlineSignProfile :: Maybe String
, inlineSignAs :: Maybe InlineSignMode
, inlineSignKeyFiles :: [String]
, inlineSignKeyPasswords :: [String]
}
data InlineDetachOptions
= InlineDetachOptions
{ inlineDetachNoArmor :: Bool
, inlineDetachOutputSigs :: String
}
data ChangeKeyPasswordOptions
= ChangeKeyPasswordOptions
{ changeKeyPasswordNoArmor :: Bool
, changeKeyPasswordOldPasswords :: [String]
, changeKeyPasswordNewPasswords :: [String]
}
data MergeCertsOptions
= MergeCertsOptions
{ mergeCertsNoArmor :: Bool
, mergeCertsFiles :: [String]
}
data ValidateUserIdOptions
= ValidateUserIdOptions
{ validateUserIdAddrSpecOnly :: Bool
, validateUserIdAt :: Maybe String
, validateUserIdString :: String
, validateUserIdAuthorityFiles :: [String]
}
data CertifyUserIdOptions
= CertifyUserIdOptions
{ certifyUserIds :: [String]
, certifyUserIdOutputFormat :: Maybe String
, certifyUserIdNoRequireSelfSig :: Bool
, certifyUserIdKeyPasswordFiles :: [String]
, certifyUserIdSignerFiles :: [String]
}
data RevokeKeyOptions
= RevokeKeyOptions
{ revokeKeyNoArmor :: Bool
, revokeKeyPasswordFiles :: [String]
}
data RevokeUserIdOptions
= RevokeUserIdOptions
{ revokeUserIdString :: String
, revokeUserIdNoArmor :: Bool
}
data UpdateKeyOptions
= UpdateKeyOptions
{ updateKeyNoArmor :: Bool
, updateKeySigningOnly :: Bool
, updateKeyRevokeDeprecatedKeys :: Bool
, updateKeyNoAddedCapabilities :: Bool
, updateKeyPasswordFiles :: [String]
, updateKeyMergeCerts :: [String]
}
newtype ListProfilesOptions
= ListProfilesOptions
{ profileSubcommand :: String
}
data VersionOptions
= VersionOptions
{ vBackend :: Bool
, vExtended :: Bool
, vSopSpec :: Bool
, vSopv :: Bool
}
data CliOptions
= CliOptions
{ cliDebug :: Bool
, cliCommand :: Command
}
data SopFailure
= MissingArg
| IncompleteVerification
| BadData
| PasswordNotHumanReadable
| ExpectedText
| CannotDecrypt
| UnsupportedAsymmetricAlgo
| CertCannotEncrypt
| UnsupportedOption
| OutputExists
| MissingInput
| NoSignature
| KeyIsProtected
| KeyCannotSign
| UnsupportedSpecialPrefix
| IncompatibleOptions
| UnsupportedProfile
| UnsupportedSubcommand
| CertUserIdNoMatch
| KeyCannotCertify
failureCode :: SopFailure -> Int
failureCode MissingArg = 19
failureCode IncompleteVerification = 23
failureCode BadData = 41
failureCode PasswordNotHumanReadable = 31
failureCode ExpectedText = 53
failureCode CannotDecrypt = 29
failureCode UnsupportedAsymmetricAlgo = 13
failureCode CertCannotEncrypt = 17
failureCode UnsupportedOption = 37
failureCode OutputExists = 59
failureCode MissingInput = 61
failureCode NoSignature = 3
failureCode KeyIsProtected = 67
failureCode KeyCannotSign = 79
failureCode UnsupportedSpecialPrefix = 71
failureCode IncompatibleOptions = 83
failureCode UnsupportedProfile = 89
failureCode UnsupportedSubcommand = 69
failureCode CertUserIdNoMatch = 107
failureCode KeyCannotCertify = 109
failWith :: SopFailure -> String -> IO a
failWith f msg = do
BLC8.hPutStrLn stderr (BLC8.pack msg)
exitWith (ExitFailure (failureCode f))
voP :: Parser VerifyOptions
voP =
VerifyOptions
<$> optional
( strOption
( long "not-before"
<> metavar "DATE"
<> help "ignore signatures before DATE"
)
)
<*> optional
( strOption
( long "not-after"
<> metavar "DATE"
<> help "ignore signatures after DATE"
)
)
<*> argument str (metavar "SIGNATURES" <> sigHelp)
<*> some (strArgument (metavar "CERTS..." <> certHelp))
where
sigHelp =
helpDoc . Just $
pretty "file containing OpenPGP signatures"
certHelp =
helpDoc . Just $
pretty "one or more certificate files"
ivoP :: Parser InlineVerifyOptions
ivoP =
InlineVerifyOptions
<$> optional
( strOption
( long "not-before"
<> metavar "DATE"
<> help "ignore signatures before DATE"
)
)
<*> optional
( strOption
( long "not-after"
<> metavar "DATE"
<> help "ignore signatures after DATE"
)
)
<*> optional
( strOption
( long "verifications-out"
<> metavar "VERIFICATIONS"
<> help "write verification records to file"
)
)
<*> some (strArgument (metavar "CERTS..." <> certHelp))
where
certHelp =
helpDoc . Just $
pretty "one or more certificate files"
lpoP :: Parser ListProfilesOptions
lpoP =
ListProfilesOptions
<$> strArgument
(metavar "SUBCOMMAND" <> help "subcommand to list profiles for")
vopP :: Parser VersionOptions
vopP =
VersionOptions
<$> switch
(long "backend" <> help "show backend implementation version")
<*> switch
(long "extended" <> help "show extended version information")
<*> switch (long "sop-spec" <> help "show targeted sop draft")
<*> switch
(long "sopv" <> help "show implemented sopv subset version")
encP :: Parser EncryptOptions
encP =
EncryptOptions
<$> switch (long "no-armor" <> help "output binary")
<*> switch (long "armor" <> help "output ASCII Armor")
<*> optional
(strOption (long "profile" <> help "encryption profile"))
<*> option
(eitherReader asTypeReader)
(long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)
<*> many
(strOption (long "sign-with" <> help "signing key material"))
<*> many
( strOption
( long "with-key-password"
<> help "password for unlocking signing key material"
)
)
<*> optional
( strOption
( long "session-key-out"
<> metavar "SESSIONKEY"
<> help "write generated session key to file"
)
)
<*> option
(eitherReader encryptForReader)
( long "for"
<> metavar "ENCRYPTION_PURPOSE"
<> help
"select recipient key purpose (any, storage, communications)"
<> value EncryptForAny
)
<*> switch
( long "without-integrity-check"
<> help "disable integrity protection"
)
<*> many
( strOption
(long "with-password" <> help "symmetric encryption password")
)
<*> many
( strArgument
(metavar "CERT" <> help "recipient certificate files")
)
where
astypeHelp =
helpDoc . Just $
pretty "what to treat the input as"
<> softline
<> list (map (pretty . fst) asTypes)
decP :: Parser DecryptOptions
decP =
DecryptOptions
<$> switch (long "no-armor" <> help "output binary")
<*> switch (long "armor" <> help "output ASCII Armor")
<*> switch
( long "without-integrity-check"
<> help "disable integrity verification"
)
<*> optional
( strOption
( long "verify-not-before"
<> metavar "DATE"
<> help "ignore signatures before DATE when decrypting"
)
)
<*> optional
( strOption
( long "verify-not-after"
<> metavar "DATE"
<> help "ignore signatures after DATE when decrypting"
)
)
<*> many
( strOption
(long "with-session-key" <> help "session key for decryption")
)
<*> optional
( strOption
(long "session-key-out" <> help "write recovered session key")
)
<*> many
( strOption
(long "with-password" <> help "password for SKESK decryption")
)
<*> many
( strOption
( long "with-key-password"
<> help "password for unlocking decryption key material"
)
)
<*> many (strArgument (metavar "KEY" <> help "secret key material"))
<*> many
( strOption
( long "verify-with"
<> help "certificate(s) to verify signatures with"
)
)
<*> optional
( strOption
( long "verifications-out"
<> help "write verification results to file"
)
)
<*> optional
( strOption
( long "verify-out"
<> help "deprecated alias for --verifications-out"
)
)
inlineSignP :: Parser InlineSignOptions
inlineSignP =
InlineSignOptions
<$> switch (long "no-armor" <> help "output binary")
<*> switch (long "armor" <> help "output ASCII Armor")
<*> optional (strOption (long "profile" <> help "signature profile"))
<*> optional
( option
(eitherReader inlineSignModeReader)
(long "as" <> metavar "DATATYPE" <> inlineSignAsHelp)
)
<*> some (strArgument (metavar "KEY" <> help "signing key file(s)"))
<*> many
( strOption
( long "with-key-password"
<> metavar "PASSWORD"
<> help "password for encrypted signing key"
)
)
where
inlineSignAsHelp =
helpDoc . Just $
pretty "what to treat the input as"
<> softline
<> list [pretty "binary", pretty "text", pretty "clearsigned"]
inlineDetachP :: Parser InlineDetachOptions
inlineDetachP =
InlineDetachOptions
<$> switch (long "no-armor" <> help "output binary")
<*> strOption
( long "signatures-out"
<> metavar "SIGNATURES"
<> help "write detached signatures to file"
)
mergeCertsP :: Parser MergeCertsOptions
mergeCertsP =
MergeCertsOptions
<$> switch (long "no-armor" <> help "output binary")
<*> some
( strArgument
(metavar "CERTS..." <> help "one or more certificate files")
)
validateUserIdP :: Parser ValidateUserIdOptions
validateUserIdP =
ValidateUserIdOptions
<$> switch
( long "addr-spec-only"
<> help
"match only the addr-spec portion of conventional OpenPGP User IDs"
)
<*> optional
( strOption
( long "validate-at"
<> metavar "DATE"
<> help "evaluate certifications at DATE"
)
)
<*> argument str (metavar "USERID" <> help "user ID to validate")
<*> some
( strArgument
( metavar "CERTS..."
<> help "one or more authority certificate files"
)
)
certifyUserIdP :: Parser CertifyUserIdOptions
certifyUserIdP =
CertifyUserIdOptions
<$> some
( strOption
( long "userid"
<> metavar "USERID"
<> help "user ID to certify (repeatable)"
)
)
<*> optional
( strOption
( long "output-format"
<> metavar "FORMAT"
<> help "output format (text or binary)"
)
)
<*> switch
( long "no-require-self-sig"
<> help "allow certifying user IDs that do not have self-signatures"
)
<*> many
( strOption
( long "with-key-password"
<> help "password for unlocking signer key material"
)
)
<*> some
( strArgument
(metavar "KEYS..." <> help "one or more signer key files")
)
revokeKeyP :: Parser RevokeKeyOptions
revokeKeyP =
RevokeKeyOptions
<$> switch (long "no-armor" <> help "output binary")
<*> many
( strOption
( long "with-key-password"
<> help "password for unlocking secret key material"
)
)
revokeUserIdP :: Parser RevokeUserIdOptions
revokeUserIdP =
RevokeUserIdOptions
<$> argument str (metavar "USERID" <> help "user ID to revoke")
<*> switch (long "no-armor" <> help "output binary")
updateKeyP :: Parser UpdateKeyOptions
updateKeyP =
UpdateKeyOptions
<$> switch (long "no-armor" <> help "output binary")
<*> switch
( long "signing-only"
<> help "limit updated material to signing-capable key material"
)
<*> switch
( long "revoke-deprecated-keys"
<> help
"emit revocations for deprecated key material when supported"
)
<*> switch
( long "no-added-capabilities"
<> help
"do not add capabilities beyond existing target key material"
)
<*> many
( strOption
( long "with-key-password"
<> help "password for unlocking key material"
)
)
<*> many
( strOption
( long "merge-certs"
<> metavar "CERTS"
<> help "additional certificate files to merge into target keys"
)
)
changeKeyPasswordP :: Parser ChangeKeyPasswordOptions
changeKeyPasswordP =
ChangeKeyPasswordOptions
<$> switch (long "no-armor" <> help "output binary")
<*> many
( strOption
( long "old-key-password"
<> help "password(s) used to unlock existing secret key material"
)
)
<*> many
( strOption
( long "new-key-password"
<> help "password used to protect rewritten secret key material"
)
)
dispatch :: POSIXTime -> Command -> IO ()
dispatch cpt cmd' = banner' stderr >> hFlush stderr >> dispatch' cpt cmd'
where
dispatch' _ (VersionC o') = doVersion o'
dispatch' _ (ListProfilesC o') = doListProfiles o'
dispatch' t (GenerateKeyC o) = doGenerateKey t o
dispatch' _ (ChangeKeyPasswordC o) = doChangeKeyPassword o
dispatch' _ (MergeCertsC o) = doMergeCerts o
dispatch' t (ValidateUserIdC o) = doValidateUserId t o
dispatch' t (CertifyUserIdC o) = doCertifyUserId t o
dispatch' t (RevokeKeyC o) = doRevokeKey t o
dispatch' t (RevokeUserIdC o) = doRevokeUserId t o
dispatch' t (UpdateKeyC o) = doUpdateKey t o
dispatch' t (VerifyC o') = doVerify t o'
dispatch' t (InlineVerifyC o') = doInlineVerify t o'
dispatch' t (EncryptC o') = doEncrypt t o'
dispatch' t (DecryptC o') = doDecrypt t o'
dispatch' t (InlineSignC o') = doInlineSign t o'
dispatch' t (InlineDetachC o') = doInlineDetach t o'
dispatch' _ (ExtractCertC o) = doExtractCert o
dispatch' t (SignC o) = doSign t o
dispatch' _ (UnsupportedC c) =
failWith
UnsupportedSubcommand
("command not yet implemented: " ++ c)
dispatch' _ DeArmorC = doDeArmor
dispatch' _ (ArmorC o) = doArmor o
main :: IO ()
main = do
hSetBuffering stderr LineBuffering
args <- getArgs
ensureKnownSubcommand knownSopSubcommands args
cpt <- getPOSIXTime
CliOptions {..} <-
customExecParser
(prefs showHelpOnError)
( info
(helper <*> versioner "hop" <*> cliP)
( headerDoc (Just (banner "hop"))
<> progDesc "hOpenPGP Validator Tool"
<> footerDoc (Just (warranty "hop"))
)
)
let _ = cliDebug
dispatch cpt cliCommand
knownSopSubcommands :: [String]
knownSopSubcommands =
[ "armor"
, "dearmor"
, "change-key-password"
, "decrypt"
, "encrypt"
, "certify-userid"
, "extract-cert"
, "generate-key"
, "inline-detach"
, "inline-sign"
, "inline-verify"
, "list-profiles"
, "merge-certs"
, "revoke-key"
, "revoke-userid"
, "sign"
, "update-key"
, "validate-userid"
, "verify"
, "version"
]
ensureKnownSubcommand :: [String] -> [String] -> IO ()
ensureKnownSubcommand knownSubcommands args =
if any (`elem` ["-h", "--help", "--version"]) args
then pure ()
else case find (not . isPrefixOf "-") args of
Just subcommand
| subcommand `notElem` knownSubcommands ->
failWith
UnsupportedSubcommand
("unsupported subcommand: " ++ subcommand)
_ -> pure ()
cliP :: Parser CliOptions
cliP =
CliOptions
<$> switch (long "debug" <> help "emit more verbose output")
<*> cmd
banner' :: Handle -> IO ()
banner' h =
hPutDoc
h
(banner "hop" <> hardline <> warranty "hop" <> hardline)
data Vrf
= Vrf
{ _vrfmsg :: String
, _vrfmfpr :: Maybe Fingerprint
}
deriving (Eq, Generic, Show)
instance A.ToJSON Vrf
cmd :: Parser Command
cmd =
hsubparser
( command
"armor"
(info (ArmorC <$> aoP) (progDesc "Armor stdin to stdout"))
<> command
"dearmor"
(info (pure DeArmorC) (progDesc "Dearmor stdin to stdout"))
<> command
"change-key-password"
( info
(ChangeKeyPasswordC <$> changeKeyPasswordP)
(progDesc "Update a key password")
)
<> command
"decrypt"
(info (DecryptC <$> decP) (progDesc "Decrypt a message"))
<> command
"encrypt"
(info (EncryptC <$> encP) (progDesc "Encrypt a message"))
<> command
"certify-userid"
( info
(CertifyUserIdC <$> certifyUserIdP)
(progDesc "Certify user IDs in a certificate")
)
<> command
"extract-cert"
( info
(ExtractCertC <$> ecoP)
( progDesc
"Extract a certificate from a secret key and output it to stdout"
)
)
<> command
"generate-key"
( info
(GenerateKeyC <$> gkoP)
(progDesc "Generate a secret key and output it to stdout")
)
<> command
"inline-detach"
( info
(InlineDetachC <$> inlineDetachP)
(progDesc "Create inline detached signatures")
)
<> command
"inline-sign"
( info
(InlineSignC <$> inlineSignP)
(progDesc "Create inline signatures")
)
<> command
"inline-verify"
( info
(InlineVerifyC <$> ivoP)
(progDesc "Verify inline-signed data")
)
<> command
"list-profiles"
(info (ListProfilesC <$> lpoP) (progDesc "List SOP profiles"))
<> command
"merge-certs"
( info
(MergeCertsC <$> mergeCertsP)
(progDesc "Merge OpenPGP certificates")
)
<> command
"revoke-key"
( info
(RevokeKeyC <$> revokeKeyP)
(progDesc "Create a key revocation certificate")
)
<> command
"revoke-userid"
( info
(RevokeUserIdC <$> revokeUserIdP)
(progDesc "Revoke a user ID")
)
<> command
"sign"
( info
(SignC <$> soP)
(progDesc "Create detached signatures and output them to stdout")
)
<> command
"update-key"
(info (UpdateKeyC <$> updateKeyP) (progDesc "Update key material"))
<> command
"validate-userid"
( info
(ValidateUserIdC <$> validateUserIdP)
(progDesc "Validate a certificate user ID")
)
<> command
"verify"
(info (VerifyC <$> voP) (progDesc "Verify signatures"))
<> command
"version"
( info
(VersionC <$> vopP)
(progDesc "output hop version to stdout")
)
)
armorTypes :: [(String, Maybe ArmorType)]
armorTypes =
[ ("auto", Nothing)
, ("sig", Just ArmorSignature)
, ("key", Just ArmorPrivateKeyBlock)
, ("cert", Just ArmorPublicKeyBlock)
, ("message", Just ArmorMessage)
]
armorTypeReader :: String -> Either String (Maybe ArmorType)
armorTypeReader = note "unknown armor type" . flip lookup armorTypes
aoP :: Parser ArmoringOptions
aoP =
ArmoringOptions
<$> option
(eitherReader armorTypeReader)
(long "label" <> metavar "LABEL" <> armortypeHelp)
<*> switch
( long "allow-nested"
<> help "do the sane thing and unconditionally armor the output"
)
where
armortypeHelp =
helpDoc . Just $
pretty "ASCII armor type"
<> softline
<> list (map (pretty . fst) armorTypes)
data ArmoringOptions
= ArmoringOptions
{ label :: Maybe ArmorType
, allowNested :: Bool
}
doArmor :: ArmoringOptions -> IO ()
doArmor ArmoringOptions {..} = do
m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
let lbs = BL.fromChunks m
armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs
label' = guessLabel label (decodeFirstPacket lbs)
a = Armor label' [] lbs
BL.putStr $
if armoredAlready && not allowNested
then lbs
else AA.encodeLazy [a]
where
decodeFirstPacket = runGet Bin.get
-- UPSTREAM: openpgp-asciiarmor should export selectArmorType helper
-- to eliminate this pattern-matching boilerplate
guessLabel (Just l) _ = l
guessLabel Nothing (SignaturePkt _) = ArmorSignature
guessLabel Nothing (SecretKeyPkt _ _) = ArmorPrivateKeyBlock
guessLabel Nothing (PublicKeyPkt _) = ArmorPublicKeyBlock
guessLabel Nothing _ = ArmorMessage
doVersion :: VersionOptions -> IO ()
doVersion VersionOptions {..} = do
let selected = length (filter id [vBackend, vExtended, vSopSpec, vSopv])
when (selected > 1) $
failWith
IncompatibleOptions
"version: --backend, --extended, --sop-spec, and --sopv are mutually exclusive"
putStrLn $ "hop " ++ showVersion version
when vBackend $ putStrLn "backend: hOpenPGP"
when vExtended $ putStrLn "extended: yes"
when vSopSpec $
putStrLn "spec: draft-dkg-openpgp-stateless-cli-16"
when vSopv $ putStrLn "sopv: 1.0"
gkoP :: Parser KeyGenOptions
gkoP =
KeyGenOptions
<$> switch (long "armor" <> help "armor the output")
<*> switch (long "no-armor" <> help "don't armor the output")
<*> many
( strOption
( long "with-key-password"
<> help "password used to protect generated secret key material"
)
)
<*> optional
( strOption
( long "profile"
<> metavar "PROFILE"
<> help
"key generation profile (default, rfc4880, compatibility, security, performance)"
)
)
<*> switch
(long "signing-only" <> help "generate signing-only key material")
<*> many
( strArgument
(metavar "USERID" <> help "User ID associated with this key")
)
data KeyGenOptions
= KeyGenOptions
{ armor :: Bool
, noArmor :: Bool
, keyPasswords :: [String]
, keyProfile :: Maybe String
, keySigningOnly :: Bool
, userIds :: [String]
}
doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()
doGenerateKey pt KeyGenOptions {..} = do
when (armor && noArmor) $
failWith
IncompatibleOptions
"generate-key: --armor and --no-armor are mutually exclusive"
baseProfile <- parseKeyGenProfile keyProfile
let profile =
if keySigningOnly
then KeyGenSigningOnly
else baseProfile
password <- parseGenerateKeyPassword keyPasswords
let ts = ThirtyTwoBitTimeStamp (floor pt)
-- UPSTREAM: hOpenPGP should expose a supported legacy secret-key
-- re-encryption path so password-protected v4 key generation does not
-- need to switch to the v6 protection format here.
keyVersion =
if isJust password && keyVersionForProfile profile == V4
then V6
else keyVersionForProfile profile
primaryKeySpec = primaryKeySpecForProfile profile
sk <- generateSecretKey ts keyVersion primaryKeySpec
baseKey <-
buildKeyWith sk $ do
case userIds of
(primaryUid : restUids) -> do
addUserId ts True (T.pack primaryUid)
mapM_ (addUserId ts False . T.pack) restUids
[] -> pure ()
addSubkeysForProfile ts keyVersion profile
newkey <- get
return newkey
s <-
maybe
(pure baseKey)
(`encryptTransferableSecretKey` baseKey)
password
let lbs = runPut $ Bin.put s
BL.putStr $
if not armor && not noArmor
then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs]
else lbs
type KeyBuilder = StateT TKUnknown IO
buildKeyWith :: SecretKey -> KeyBuilder a -> IO a
buildKeyWith sk a = evalStateT a (bareTK sk)
where
bareTK (SecretKey pkp ska) = TKUnknown (pkp, Just ska) [] [] [] []
data GeneratedKeySpec
= GeneratedRSAKey Int
| GeneratedEd25519Key
| GeneratedX25519Key
deriving (Eq)
generateSecretKey
:: ThirtyTwoBitTimeStamp
-> KeyVersion
-> GeneratedKeySpec
-> IO SecretKey
generateSecretKey ts keyVersion (GeneratedRSAKey bits) = do
(pub, priv) <- liftIO $ RSA.generate bits 0x10001
return $ SecretKey (pkp pub) (ska priv)
where
pkp pub = PKPayload keyVersion ts 0 RSA (RSAPubKey (RSA_PublicKey pub))
ska priv = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey priv)) 0 -- FIXME: calculate checksum
generateSecretKey ts keyVersion GeneratedEd25519Key = do
priv <- Ed25519.generateSecretKey
let pub = Ed25519.toPublic priv
pubBytes = BA.convert pub :: B.ByteString
privBytes = BA.convert priv :: B.ByteString
pure $
SecretKey
( PKPayload
keyVersion
ts
0
(toFVal 27)
(EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip pubBytes))))
)
(SUUnencrypted (EdDSAPrivateKey Ed25519 privBytes) 0)
generateSecretKey ts keyVersion GeneratedX25519Key = do
priv <- Curve25519.generateSecretKey
let pub = Curve25519.toPublic priv
pubBytes = BA.convert pub :: B.ByteString
privBytes = BA.convert priv :: B.ByteString
pure $
SecretKey
( PKPayload
keyVersion
ts
0
X25519
(EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip pubBytes))))
)
(SUUnencrypted (X25519PrivateKey privBytes) 0)
data KeyGenProfile
= KeyGenDefault
| KeyGenRFC4880
| KeyGenSecurity
| KeyGenPerformance
| KeyGenSigningOnly
deriving (Eq)
parseKeyGenProfile :: Maybe String -> IO KeyGenProfile
parseKeyGenProfile Nothing = pure KeyGenDefault
parseKeyGenProfile (Just "default") = pure KeyGenDefault
parseKeyGenProfile (Just "rfc4880") = pure KeyGenRFC4880
parseKeyGenProfile (Just "compatibility") = pure KeyGenRFC4880
parseKeyGenProfile (Just "security") = pure KeyGenSecurity
parseKeyGenProfile (Just "performance") = pure KeyGenPerformance
parseKeyGenProfile (Just profile) =
failWith
UnsupportedProfile
("generate-key: unsupported profile " ++ profile)
keyVersionForProfile :: KeyGenProfile -> KeyVersion
keyVersionForProfile KeyGenDefault = V6
keyVersionForProfile KeyGenRFC4880 = V4
keyVersionForProfile KeyGenSecurity = V6
keyVersionForProfile KeyGenPerformance = V6
keyVersionForProfile KeyGenSigningOnly = V6
primaryKeySpecForProfile :: KeyGenProfile -> GeneratedKeySpec
primaryKeySpecForProfile KeyGenRFC4880 = GeneratedRSAKey 4096
primaryKeySpecForProfile _ = GeneratedEd25519Key
parseGenerateKeyPassword :: [String] -> IO (Maybe BL.ByteString)
parseGenerateKeyPassword [] = pure Nothing
parseGenerateKeyPassword [passwordFile] =
Just
<$> ( loadPasswordFromFile
"generate-key"
"--with-key-password"
passwordFile
>>= normalizeHumanReadablePassword
"generate-key"
"--with-key-password"
)
parseGenerateKeyPassword _ =
failWith
UnsupportedOption
"generate-key: multiple --with-key-password values are not supported"
loadPasswordFiles
:: String -> String -> [String] -> IO [BL.ByteString]
loadPasswordFiles context optionName = mapM (loadPasswordFromFile context optionName)
loadPasswordFromFile
:: String -> String -> FilePath -> IO BL.ByteString
loadPasswordFromFile context optionName path = do
case stripPrefix "@ENV:" path of
Just varName
| null varName ->
failWith
BadData
(context ++ ": empty environment variable name in " ++ optionName)
| otherwise -> do
envValue <- lookupEnv varName
case envValue of
Nothing ->
failWith
MissingInput
( context
++ ": environment variable not found for "
++ optionName
++ ": "
++ varName
)
Just envVal -> pure (BLC8.pack envVal)
Nothing ->
case stripPrefix "@FD:" path of
Just fdSpec -> loadPasswordFromFD context optionName fdSpec
Nothing ->
case path of
'@' : _ ->
failWith
UnsupportedSpecialPrefix
( context
++ ": unsupported special prefix for "
++ optionName
++ ": "
++ path
)
_ -> do
exists <- doesFileExist path
unless exists $
failWith
MissingInput
( context
++ ": password file does not exist for "
++ optionName
++ ": "
++ path
)
BL.readFile path
loadPasswordFromFD
:: String -> String -> String -> IO BL.ByteString
loadPasswordFromFD context optionName fdSpec =
case readMaybe fdSpec :: Maybe Int of
Just fdNum
| fdNum >= 0 ->
( do
let fdPath = "/dev/fd/" ++ show fdNum
exists <- doesFileExist fdPath
unless exists $
failWith
MissingInput
( context
++ ": file descriptor not available for "
++ optionName
++ ": "
++ fdSpec
)
contents <- BL.readFile fdPath
_ <- evaluate (BL.length contents)
pure contents
)
`catch` ( \err ->
failWith
MissingInput
( context
++ ": failed reading file descriptor for "
++ optionName
++ ": "
++ fdSpec
++ " ("
++ displayException (err :: IOException)
++ ")"
)
)
| otherwise ->
failWith
BadData
( context
++ ": invalid file descriptor in "
++ optionName
++ ": "
++ fdSpec
)
_ ->
failWith
BadData
( context
++ ": invalid file descriptor in "
++ optionName
++ ": "
++ fdSpec
)
normalizeHumanReadablePassword
:: String -> String -> BL.ByteString -> IO BL.ByteString
normalizeHumanReadablePassword context optionName passwordBytes =
case TE.decodeUtf8' (BL.toStrict passwordBytes) of
Left _ ->
failWith
PasswordNotHumanReadable
( context
++ ": password is not human-readable UTF-8 for "
++ optionName
)
Right txt ->
pure
(BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt)))
passwordRetryCandidates :: BL.ByteString -> [BL.ByteString]
passwordRetryCandidates passwordBytes =
case TE.decodeUtf8' (BL.toStrict passwordBytes) of
Left _ -> [passwordBytes]
Right txt ->
let trimmed = BL.fromStrict (TE.encodeUtf8 (T.dropWhileEnd isSpace txt))
in if trimmed == passwordBytes
then [passwordBytes]
else [passwordBytes, trimmed]
addSubkeysForProfile
:: ThirtyTwoBitTimeStamp
-> KeyVersion
-> KeyGenProfile
-> KeyBuilder ()
addSubkeysForProfile ts keyVersion profile =
case profile of
KeyGenSigningOnly ->
addSubkey ts keyVersion profile [SignDataKey]
_ -> do
addSubkey
ts
keyVersion
profile
[EncryptStorageKey, EncryptCommunicationsKey]
addSubkey ts keyVersion profile [SignDataKey]
addSubkey ts keyVersion profile [AuthKey]
subkeySpecForProfile
:: KeyGenProfile -> [KeyFlag] -> GeneratedKeySpec
subkeySpecForProfile KeyGenRFC4880 _ = GeneratedRSAKey 4096
subkeySpecForProfile _ keyflags
| any
(`elem` keyflags)
[EncryptStorageKey, EncryptCommunicationsKey] =
GeneratedX25519Key
| otherwise = GeneratedEd25519Key
encryptTransferableSecretKey
:: BL.ByteString -> TKUnknown -> IO TKUnknown
encryptTransferableSecretKey password tk = do
keyPair' <- encryptKeyPair (_tkuKey tk)
subs' <- mapM encryptSub (_tkuSubs tk)
pure tk {_tkuKey = keyPair', _tkuSubs = subs'}
where
encryptKeyPair (pkp, Just ska) = do
encrypted <- encryptSecretAddendumForOutput pkp ska
pure (pkp, Just encrypted)
encryptKeyPair keyPair = pure keyPair
encryptSub (SecretSubkeyPkt pkp ska, sigs) = do
encrypted <- encryptSecretAddendumForOutput pkp ska
pure (SecretSubkeyPkt pkp encrypted, sigs)
encryptSub sub = pure sub
encryptSecretAddendumForOutput pkp ska =
case ska of
SUUnencrypted {} -> doEncryptSecret
_ -> pure ska
where
doEncryptSecret = do
encryptedResult <-
encryptPrivateKey defaultPolicy pkp ska password
case encryptedResult of
Left err ->
failWith
BadData
("generate-key: failed to protect secret key material: " ++ err)
Right val -> pure val
rsaSigningKey :: SKAddendum -> IO RSA.PrivateKey
rsaSigningKey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) =
pure (k {RSA.private_p = 0, RSA.private_q = 0})
rsaSigningKey _ =
failWith
BadData
"generate-key: unsupported secret key format for RSA signing"
issuerSubpacketsFor
:: String -> SomePKPayload -> IO [SigSubPacket]
issuerSubpacketsFor context pkp =
case _keyVersion pkp of
V6 -> pure []
_ ->
case eightOctetKeyID pkp of
Left err ->
failWith
BadData
(context ++ ": could not derive issuer key id: " ++ show err)
Right keyId -> pure [SigSubPacket False (Issuer keyId)]
addUserId
:: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder ()
addUserId ts primary userid = do
tk <- get
signed <- selfsign (_tkuKey tk) userid
modify (newUID signed)
where
newUID signed tk = tk {_tkuUIDs = _tkuUIDs tk ++ [signed]}
selfsign (pkp, Just ska) u = do
issuer <- liftIO (unhashed pkp)
sig <-
liftIO $
signWithKey
"generate-key"
pkp
PositiveCert
SHA512
(hashed pkp)
issuer
(userIdPayloadForSigning pkp (UserId u))
(Just ska)
pure (u, [sig])
selfsign _ _ =
liftIO $
failWith
BadData
"generate-key: primary key is missing secret key material"
hashed pkp =
[ SigSubPacket False (SigCreationTime ts)
, SigSubPacket
False
( IssuerFingerprint
(issuerFingerprintVersionFor pkp)
(fingerprint pkp)
)
, SigSubPacket False (KeyFlags (S.singleton CertifyKeysKey))
, SigSubPacket False (PrimaryUserId primary)
, SigSubPacket
False
(PreferredHashAlgorithms [SHA512, SHA256, SHA384, SHA224])
, SigSubPacket
False
(PreferredSymmetricAlgorithms [AES256, AES192, AES128])
]
unhashed = issuerSubpacketsFor "generate-key"
addSubkey
:: ThirtyTwoBitTimeStamp
-> KeyVersion
-> KeyGenProfile
-> [KeyFlag]
-> KeyBuilder ()
addSubkey ts keyVersion profile keyflags = do
tk <- get
(SecretKey subpkp subska) <-
liftIO $
generateSecretKey
ts
keyVersion
(subkeySpecForProfile profile keyflags)
(pkp, ska) <-
case _tkuKey tk of
(primaryPkp, Just primarySka) -> pure (primaryPkp, primarySka)
_ ->
liftIO $
failWith
BadData
"generate-key: primary key is missing secret key material"
issuerPrimary <- liftIO (unhashed pkp)
issuerSub <- liftIO (unhashed subpkp)
embeddedBacksig <-
if SignDataKey `elem` keyflags
then
Just
<$> liftIO
( signWithKey
"generate-key"
subpkp
PrimaryKeyBindingSig
SHA512
(hashed subpkp)
issuerSub
(subkeyPayloadForSigning pkp subpkp)
(Just subska)
)
else pure Nothing
bindingSig <-
liftIO $
signWithKey
"generate-key"
pkp
SubkeyBindingSig
SHA512
(hashedwithflags pkp)
( maybe
issuerPrimary
( \sig -> SigSubPacket False (EmbeddedSignature sig) : issuerPrimary
)
embeddedBacksig
)
(subkeyPayloadForSigning pkp subpkp)
(Just ska)
modify (addIt subpkp subska bindingSig)
where
addIt sp ss binding tk =
tk
{ _tkuSubs = _tkuSubs tk ++ [(SecretSubkeyPkt sp ss, [binding])]
}
hashed pkp =
[ SigSubPacket False (SigCreationTime ts)
, SigSubPacket
False
( IssuerFingerprint
(issuerFingerprintVersionFor pkp)
(fingerprint pkp)
)
]
hashedwithflags pkp =
hashed pkp
++ [SigSubPacket False (KeyFlags (S.fromList keyflags))]
unhashed = issuerSubpacketsFor "generate-key"
putKeyForSigning :: SomePKPayload -> Bin.Put
putKeyForSigning pkp@(PKPayload V6 _ _ _ _) = do
putWord8 0x9A
let bs = runPut (Bin.put pkp)
putWord32be (fromIntegral (BL.length bs))
putLazyByteString bs
putKeyForSigning pkp = do
putWord8 0x99
let bs = runPut (Bin.put pkp)
putWord16be (fromIntegral (BL.length bs))
putLazyByteString bs
putUserIdForSigning :: UserId -> Bin.Put
putUserIdForSigning (UserId u) = do
let bs = TE.encodeUtf8 u
putWord8 0xB4
putWord32be (fromIntegral (B.length bs))
putByteString bs
userIdPayloadForSigning
:: SomePKPayload -> UserId -> BL.ByteString
userIdPayloadForSigning pkp uid =
runPut $ do
putKeyForSigning pkp
putUserIdForSigning uid
subkeyPayloadForSigning
:: SomePKPayload -> SomePKPayload -> BL.ByteString
subkeyPayloadForSigning primary sub =
runPut $ do
putKeyForSigning primary
putKeyForSigning sub
issuerFingerprintVersionFor
:: SomePKPayload -> IssuerFingerprintVersion
issuerFingerprintVersionFor pkp =
case _keyVersion pkp of
V6 -> IssuerFingerprintV6
_ -> IssuerFingerprintV4
ecoP :: Parser ExtractCertOptions
ecoP =
ExtractCertOptions
<$> switch (long "armor" <> help "armor the output")
<*> switch (long "no-armor" <> help "don't armor the output")
data ExtractCertOptions
= ExtractCertOptions
{ ecArmor :: Bool
, ecNoArmor :: Bool
}
doExtractCert :: ExtractCertOptions -> IO ()
doExtractCert ExtractCertOptions {..} = do
kbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
let lbs = BL.fromChunks kbs
pkts <- decodeOpenPGPInput "stdin" lbs
tks <-
runConduitRes $
CL.sourceList pkts
.| conduitToTKsDroppingEither
.| CL.mapMaybe (either (const Nothing) id)
.| CC.sinkList
when (null tks) $
failWith
MissingInput
"extract-cert: no transferable secret key found on standard input"
let output = runPut $ mapM_ (Bin.put . pubToSecret) tks
BL.putStr $
if not ecArmor && not ecNoArmor
then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
else output
where
pubToSecret tk =
tk
{ _tkuKey = pToS (_tkuKey tk)
, _tkuSubs = map subPToS (_tkuSubs tk)
}
pToS (pkp, _) = (pkp, Nothing)
subPToS (SecretSubkeyPkt pkp _, sigs) = (PublicSubkeyPkt pkp, sigs)
subPToS (PublicSubkeyPkt pkp, sigs) = (PublicSubkeyPkt pkp, sigs)
subPToS x = x
doChangeKeyPassword :: ChangeKeyPasswordOptions -> IO ()
doChangeKeyPassword ChangeKeyPasswordOptions {..} = do
input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
packets <- decodeOpenPGPInput "stdin" input
tks <-
runConduitRes $
CL.sourceList packets
.| conduitToTKsDroppingEither
.| CL.mapMaybe (either (const Nothing) id)
.| CC.sinkList
when (null tks) $
failWith
MissingInput
"change-key-password: no transferable secret key found on standard input"
when (any (not . hasSecretKeyMaterial) tks) $
failWith
MissingInput
"change-key-password: expected transferable secret key input on standard input"
oldPasswordsRaw <-
loadPasswordFiles
"change-key-password"
"--old-key-password"
changeKeyPasswordOldPasswords
let oldPasswords = concatMap passwordRetryCandidates oldPasswordsRaw
newPassword <-
parseChangeKeyPasswordNewPassword changeKeyPasswordNewPasswords
unlockedTks <-
mapM
( unlockTransferableSecretKeyMaterial
"change-key-password"
"standard input"
"--old-key-password"
oldPasswords
)
tks
rewrittenTks <-
case newPassword of
Just password -> mapM (encryptTransferableSecretKey password) unlockedTks
Nothing -> pure unlockedTks
let output = runPut (mapM_ Bin.put rewrittenTks)
BL.putStr $
if changeKeyPasswordNoArmor || BL.null output
then output
else AA.encodeLazy [Armor ArmorPrivateKeyBlock [] output]
parseChangeKeyPasswordNewPassword
:: [String] -> IO (Maybe BL.ByteString)
parseChangeKeyPasswordNewPassword [] = pure Nothing
parseChangeKeyPasswordNewPassword [passwordFile] =
Just
<$> ( loadPasswordFromFile
"change-key-password"
"--new-key-password"
passwordFile
>>= normalizeHumanReadablePassword
"change-key-password"
"--new-key-password"
)
parseChangeKeyPasswordNewPassword _ =
failWith
UnsupportedOption
"change-key-password: multiple --new-key-password values are not supported"
hasSecretKeyMaterial :: TKUnknown -> Bool
hasSecretKeyMaterial tk =
case _tkuKey tk of
(_, Just _) -> True
_ -> any isSecretSubkeyPkt (_tkuSubs tk)
where
isSecretSubkeyPkt (SecretSubkeyPkt _ _, _) = True
isSecretSubkeyPkt _ = False
doValidateUserId :: POSIXTime -> ValidateUserIdOptions -> IO ()
doValidateUserId cpt ValidateUserIdOptions {..} = do
authorityTks <-
concat
<$> mapM
(loadCertTKsFromFile "validate-userid")
validateUserIdAuthorityFiles
validateAtTime <- verificationUpperBound cpt validateUserIdAt
input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
certPkts <- decodeOpenPGPInput "standard input" input
certTks <-
runConduitRes $
CL.sourceList certPkts
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
when (null certTks) $
failWith
MissingInput
"validate-userid: no certificate found on standard input"
let targetUserId = T.pack validateUserIdString
forM_ certTks $ \certTk ->
when
( not
( certificateHasMatchingValidatedUserId
authorityTks
validateAtTime
validateUserIdAddrSpecOnly
targetUserId
certTk
)
)
$ failWith
CertUserIdNoMatch
( "validate-userid: certificate has no correctly bound user ID matching "
++ validateUserIdString
)
certificateHasMatchingValidatedUserId
:: [TKUnknown] -> Maybe UTCTime -> Bool -> Text -> TKUnknown -> Bool
certificateHasMatchingValidatedUserId authorityTks validateAtTime addrSpecOnly targetUserId certTk =
case verifyUnknownTKWith verifier validateAtTime certTk of
Left _ -> False
Right verifiedTk -> any matchingBoundUid (_tkuUIDs verifiedTk)
where
verifier = verifySigWith (verifyAgainstKeys (certTk : authorityTks))
matchingBoundUid (uid, sigs) =
useridMatches addrSpecOnly targetUserId uid
&& any (signatureMatchesSigner certTk) sigs
&& any
(\sig -> any (`signatureMatchesSigner` sig) authorityTks)
sigs
useridMatches :: Bool -> Text -> Text -> Bool
useridMatches False targetUserId uid = uid == targetUserId
useridMatches True targetUserId uid =
case conventionalAddrSpec uid of
Just addrSpec -> addrSpec == targetUserId
Nothing -> False
conventionalAddrSpec :: Text -> Maybe Text
conventionalAddrSpec uid =
let (prefix, suffix) = T.breakOnEnd (T.pack "<") uid
in if T.null prefix
then Nothing
else case T.unsnoc suffix of
Just (addrSpec, '>')
| T.any (== '<') addrSpec -> Nothing
| otherwise -> guardNonEmpty (T.strip addrSpec)
_ -> Nothing
where
guardNonEmpty text
| T.null text = Nothing
| otherwise = Just text
signatureMatchesSigner :: TKUnknown -> SignaturePayload -> Bool
signatureMatchesSigner signer sig =
maybe
False
(keyMatchesFingerprint False signer)
(signatureIssuerFingerprint sig)
|| maybe
False
(keyMatchesEightOctetKeyId False signer . Right)
(signatureIssuerKeyId sig)
signatureIssuerFingerprint
:: SignaturePayload -> Maybe Fingerprint
signatureIssuerFingerprint =
listToMaybe . mapMaybe getIssuerFingerprint . signatureSubpackets
where
getIssuerFingerprint (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) =
Just issuerFingerprint
getIssuerFingerprint _ = Nothing
signatureIssuerKeyId :: SignaturePayload -> Maybe EightOctetKeyId
signatureIssuerKeyId = listToMaybe . mapMaybe getIssuerKeyId . signatureSubpackets
where
getIssuerKeyId (SigSubPacket _ (Issuer issuerKeyId)) = Just issuerKeyId
getIssuerKeyId _ = Nothing
signatureSubpackets :: SignaturePayload -> [SigSubPacket]
signatureSubpackets (SigV4 _ _ _ hashed unhashed _ _) = hashed ++ unhashed
signatureSubpackets (SigV6 _ _ _ _ hashed unhashed _ _) = hashed ++ unhashed
signatureSubpackets _ = []
doCertifyUserId :: POSIXTime -> CertifyUserIdOptions -> IO ()
doCertifyUserId _cpt CertifyUserIdOptions {..} = do
signerPasswordsRaw <-
loadPasswordFiles
"certify-userid"
"--with-key-password"
certifyUserIdKeyPasswordFiles
let signerPasswords = concatMap passwordRetryCandidates signerPasswordsRaw
signerTks <-
concat
<$> mapM
(loadCertifySignerTKsFromFile signerPasswords)
certifyUserIdSignerFiles
when (null signerTks) $
failWith
MissingInput
"certify-userid: no signer certificate found"
input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
certPkts <- decodeOpenPGPInput "standard input" input
targetTks <-
runConduitRes $
CL.sourceList certPkts
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
when (null targetTks) $
failWith
MissingInput
"certify-userid: no certificate found on standard input"
let targetUserIds = map T.pack certifyUserIds
requireSelfSig = not certifyUserIdNoRequireSelfSig
updatedTargets <-
mapM
( \targetTk ->
addUserIdCertifications
targetTk
targetUserIds
requireSelfSig
signerTks
)
targetTks
let output = runPut (mapM_ Bin.put updatedTargets)
armorOutput =
case certifyUserIdOutputFormat of
Just "binary" -> output
_ -> AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
BL.putStr armorOutput
loadCertifySignerTKsFromFile
:: [BL.ByteString] -> String -> IO [TKUnknown]
loadCertifySignerTKsFromFile signerPasswords path = do
lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
packets <- decodeOpenPGPInput path lbs
tks <-
runConduitRes $
CL.sourceList packets
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
let fallbackTks = signingFallbackTKs packets
when (null tks && null fallbackTks) $
failWith
MissingInput
("certify-userid: no signer key material found in " ++ path)
mapM
( unlockTransferableSecretKeyMaterial
"certify-userid failed"
path
"--with-key-password"
signerPasswords
)
(if null tks then fallbackTks else tks)
addUserIdCertifications
:: TKUnknown -> [Text] -> Bool -> [TKUnknown] -> IO TKUnknown
addUserIdCertifications targetTk targetUserIds requireSelfSig signerTks = do
forM_ targetUserIds $ \targetUserId ->
case find ((== targetUserId) . fst) (_tkuUIDs targetTk) of
Nothing ->
failWith
CertUserIdNoMatch
( "certify-userid: target certificate has no user ID matching "
++ T.unpack targetUserId
)
Just (_, sigs) ->
when
( requireSelfSig
&& not (any (signatureMatchesSigner targetTk) sigs)
)
$ failWith
CertUserIdNoMatch
( "certify-userid: target user ID has no self-signature: "
++ T.unpack targetUserId
)
newSigs <-
concat
<$> forM
signerTks
( \signerTk ->
forM
targetUserIds
( \targetUserId -> do
sig <- createUIDCertification targetUserId signerTk
pure (targetUserId, sig)
)
)
let updateUID (uid, sigs) =
if uid `elem` targetUserIds
then (uid, sigs ++ map snd (filter ((== uid) . fst) newSigs))
else (uid, sigs)
pure $ targetTk {_tkuUIDs = map updateUID (_tkuUIDs targetTk)}
createUIDCertification
:: Text -> TKUnknown -> IO SignaturePayload
createUIDCertification targetUserId signerTk = do
let (signerPkp, mSignerSka) = _tkuKey signerTk
signerSka <-
case mSignerSka of
Just ska -> pure ska
Nothing ->
failWith
KeyCannotCertify
"certify-userid: signer certificate has no secret key material"
signingKey <- rsaSigningKey signerSka
issuer <- issuerSubpacketsFor "certify-userid" signerPkp
let hashed = [SigSubPacket False (SigCreationTime (_timestamp signerPkp))]
certification =
signUserIDwithRSA
signerPkp
(UserId targetUserId)
hashed
issuer
signingKey
case certification of
Left err ->
failWith
BadData
("certify-userid: failed to create certification: " ++ show err)
Right sig -> pure sig
doRevokeKey :: POSIXTime -> RevokeKeyOptions -> IO ()
doRevokeKey _cpt RevokeKeyOptions {..} = do
keyPasswordsRaw <-
loadPasswordFiles
"revoke-key"
"--with-key-password"
revokeKeyPasswordFiles
let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
keyPkts <- decodeOpenPGPInput "standard input" input
keyTks <-
runConduitRes $
CL.sourceList keyPkts
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
when (null keyTks) $
failWith
MissingInput
"revoke-key: no key found on standard input"
revocationSigPkts <-
mapM (createKeyRevocation keyPasswords) keyTks
let output = runPut (mapM_ Bin.put revocationSigPkts)
BL.putStr $
if revokeKeyNoArmor
then output
else AA.encodeLazy [Armor ArmorSignature [] output]
where
createKeyRevocation keyPasswords' keyTk = do
unlockedTk <-
unlockTransferableSecretKeyMaterial
"revoke-key failed"
"standard input"
"--with-key-password"
keyPasswords'
keyTk
let (pkp, mSka) = _tkuKey unlockedTk
ska <-
case mSka of
Just s -> pure s
Nothing ->
failWith
KeyCannotCertify
"revoke-key: key has no secret key material"
signingKey <- rsaSigningKey ska
issuer <- issuerSubpacketsFor "revoke-key" pkp
let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]
revocation = signKeyRevocationWithRSA pkp hashed issuer signingKey
case revocation of
Left err ->
failWith
BadData
("revoke-key: failed to create revocation: " ++ show err)
Right sig -> pure (SignaturePkt sig)
doRevokeUserId :: POSIXTime -> RevokeUserIdOptions -> IO ()
doRevokeUserId _cpt RevokeUserIdOptions {..} = do
input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
keyPkts <- decodeOpenPGPInput "standard input" input
keyTks <-
runConduitRes $
CL.sourceList keyPkts
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
when (null keyTks) $
failWith
MissingInput
"revoke-userid: no key found on standard input"
let keyTk = case keyTks of
(kt : _) -> kt
_ ->
error
"revoke-userid: no key found on standard input (should be caught above)"
(pkp, mSka) = _tkuKey keyTk
targetUserId = T.pack revokeUserIdString
unless (any ((== targetUserId) . fst) (_tkuUIDs keyTk)) $
failWith
MissingInput
( "revoke-userid: key has no user ID matching "
++ revokeUserIdString
)
ska <-
case mSka of
Just s -> pure s
Nothing ->
failWith
KeyCannotCertify
"revoke-userid: key has no secret key material"
signingKey <- rsaSigningKey ska
issuer <- issuerSubpacketsFor "revoke-userid" pkp
let hashed = [SigSubPacket False (SigCreationTime (_timestamp pkp))]
revocation =
signCertRevocationWithRSA
pkp
(UserId targetUserId)
hashed
issuer
signingKey
case revocation of
Left err ->
failWith
BadData
("revoke-userid: failed to create revocation: " ++ show err)
Right sig -> do
let revocationSigPkt = SignaturePkt sig
output = runPut (Bin.put revocationSigPkt)
BL.putStr $
if revokeUserIdNoArmor
then output
else AA.encodeLazy [Armor ArmorSignature [] output]
doUpdateKey :: POSIXTime -> UpdateKeyOptions -> IO ()
doUpdateKey cpt UpdateKeyOptions {..} = do
keyPasswordsRaw <-
loadPasswordFiles
"update-key"
"--with-key-password"
updateKeyPasswordFiles
let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
when updateKeyRevokeDeprecatedKeys $
hPutStrLn
stderr
"Warning: update-key: --revoke-deprecated-keys requested, but no deprecated-key detector is available; proceeding without synthetic revocations."
stdinInput <-
runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
stdinPkts <- decodeOpenPGPInput "stdin" stdinInput
stdinTks <-
runConduitRes $
CL.sourceList stdinPkts
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
when (null stdinTks) $
failWith
MissingInput
"update-key: no key found on standard input"
updateSourceTks <-
concat <$> mapM loadVerifyTKsFromFile updateKeyMergeCerts
when (null updateSourceTks) $
failWith MissingInput "update-key: no update keys found"
stdinUnlocked <-
mapM
(unlockUpdateKeyMaterial "standard input" keyPasswords)
stdinTks
updateUnlocked <-
mapM
(unlockUpdateKeyMaterial "update input" keyPasswords)
updateSourceTks
let updateTks =
if updateKeySigningOnly
then filter (updateKeyHasSigningCapability cpt) updateUnlocked
else updateUnlocked
when (updateKeySigningOnly && null updateTks) $
failWith
MissingInput
"update-key: no signing-capable update keys found"
let updatedTks =
map
( \targetTk ->
foldl'
(<>)
targetTk
( selectUpdateMergeInputs
cpt
updateKeyNoAddedCapabilities
targetTk
updateTks
)
)
stdinUnlocked
-- Choose armor type based on whether updated key has secret material
armorType =
if any hasSecretKeyMaterial updatedTks
then ArmorPrivateKeyBlock
else ArmorPublicKeyBlock
output = runPut (mapM_ Bin.put updatedTks)
BL.putStr $
if updateKeyNoArmor
then output
else AA.encodeLazy [Armor armorType [] output]
doMergeCerts :: MergeCertsOptions -> IO ()
doMergeCerts MergeCertsOptions {..} = do
stdinInput <-
runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
stdinPkts <- decodeOpenPGPInput "stdin" stdinInput
stdinTks <-
runConduitRes $
CL.sourceList stdinPkts
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
mergeInTks <-
concat <$> mapM loadVerifyTKsFromFile mergeCertsFiles
let mergedTks = mergeCertificatesForOutput stdinTks mergeInTks
output = runPut (mapM_ Bin.put mergedTks)
BL.putStr $
if mergeCertsNoArmor || BL.null output
then output
else AA.encodeLazy [Armor ArmorPublicKeyBlock [] output]
mergeCertificatesForOutput
:: [TKUnknown] -> [TKUnknown] -> [TKUnknown]
mergeCertificatesForOutput stdinTks mergeInTks =
map mergeGroup (groupByPrimaryKey stdinTks)
where
-- Upstream could expose this as a dedicated helper over TKWithWireRep
-- so downstreams can keep packet provenance while merging certs.
mergeGroup (base, rest) =
let primary = certificatePrimaryFingerprint base
mergedStdin = foldl' (<>) base rest
matchingMergeInputs =
filter ((== primary) . certificatePrimaryFingerprint) mergeInTks
in foldl' (<>) mergedStdin matchingMergeInputs
groupByPrimaryKey :: [TKUnknown] -> [(TKUnknown, [TKUnknown])]
groupByPrimaryKey [] = []
groupByPrimaryKey (tk : rest) =
let primary = certificatePrimaryFingerprint tk
(samePrimary, differentPrimary) =
partition ((== primary) . certificatePrimaryFingerprint) rest
in (tk, samePrimary) : groupByPrimaryKey differentPrimary
certificatePrimaryFingerprint :: TKUnknown -> B.ByteString
certificatePrimaryFingerprint =
BL.toStrict . unFingerprint . fingerprint . fst . _tkuKey
unlockUpdateKeyMaterial
:: String -> [BL.ByteString] -> TKUnknown -> IO TKUnknown
unlockUpdateKeyMaterial _ [] tk = pure tk
unlockUpdateKeyMaterial source keyPasswords tk =
unlockTransferableSecretKeyMaterial
"update-key failed"
source
"--with-key-password"
keyPasswords
tk
updateKeyHasSigningCapability :: POSIXTime -> TKUnknown -> Bool
updateKeyHasSigningCapability cpt tk =
any
( \funKey ->
S.null (fkufs funKey) || S.member SignDataKey (fkufs funKey)
)
(tkToFunKeysAt cpt tk)
selectUpdateMergeInputs
:: POSIXTime
-> Bool
-> TKUnknown
-> [TKUnknown]
-> [TKUnknown]
selectUpdateMergeInputs cpt noAddedCaps targetTk updateTks =
filteredByCaps
where
targetPrimary = certificatePrimaryFingerprint targetTk
mergeCandidates =
filter
((== targetPrimary) . certificatePrimaryFingerprint)
updateTks
targetCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt targetTk))
addsCapabilities updateTk =
let updateCapabilities = S.unions (map fkufs (tkToFunKeysAt cpt updateTk))
in not (S.null (updateCapabilities S.\\ targetCapabilities))
filteredByCaps =
if noAddedCaps
then filter (not . addsCapabilities) mergeCandidates
else mergeCandidates
soP :: Parser SignOptions
soP =
SignOptions
<$> switch (long "armor" <> help "armor the output")
<*> switch (long "no-armor" <> help "don't armor the output")
<*> optional
( strOption
( long "micalg-out"
<> metavar "MICALG"
<> help "write MIME micalg parameter value to file"
)
)
<*> many
( strOption
( long "with-key-password"
<> help "password for unlocking signing key material"
)
)
<*> option
(eitherReader asTypeReader)
(long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary)
<*> some
( strArgument
( metavar "KEYS..."
<> help "paths to at least one secret key, one key per filename"
)
)
where
astypeHelp =
helpDoc . Just $
pretty "what to treat the input as"
<> softline
<> list (map (pretty . fst) asTypes)
data SignOptions
= SignOptions
{ sArmor :: Bool
, sNoArmor :: Bool
, sMicalgOut :: Maybe String
, sKeyPasswords :: [String]
, sAs :: AsBinaryText
, sKeyFiles :: [String]
}
asTypes :: [(String, AsBinaryText)]
asTypes = [("binary", AsBinary), ("text", AsText)]
data AsBinaryText
= AsBinary
| AsText
deriving (Eq)
data InlineSignMode
= InlineSignAsBinary
| InlineSignAsText
| InlineSignAsClearSigned
deriving (Eq)
data EncryptFor
= EncryptForAny
| EncryptForStorage
| EncryptForCommunications
deriving (Eq)
asTypeReader :: String -> Either String AsBinaryText
asTypeReader = note "unknown as type" . flip lookup asTypes
encryptForReader :: String -> Either String EncryptFor
encryptForReader "any" = Right EncryptForAny
encryptForReader "storage" = Right EncryptForStorage
encryptForReader "communications" = Right EncryptForCommunications
encryptForReader _ =
Left
"encryption purpose must be one of: any, storage, communications"
doSign :: POSIXTime -> SignOptions -> IO ()
doSign pt SignOptions {..} = do
when (sNoArmor && sArmor) $
failWith
IncompatibleOptions
"sign: --armor and --no-armor are mutually exclusive"
forM_ sMicalgOut (ensureOutputPathAvailable "sign")
mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
when (sAs == AsText) $
ensureUTF8TextInput "sign" (BL.fromChunks mbs)
forM_
sMicalgOut
(\_ -> ensureCanonicalMIMETextInput (BL.fromChunks mbs))
signingPasswordsRaw <-
loadPasswordFiles "sign" "--with-key-password" sKeyPasswords
let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw
ks <- loadSigningKeys sKeyFiles signingPasswords
let ts = ThirtyTwoBitTimeStamp (floor pt)
payload' = BL.fromChunks mbs
payload = payload'
processedKeys <- mapM (normalizeSigningKey pt) ks
let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys
signingHash =
selectSigningHash
(concat perTransferKeySigners)
[]
legacySigningHashFallbackOrder
when (any null perTransferKeySigners) $
failWith
KeyCannotSign
"sign: supplied key cannot produce detached signatures"
signatures <-
mapM
(signData sAs ts signingHash payload)
(concat perTransferKeySigners)
let output = runPut (mapM_ (Bin.put . SignaturePkt) signatures)
case sMicalgOut of
Just outPath ->
writeFileWithOutputExistsCheck
"sign"
outPath
(renderMicalg signatures)
Nothing -> pure ()
BL.putStr $
if not sArmor && not sNoArmor
then AA.encodeLazy [Armor ArmorSignature [] output]
else output
where
signData
:: AsBinaryText
-> ThirtyTwoBitTimeStamp
-> HashAlgorithm
-> BL.ByteString
-> FunKey
-> IO SignaturePayload
signData mode t signHash d k = do
let st = case mode of
AsBinary -> BinarySig
AsText -> CanonicalTextSig
payload = d
issuerPackets <- unhashed (fpkp k)
signWithKey
"sign"
(fpkp k)
st
signHash
(hashed (fpkp k) t)
issuerPackets
payload
(fmska k)
hashed pkp ct =
[ SigSubPacket False (SigCreationTime ct)
, SigSubPacket
False
( IssuerFingerprint
(issuerFingerprintVersionFor pkp)
(fingerprint pkp)
)
]
unhashed pkp = issuerSubpacketsFor "sign" pkp
loadSigningKeys :: [String] -> [BL.ByteString] -> IO [TKUnknown]
loadSigningKeys keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles
where
loadFromFile path = do
lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
packets <- decodeOpenPGPInput path lbs
tks <-
runConduitRes $
CL.sourceList packets
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
let fallbackTks = signingFallbackTKs packets
when (null tks && null fallbackTks) $
failWith
MissingInput
("sign: no secret key material found in " ++ path)
mapM
(decryptSigningKeyMaterial path keyPasswords)
(if null tks then fallbackTks else tks)
decryptSigningKeyMaterial
:: FilePath -> [BL.ByteString] -> TKUnknown -> IO TKUnknown
decryptSigningKeyMaterial path keyPasswords =
unlockTransferableSecretKeyMaterial
"sign failed"
path
"--with-key-password"
keyPasswords
unlockTransferableSecretKeyMaterial
:: String
-> FilePath
-> String
-> [BL.ByteString]
-> TKUnknown
-> IO TKUnknown
-- Upstream could expose a TK-wide secret-key rewrite helper so SOP
-- subcommands do not need to walk primary and subkey packets separately.
unlockTransferableSecretKeyMaterial context path passwordOption keyPasswords tk = do
keyPair' <- decryptSecretPart (_tkuKey tk)
subs' <- mapM decryptSub (_tkuSubs tk)
pure tk {_tkuKey = keyPair', _tkuSubs = subs'}
where
decryptSecretPart (pkp, Just ska) = do
ska' <-
unlockSecretAddendum
context
path
passwordOption
keyPasswords
pkp
ska
pure (pkp, Just ska')
decryptSecretPart keyPair = pure keyPair
decryptSub (SecretSubkeyPkt pkp ska, sigs) = do
ska' <-
unlockSecretAddendum
context
path
passwordOption
keyPasswords
pkp
ska
pure (SecretSubkeyPkt pkp ska', sigs)
decryptSub sub = pure sub
unlockSecretAddendum
:: String
-> FilePath
-> String
-> [BL.ByteString]
-> SomePKPayload
-> SKAddendum
-> IO SKAddendum
unlockSecretAddendum _ _ _ _ _ sk@(SUUnencrypted _ _) = pure sk
unlockSecretAddendum context path passwordOption [] _ _ =
failWith
KeyIsProtected
( context
++ ": encrypted key material in "
++ path
++ " requires "
++ passwordOption
)
unlockSecretAddendum context path passwordOption keyPasswords pkp sk =
case tryDecrypt keyPasswords of
Right decrypted -> pure decrypted
Left _ ->
failWith
KeyIsProtected
( context
++ ": could not unlock key material in "
++ path
++ " with provided "
++ passwordOption
++ " values"
)
where
tryDecrypt [] = Left ()
tryDecrypt (password : rest) =
case decryptPrivateKey (pkp, sk) password of
Left _ -> tryDecrypt rest
Right decrypted -> Right decrypted
normalizeSigningKey :: POSIXTime -> TKUnknown -> IO TKUnknown
normalizeSigningKey pt tk =
case processTK (Just pt) tk of
Left err ->
failWith
BadData
("sign: invalid signing key material: " ++ show err)
Right normalized -> pure normalized
signPayloadWithKeys
:: POSIXTime
-> AsBinaryText
-> BL.ByteString
-> [TKUnknown]
-> [HashAlgorithm]
-> [HashAlgorithm]
-> IO [SignaturePayload]
signPayloadWithKeys pt asMode payload keys recipientHashPrefs fallbackOrder = do
processedKeys <- mapM (normalizeSigningKey pt) keys
let perTransferKeySigners = map (signingCapableRSAFunKeys pt) processedKeys
signingHash =
selectSigningHash
(concat perTransferKeySigners)
recipientHashPrefs
fallbackOrder
when (any null perTransferKeySigners) $
failWith
KeyCannotSign
"encrypt: supplied key cannot produce signatures"
mapM
(signData asMode ts signingHash payload)
(concat perTransferKeySigners)
where
ts = ThirtyTwoBitTimeStamp (floor pt)
signData
:: AsBinaryText
-> ThirtyTwoBitTimeStamp
-> HashAlgorithm
-> BL.ByteString
-> FunKey
-> IO SignaturePayload
signData mode t signHash d' k = do
let st = case mode of
AsBinary -> BinarySig
AsText -> CanonicalTextSig
payload' = d'
issuerPackets <- unhashed (fpkp k)
signWithKey
"encrypt"
(fpkp k)
st
signHash
(hashed (fpkp k) t)
issuerPackets
payload'
(fmska k)
hashed pkp ct =
[ SigSubPacket False (SigCreationTime ct)
, SigSubPacket
False
( IssuerFingerprint
(issuerFingerprintVersionFor pkp)
(fingerprint pkp)
)
]
unhashed pkp = issuerSubpacketsFor "encrypt" pkp
signingCapableFunKeys :: POSIXTime -> TKUnknown -> [FunKey]
signingCapableFunKeys pt =
filter canSign . tkToFunKeysAt pt
where
canSign k =
canSignDataUsage (fkufs k)
&& case fmska k of
Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True
Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True
Just (SUUnencrypted (UnknownSKey _) _) ->
isEd25519PKA (_pkalgo (fpkp k))
|| isEdDSAPKA (_pkalgo (fpkp k))
|| isEd448PKA (_pkalgo (fpkp k))
_ -> False
canSignDataUsage keyFlags = S.null keyFlags || S.member SignDataKey keyFlags
-- Legacy alias kept for internal call sites that have not been updated.
signingCapableRSAFunKeys :: POSIXTime -> TKUnknown -> [FunKey]
signingCapableRSAFunKeys = signingCapableFunKeys
{- | Algorithm-dispatching signature helper used by all sign paths.
Supports RSA (v4), Ed25519 (v4), and Ed448 (v4).
-}
signWithKey
:: String
-- ^ context for error messages
-> SomePKPayload
-> SigType
-> HashAlgorithm
-> [SigSubPacket]
-- ^ hashed subpackets
-> [SigSubPacket]
-- ^ unhashed subpackets
-> BL.ByteString
-- ^ payload to sign
-> Maybe SKAddendum
-> IO SignaturePayload
signWithKey ctx signerPKP st signHash hsd usd payload mska =
case mska of
Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) ->
validateRSASigningKeySize ctx signerPKP
>> if _keyVersion signerPKP == V6
then signRSAWithV6Salt (k {RSA.private_p = 0, RSA.private_q = 0})
else
signWithRSABuilder
signHash
(k {RSA.private_p = 0, RSA.private_q = 0})
Just (SUUnencrypted (EdDSAPrivateKey Ed25519 rawBytes) _) ->
case eitherCryptoError (Ed25519.secretKey rawBytes) of
Left err ->
failWith
BadData
(ctx ++ " failed: bad Ed25519 secret key: " ++ show err)
Right sk
| _keyVersion signerPKP == V6 -> signEd25519 sk
| isEdDSAPKA (_pkalgo signerPKP) ->
case signDataWithEd25519Legacy st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
Right sig -> pure sig
| otherwise ->
case signDataWithEd25519 st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
Right sig -> pure sig
Just (SUUnencrypted (EdDSAPrivateKey Ed448 rawBytes) _) ->
case eitherCryptoError (Ed448.secretKey rawBytes) of
Left err ->
failWith
BadData
(ctx ++ " failed: bad Ed448 secret key: " ++ show err)
Right sk
| _keyVersion signerPKP == V6 -> signEd448 sk
| otherwise ->
case signDataWithEd448 st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
Right sig -> pure sig
Just (SUUnencrypted (UnknownSKey rawBytes) _) ->
case () of
_
| isEd25519PKA (_pkalgo signerPKP) ->
do
normalized <- normalizeUnknownSecretForEdDSA ctx 32 rawBytes
case eitherCryptoError (Ed25519.secretKey normalized) of
Left err ->
failWith
BadData
(ctx ++ " failed: bad Ed25519 secret key: " ++ show err)
Right sk
| _keyVersion signerPKP == V6 -> signEd25519 sk
| isEdDSAPKA (_pkalgo signerPKP) ->
case signDataWithEd25519Legacy st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
Right sig -> pure sig
| otherwise ->
case signDataWithEd25519 st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
Right sig -> pure sig
| isEd448PKA (_pkalgo signerPKP) ->
do
normalized <- normalizeUnknownSecretForEdDSA ctx 57 rawBytes
case eitherCryptoError (Ed448.secretKey normalized) of
Left err ->
failWith
BadData
(ctx ++ " failed: bad Ed448 secret key: " ++ show err)
Right sk
| _keyVersion signerPKP == V6 -> signEd448 sk
| otherwise ->
case signDataWithEd448 st sk hsd usd payload of
Left err' -> failWith BadData (ctx ++ " failed: " ++ renderSignError err')
Right sig -> pure sig
_ ->
failWith
UnsupportedAsymmetricAlgo
( ctx
++ " failed: unsupported unknown signing key for algorithm "
++ show (_pkalgo signerPKP)
)
_ ->
failWith
BadData
(ctx ++ " failed: unsupported or encrypted signing key")
where
signEd25519 sk =
signWithV6Salt
(\salt -> signDataWithEd25519V6 st salt sk hsd usd payload)
signEd448 sk =
signWithV6Salt
(\salt -> signDataWithEd448V6 st salt sk hsd usd payload)
signRSAWithV6Salt privateKey =
signWithV6Salt
(\salt -> signDataWithRSAV6 st salt privateKey hsd usd payload)
signWithV6Salt signer = go [32, 64, 16, 20, 28, 48] []
where
go [] _ =
failWith
BadData
(ctx ++ " failed: unable to construct a valid v6 signature salt")
go (n : rest) tried = do
bytes <- getRandomBytes n
case signer (SignatureSalt (BL.fromStrict bytes)) of
Right sig -> pure sig
Left (SignV6SaltSizeMismatch _ expected _) ->
let expectedLen = fromIntegral expected
in if expectedLen `elem` tried
then
failWith
BadData
(ctx ++ " failed: unable to resolve v6 signature salt size")
else go (expectedLen : rest) (expectedLen : tried)
Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)
signWithRSABuilder hashToUse privateKey =
let builder =
SP.addUnhashedSubs
(SubpacketList usd)
( SP.addHashedSubs
(SubpacketList hsd)
(SP.sigBuilderInit st hashToUse)
)
in case signDataWithRSABuilder builder privateKey payload of
Left err -> failWith BadData (ctx ++ " failed: " ++ renderSignError err)
Right sig -> pure sig
normalizeUnknownSecretForEdDSA
:: String -> Int -> BL.ByteString -> IO B.ByteString
normalizeUnknownSecretForEdDSA ctx expectedLen rawLbs
| B.length raw == expectedLen = pure raw
| B.length raw >= 2 =
let bits =
(fromIntegral (B.index raw 0) `shiftL` 8)
.|. fromIntegral (B.index raw 1)
mpiBytes = (bits + 7) `div` 8
payload = B.drop 2 raw
in if B.length payload == mpiBytes && mpiBytes <= expectedLen
then pure (i2ospOf_ expectedLen (os2ip payload))
else bad
| otherwise = bad
where
raw = BL.toStrict rawLbs
bad =
failWith
BadData
( ctx
++ " failed: unsupported EdDSA secret key encoding (length="
++ show (B.length raw)
++ ")"
)
validateRSASigningKeySize :: String -> SomePKPayload -> IO ()
validateRSASigningKeySize ctx signerPKP =
case pubkeySize (_pubkey signerPKP) of
Right bits
| bits < 2048 ->
failWith
KeyCannotSign
( ctx
++ " failed: RSA signing keys smaller than 2048 bits are not supported"
)
| otherwise -> pure ()
Left err ->
failWith
BadData
(ctx ++ " failed: unable to determine RSA key size: " ++ err)
-- FIXME: clean this up
isEd25519PKA, isEd448PKA, isEdDSAPKA :: PubKeyAlgorithm -> Bool
isEd25519PKA pka = fromFVal pka == 27
isEdDSAPKA pka = fromFVal pka == 22
isEd448PKA pka = fromFVal pka == 28
selectSigningHash
:: [FunKey] -> [HashAlgorithm] -> [HashAlgorithm] -> HashAlgorithm
selectSigningHash signerKeys recipientHashPrefs fallbackOrder =
fromMaybe
SHA512
(find (hashSupportedByAllSigners signerKeys) candidateOrder)
where
requestedPrefs =
if null recipientHashPrefs
then signerPrefs
else recipientHashPrefs
signerPrefs = concatMap fpreferredHashes signerKeys
filteredRequested = filter (hashSupportedByAllSigners signerKeys) requestedPrefs
filteredSignerPrefs = filter (hashSupportedByAllSigners signerKeys) signerPrefs
candidateOrder = filteredRequested ++ filteredSignerPrefs ++ fallbackOrder
legacySigningHashFallbackOrder :: [HashAlgorithm]
legacySigningHashFallbackOrder = [SHA512, SHA384, SHA256, SHA224]
rfc9580SigningHashFallbackOrder :: [HashAlgorithm]
rfc9580SigningHashFallbackOrder = [SHA3_512, SHA3_256, SHA512, SHA384, SHA256, SHA224]
hashSupportedByAllSigners :: [FunKey] -> HashAlgorithm -> Bool
hashSupportedByAllSigners signers ha =
not (isDeprecatedHashAlgorithm ha)
&& all (`signerSupportsHashAlgorithm` ha) signers
signerSupportsHashAlgorithm :: FunKey -> HashAlgorithm -> Bool
signerSupportsHashAlgorithm signer ha =
not (isDeprecatedHashAlgorithm ha)
&& case _pkalgo (fpkp signer) of
RSA -> rsaPKCS15SupportedHash ha
DeprecatedRSASignOnly -> rsaPKCS15SupportedHash ha
DeprecatedRSAEncryptOnly -> rsaPKCS15SupportedHash ha
_ -> not (isOtherHashAlgorithm ha)
rsaPKCS15SupportedHash :: HashAlgorithm -> Bool
rsaPKCS15SupportedHash SHA224 = True
rsaPKCS15SupportedHash SHA256 = True
rsaPKCS15SupportedHash SHA384 = True
rsaPKCS15SupportedHash SHA512 = True
rsaPKCS15SupportedHash _ = False
isDeprecatedHashAlgorithm :: HashAlgorithm -> Bool
isDeprecatedHashAlgorithm DeprecatedMD5 = True
isDeprecatedHashAlgorithm SHA1 = True
isDeprecatedHashAlgorithm RIPEMD160 = True
isDeprecatedHashAlgorithm _ = False
isOtherHashAlgorithm :: HashAlgorithm -> Bool
isOtherHashAlgorithm (OtherHA _) = True
isOtherHashAlgorithm _ = False
hashAlgorithmHeaderName :: HashAlgorithm -> String
hashAlgorithmHeaderName DeprecatedMD5 = "MD5"
hashAlgorithmHeaderName SHA1 = "SHA1"
hashAlgorithmHeaderName RIPEMD160 = "RIPEMD160"
hashAlgorithmHeaderName SHA224 = "SHA224"
hashAlgorithmHeaderName SHA256 = "SHA256"
hashAlgorithmHeaderName SHA384 = "SHA384"
hashAlgorithmHeaderName SHA512 = "SHA512"
hashAlgorithmHeaderName SHA3_256 = "SHA3-256"
hashAlgorithmHeaderName SHA3_512 = "SHA3-512"
hashAlgorithmHeaderName (OtherHA _) = "SHA512"
ensureCanonicalMIMETextInput :: BL.ByteString -> IO ()
ensureCanonicalMIMETextInput lbs = do
let bs = BL.toStrict lbs
when (B.any (> 0x7f) bs) $
failWith
ExpectedText
"sign: --micalg-out requires canonical 7-bit text data on standard input"
case TE.decodeUtf8' bs of
Left _ ->
failWith
ExpectedText
"sign: --micalg-out requires UTF-8 text data on standard input"
Right _ -> pure ()
when (not (canonicalCRLFLineEndings bs)) $
failWith
ExpectedText
"sign: --micalg-out requires CRLF line endings on standard input"
when (hasTrailingLineWhitespace bs) $
failWith
ExpectedText
"sign: --micalg-out requires no trailing line whitespace on standard input"
where
canonicalCRLFLineEndings bytes = go (B.unpack bytes)
where
go [] = True
go [13] = False
go (13 : 10 : rest) = go rest
go (13 : _) = False
go (10 : _) = False
go (_ : rest) = go rest
hasTrailingLineWhitespace bytes =
endsWithWhitespace bytes
|| trailingWhitespaceBeforeCRLF (B.unpack bytes)
endsWithWhitespace bytes =
case B.unsnoc bytes of
Just (_, c) -> c == 32 || c == 9
Nothing -> False
trailingWhitespaceBeforeCRLF (a : 13 : 10 : rest)
| a == 32 || a == 9 = True
| otherwise = trailingWhitespaceBeforeCRLF (13 : 10 : rest)
trailingWhitespaceBeforeCRLF (_ : rest) = trailingWhitespaceBeforeCRLF rest
trailingWhitespaceBeforeCRLF _ = False
ensureUTF8TextInput :: String -> BL.ByteString -> IO ()
ensureUTF8TextInput subcommand lbs =
case TE.decodeUtf8' (BL.toStrict lbs) of
Left _ ->
failWith
ExpectedText
(subcommand ++ ": --as=text requires UTF-8 text on standard input")
Right _ -> pure ()
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] -> [TKUnknown]
signingFallbackTKs packets =
[ TKUnknown (pkp, Just ska) [] [] [] []
| SecretKeyPkt pkp ska <- packets
]
data FunKey
= FunKey
{ fpkp :: SomePKPayload
, fmska :: Maybe SKAddendum
, fkufs :: S.Set KeyFlag
, fpreferredHashes :: [HashAlgorithm]
, fpreferredSymmetricAlgorithms :: [SymmetricAlgorithm]
, fsupportsSEIPDv2 :: Bool
}
deriving (Show)
tkToFunKeysAt :: POSIXTime -> TKUnknown -> [FunKey]
tkToFunKeysAt pt tk@(TKUnknown (pkp, mska) _ uids _ subs) =
catMaybes (mainKey : map extract subs)
where
mainPreferredHashes = effectiveHashPreferencesAt pt tk
mainPreferredSymmetricAlgorithms = effectiveSymmetricPreferencesAt pt tk
mainSupportsSEIPDv2 = effectiveSEIPDv2SupportAt pt tk
mainKey =
Just
( FunKey
pkp
mska
(fromMaybe S.empty (grabASig uids >>= sig2KUFs))
mainPreferredHashes
mainPreferredSymmetricAlgorithms
mainSupportsSEIPDv2
)
sig2KUFs = getHasheds >=> find isKUF >=> getKUFs
grabASig :: [(a, [b])] -> Maybe b
grabASig = (listToMaybe >=> listToMaybe) . map snd -- FIXME: this should grab the "best" sig
getHasheds :: SignaturePayload -> Maybe [SigSubPacket]
getHasheds (SigV4 _ _ _ hasheds _ _ _) = Just hasheds
getHasheds (SigV6 _ _ _ _ hasheds _ _ _) = Just hasheds
getHasheds _ = Nothing
getKUFs :: SigSubPacket -> Maybe (S.Set KeyFlag)
getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs
getKUFs _ = Nothing
extract ((SecretSubkeyPkt spkp sska), sigs) =
return
( FunKey
spkp
(Just sska)
(fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
mainPreferredHashes
mainPreferredSymmetricAlgorithms
mainSupportsSEIPDv2
)
extract ((PublicSubkeyPkt spkp), sigs) =
return
( FunKey
spkp
Nothing
(fromMaybe S.empty (listToMaybe sigs >>= sig2KUFs))
mainPreferredHashes
mainPreferredSymmetricAlgorithms
mainSupportsSEIPDv2
)
extract _ = Nothing
effectiveHashPreferencesAt
:: POSIXTime -> TKUnknown -> [HashAlgorithm]
effectiveHashPreferencesAt pt tk =
concatMap toHashes $
fromMaybe
[]
( effectiveKeyPreferencesAt
(posixSecondsToUTCTime (realToFrac pt))
tk
)
where
toHashes (PreferredHashAlgorithms hashes) = hashes
toHashes _ = []
effectiveSymmetricPreferencesAt
:: POSIXTime -> TKUnknown -> [SymmetricAlgorithm]
effectiveSymmetricPreferencesAt pt tk =
concatMap toSymmetricAlgorithms $
fromMaybe
[]
( effectiveKeyPreferencesAt
(posixSecondsToUTCTime (realToFrac pt))
tk
)
where
toSymmetricAlgorithms (PreferredSymmetricAlgorithms algorithms) = algorithms
toSymmetricAlgorithms _ = []
effectiveSEIPDv2SupportAt :: POSIXTime -> TKUnknown -> Bool
effectiveSEIPDv2SupportAt pt tk =
any supportsSEIPDv2Flag $
concatMap toFeatureFlags $
fromMaybe
[]
( effectiveKeyPreferencesAt
(posixSecondsToUTCTime (realToFrac pt))
tk
)
where
toFeatureFlags (Features flags) = S.toList flags
toFeatureFlags _ = []
supportsSEIPDv2Flag FeatureSEIPDv2 = True
supportsSEIPDv2Flag _ = False
-- SOP Handler Stubs
-- These implement the stateless OpenPGP CLI commands per draft-16
doVerify :: POSIXTime -> VerifyOptions -> IO ()
doVerify cpt VerifyOptions {..} = do
(krs, verifyTks) <- loadVerifyContext cpt verifyCertFiles
signatureInput <-
runConduitRes $ CC.sourceFile verifySigFile .| CC.sinkLazy
sigPkts <- decodeLikeSignaturePackets signatureInput
let sigs = V.fromList (filter isDetachedVerificationSignaturePkt sigPkts)
blob <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
upperBound <- verificationUpperBound cpt verifyNotAfter
lowerBound <- verificationLowerBound cpt verifyNotBefore
let sigsWithoutUnsupportedCritical =
V.filter
(not . detachedSignatureHasUnsupportedCriticalSubpackets)
sigs
binaryVerifications <-
verifyWithLiteralData
BinaryData
blob
sigsWithoutUnsupportedCritical
krs
upperBound
verifications <-
if any isRight binaryVerifications
then pure binaryVerifications
else
verifyWithLiteralData
TextData
blob
sigsWithoutUnsupportedCritical
krs
upperBound
let decodedVerifications = map (first show) verifications
signerPolicyAdjusted =
map
(enforceVerificationSignerPolicy cpt verifyTks)
decodedVerifications
let filtered =
filterByVerificationBounds
lowerBound
upperBound
signerPolicyAdjusted
policyFiltered =
filter (not . verificationResultUsesDeprecatedHash) filtered
mapM_
(putStrLn . renderSOPVerificationLine verifyTks)
(rights policyFiltered)
case any isRight policyFiltered of
True -> exitSuccess
_ -> failWith NoSignature "No acceptable signatures found"
where
decodeLikeSignaturePackets lbs = do
decodedArmors <-
decodeAsciiArmorInput
("signature input in " ++ verifySigFile)
lbs
case decodedArmors of
Just armors ->
case firstBy isDetachedSignatureArmor armors of
Just (Armor ArmorSignature _ bs) ->
parseOpenPGPPackets
("signature input in " ++ verifySigFile)
(BL.fromStrict (BLC8.toStrict bs))
_ ->
case firstBy isDetachedSignatureUnsupportedArmor armors of
Just (ClearSigned _ _ _) ->
failWith
BadData
("verify: expected detached signatures in " ++ verifySigFile)
Just (Armor _ _ _) ->
failWith
BadData
("verify: expected signature armor in " ++ verifySigFile)
_ ->
parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs
Nothing ->
parseOpenPGPPackets ("signature input in " ++ verifySigFile) lbs
verifyWithLiteralData format payload sigs keyring upperBound =
runConduitRes $
CC.yieldMany
(V.cons (LiteralDataPkt format mempty 0 payload) sigs)
.| conduitVerify keyring upperBound
.| CC.sinkList
detachedSignatureHasUnsupportedCriticalSubpackets :: Pkt -> Bool
detachedSignatureHasUnsupportedCriticalSubpackets (SignaturePkt sig) =
any criticalUnsupported (signatureHashedSubpackets sig)
where
criticalUnsupported (SigSubPacket True (OtherSigSub _ _)) = True
criticalUnsupported (SigSubPacket True (UserDefinedSigSub _ _)) = True
criticalUnsupported (SigSubPacket True (NotationData _ _ _)) = True
criticalUnsupported _ = False
detachedSignatureHasUnsupportedCriticalSubpackets _ = False
signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket]
signatureHashedSubpackets (SigV4 _ _ _ hashed _ _ _) = hashed
signatureHashedSubpackets (SigV6 _ _ _ _ hashed _ _ _) = hashed
signatureHashedSubpackets _ = []
verificationResultUsesDeprecatedHash
:: Either String Verification -> Bool
verificationResultUsesDeprecatedHash (Right verification) =
verificationUsesDeprecatedHash verification
verificationResultUsesDeprecatedHash _ = False
verificationUsesDeprecatedHash :: Verification -> Bool
verificationUsesDeprecatedHash (Verification _ sigPayload _) =
isDeprecatedHashAlgorithm (signatureHashAlgorithm sigPayload)
signatureHashAlgorithm :: SignaturePayload -> HashAlgorithm
signatureHashAlgorithm (SigV3 _ _ _ _ ha _ _) = ha
signatureHashAlgorithm (SigV4 _ _ ha _ _ _ _) = ha
signatureHashAlgorithm (SigV6 _ _ ha _ _ _ _ _) = ha
signatureHashAlgorithm (SigVOther _ _) = OtherHA 0
enforceVerificationSignerPolicy
:: POSIXTime
-> [TKUnknown]
-> Either String Verification
-> Either String Verification
enforceVerificationSignerPolicy _ _ result@(Left _) = result
enforceVerificationSignerPolicy cpt verifyTks result@(Right verification)
| signerAllowed = result
| otherwise =
Left
"verification failed: signer key is not valid for signing at signature creation time"
where
signerAllowed = any signerMatchesProcessed verifyTks
signerFp = fingerprint (_verificationSigner verification)
verificationTimePosix =
maybe
cpt
(realToFrac . utcTimeToPOSIXSeconds)
(signatureCreationTime (_verificationSignature verification))
verificationTime = posixSecondsToUTCTime verificationTimePosix
signerMatchesProcessed tk
| not (keyMatchesFingerprint True tk signerFp) = False
| keyMatchesFingerprint False tk signerFp = True
| otherwise =
any (subkeyAllowsSigning verificationTime signerFp) (_tkuSubs tk)
subkeyAllowsSigning
:: UTCTime -> Fingerprint -> (Pkt, [SignaturePayload]) -> Bool
subkeyAllowsSigning t signerFp (pkt, sigs) =
case subkeyPayload pkt of
Just pkp
| fingerprint pkp == signerFp ->
any
(bindingSignatureAllowsSigning t)
(filter isSKBindingSig sigs)
_ -> False
where
subkeyPayload (PublicSubkeyPkt pkp) = Just pkp
subkeyPayload (SecretSubkeyPkt pkp _) = Just pkp
subkeyPayload _ = Nothing
bindingSignatureAllowsSigning
:: UTCTime -> SignaturePayload -> Bool
bindingSignatureAllowsSigning t sig =
allowsSigning && hasValidBacksig
where
allowsSigning =
let flagSets = signatureKeyFlagSets sig
in null flagSets || any (S.member SignDataKey) flagSets
hasValidBacksig =
any
( \embedded ->
isPKBindingSig embedded
&& not (signatureExpiredAt t embedded)
)
(signatureEmbeddedSignatures sig)
signatureEmbeddedSignatures
:: SignaturePayload -> [SignaturePayload]
signatureEmbeddedSignatures sig =
[ embedded
| SigSubPacket _ (EmbeddedSignature embedded) <-
signatureSubpackets sig
]
signatureKeyFlagSets :: SignaturePayload -> [S.Set KeyFlag]
signatureKeyFlagSets sig =
[ flags
| SigSubPacket _ (KeyFlags flags) <- signatureSubpackets sig
]
signatureExpiredAt :: UTCTime -> SignaturePayload -> Bool
signatureExpiredAt t sig =
case (signatureCreationTime sig, signatureValiditySeconds sig) of
(Just created, Just validitySeconds) ->
utcTimeToPOSIXSeconds t
>= utcTimeToPOSIXSeconds created + fromIntegral validitySeconds
_ -> False
signatureValiditySeconds :: SignaturePayload -> Maybe Integer
signatureValiditySeconds sig =
listToMaybe
[ fromIntegral secs
| SigSubPacket _ (SigExpirationTime (ThirtyTwoBitDuration secs)) <-
signatureSubpackets sig
]
verificationUpperBound
:: POSIXTime -> Maybe String -> IO (Maybe UTCTime)
verificationUpperBound cpt Nothing = return (Just (posixSecondsToUTCTime cpt))
verificationUpperBound _ (Just "-") = return Nothing
verificationUpperBound cpt (Just "now") =
return (Just (posixSecondsToUTCTime cpt))
verificationUpperBound _ (Just s) = do
let m = iso8601ParseM s :: Maybe UTCTime
case m of
Just t -> return (Just t)
Nothing -> failWith BadData ("Invalid DATE value: " ++ s)
verificationLowerBound
:: POSIXTime -> Maybe String -> IO (Maybe UTCTime)
verificationLowerBound _ Nothing = return Nothing
verificationLowerBound _ (Just "-") = return Nothing
verificationLowerBound cpt (Just "now") =
return (Just (posixSecondsToUTCTime cpt))
verificationLowerBound _ (Just s) = do
let m = iso8601ParseM s :: Maybe UTCTime
case m of
Just t -> return (Just t)
Nothing -> failWith BadData ("Invalid DATE value: " ++ s)
filterByVerificationBounds
:: Maybe UTCTime
-> Maybe UTCTime
-> [Either String Verification]
-> [Either String Verification]
filterByVerificationBounds lower upper = map (>>= ensureBounds)
where
ensureBounds v =
case signatureCreationTime (_verificationSignature v) of
Nothing ->
Left "verification failed: signature is missing creation time"
Just sigTime
| Just upperBound <- upper
, sigTime > upperBound ->
Left
"verification failed: signature created after --not-after bound"
| Just lowerBound <- lower
, sigTime < lowerBound ->
Left
"verification failed: signature created before --not-before bound"
| otherwise -> Right v
signatureCreationTime :: SignaturePayload -> Maybe UTCTime
signatureCreationTime (SigV4 _ _ _ hashed _ _ _) =
firstCreationTime hashed
signatureCreationTime (SigV6 _ _ _ _ hashed _ _ _) =
firstCreationTime hashed
signatureCreationTime _ = Nothing
firstCreationTime :: [SigSubPacket] -> Maybe UTCTime
firstCreationTime = listToMaybe . mapMaybe getCreation
where
getCreation (SigSubPacket _ (SigCreationTime (ThirtyTwoBitTimeStamp ts))) =
Just (posixSecondsToUTCTime (fromIntegral ts))
getCreation _ = Nothing
isDetachedVerificationSignaturePkt :: Pkt -> Bool
isDetachedVerificationSignaturePkt (SignaturePkt (SigV4 sigType _ _ _ _ _ _)) =
sigType == BinarySig || sigType == CanonicalTextSig
isDetachedVerificationSignaturePkt (SignaturePkt (SigV6 sigType _ _ _ _ _ _ _)) =
sigType == BinarySig || sigType == CanonicalTextSig
isDetachedVerificationSignaturePkt _ = False
doInlineVerify :: POSIXTime -> InlineVerifyOptions -> IO ()
doInlineVerify cpt InlineVerifyOptions {..} = do
(krs, verifyTks) <- loadVerifyContext cpt inlineCertFiles
signedInput <-
runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
upperBound <- verificationUpperBound cpt inlineNotAfter
lowerBound <- verificationLowerBound cpt inlineNotBefore
(allowTrailingSignatures, parsedPackets) <-
inlineVerifyPackets signedInput
packets <-
normalizeInlineVerifyPackets
allowTrailingSignatures
parsedPackets
let verifications =
map (first show) (verifyPacketsBatch krs upperBound packets)
filtered = filterByVerificationBounds lowerBound upperBound verifications
successLines = map (renderSOPVerificationLine verifyTks) (rights filtered)
renderedOut =
if null successLines
then ""
else unlines successLines
case verificationsOut of
Just outPath ->
writeFileWithOutputExistsCheck
"inline-verify"
outPath
renderedOut
Nothing -> pure ()
case any isRight filtered of
True ->
extractSingleLiteralPayload packets >>= BL.putStr >> exitSuccess
_ -> failWith NoSignature "No acceptable signatures found"
where
inlineVerifyPackets :: BL.ByteString -> IO (Bool, [Pkt])
inlineVerifyPackets lbs = do
decodedArmors <- decodeAsciiArmorInput "inline-verify input" lbs
case decodedArmors of
Just armors ->
case listToMaybe (filter isInlineVerifyCandidateArmor armors) of
Just (Armor ArmorMessage _ bs) -> do
let packetBytes = BL.fromStrict (BLC8.toStrict bs)
packets <-
parseInlineVerifyMessagePackets
"inline-verify armored message"
packetBytes
pure (False, packets)
Just (ClearSigned headers cleartext signatureArmor) -> do
validateClearSignedEnvelopeBounds lbs
validateClearSignedHeaders headers
sigPkts <- clearSignedSignaturePackets signatureArmor
pure
( True
, LiteralDataPkt
TextData
BL.empty
0
(BL.fromStrict (BLC8.toStrict cleartext))
: sigPkts
)
Just (Armor _ _ _) ->
failWith
BadData
"inline-verify expects an armored OpenPGP message or cleartext signed message"
Nothing -> do
packets <-
parseInlineVerifyMessagePackets "inline-verify input" lbs
pure (False, packets)
Nothing -> do
packets <-
parseInlineVerifyMessagePackets "inline-verify input" lbs
pure (False, packets)
parseInlineVerifyMessagePackets
:: String -> BL.ByteString -> IO [Pkt]
parseInlineVerifyMessagePackets context packetBytes = do
rawPkts <- parseRawOpenPGPPackets context packetBytes
when (any compressedPacketParseFailed rawPkts) $
failWith
BadData
"inline-verify input has malformed compressed packet data"
when (any compressedPacketIsEmpty rawPkts) $
failWith
BadData
"inline-verify input has empty compressed packet data"
expanded <- expandPacketsStrict context rawPkts
when
(any isMarkerPacket expanded && any isCompressedPacket rawPkts)
$ failWith
BadData
"inline-verify input has malformed compressed packet sequence"
pure expanded
expandPacketsStrict :: String -> [Pkt] -> IO [Pkt]
expandPacketsStrict context =
fmap concat . mapM expandPacket
where
expandPacket pkt =
case decompressPkt pkt of
Left err ->
failWith
BadData
( context
++ ": failed to parse compressed packet: "
++ renderCompressionError err
)
Right packets -> pure packets
isInlineVerifyCandidateArmor :: Armor -> Bool
isInlineVerifyCandidateArmor (Armor ArmorMessage _ _) = True
isInlineVerifyCandidateArmor ClearSigned {} = True
isInlineVerifyCandidateArmor _ = False
clearSignedSignaturePackets :: Armor -> IO [Pkt]
clearSignedSignaturePackets (Armor ArmorSignature _ sigbs) =
let sigPktsSource =
parseOpenPGPPackets
"cleartext signature block"
(BL.fromStrict (BLC8.toStrict sigbs))
in do
parsed <- sigPktsSource
let sigPkts = filter isSignaturePkt parsed
if null sigPkts
then
failWith
BadData
"cleartext signature block has no signature packets"
else return sigPkts
clearSignedSignaturePackets (Armor _ _ _) =
failWith
BadData
"cleartext signed message does not contain an armored signature block"
clearSignedSignaturePackets (ClearSigned _ _ inner) =
clearSignedSignaturePackets inner
isSignaturePkt :: Pkt -> Bool
isSignaturePkt SignaturePkt {} = True
isSignaturePkt _ = False
normalizeInlineVerifyPackets :: Bool -> [Pkt] -> IO [Pkt]
normalizeInlineVerifyPackets allowTrailingSignatures pkts
| any isBrokenPacket relevantPkts =
failWith
BadData
"inline-verify input contains malformed packet encoding"
| any (not . isInlineVerificationPacket) filteredPkts =
failWith
BadData
"inline-verify input contains unsupported packet types"
| otherwise =
case ( [pkt | pkt@LiteralDataPkt {} <- filteredPkts]
, [pkt | pkt@SignaturePkt {} <- filteredPkts]
) of
([], _) ->
failWith
BadData
"inline-verify input has no literal message payload"
([_], []) ->
failWith
BadData
"inline-verify input has no signatures"
([lit], sigs)
| not hasOnePass
&& ( null signaturePositions
|| not (all (< literalIndex) signaturePositions)
)
&& ( not allowTrailingSignatures
|| not (all (> literalIndex) signaturePositions)
) ->
failWith
BadData
"inline-verify input has malformed signed-message packet order"
| otherwise -> pure (lit : sigs)
(_, _) ->
failWith
BadData
"inline-verify input contains multiple literal payloads"
where
relevantPkts = filter (not . isMarkerPacket) pkts
filteredPkts = filter (not . isIgnorableInlineVerifyPacket) relevantPkts
packetPositions = zip [0 :: Int ..] filteredPkts
signaturePositions = [i | (i, SignaturePkt {}) <- packetPositions]
onePassPositions = [i | (i, OnePassSignaturePkt {}) <- packetPositions]
literalPositions = [i | (i, LiteralDataPkt {}) <- packetPositions]
hasOnePass = not (null onePassPositions)
literalIndex =
case literalPositions of
(i : _) -> i
[] -> -1
isBrokenPacket BrokenPacketPkt {} = True
isBrokenPacket _ = False
isIgnorableInlineVerifyPacket :: Pkt -> Bool
isIgnorableInlineVerifyPacket (OtherPacketPkt tag _) = tag >= 40
isIgnorableInlineVerifyPacket _ = False
isInlineVerificationPacket :: Pkt -> Bool
isInlineVerificationPacket LiteralDataPkt {} = True
isInlineVerificationPacket SignaturePkt {} = True
isInlineVerificationPacket OnePassSignaturePkt {} = True
isInlineVerificationPacket (OtherPacketPkt tag _) = tag >= 40
isInlineVerificationPacket BrokenPacketPkt {} = False
isInlineVerificationPacket _ = False
doEncrypt :: POSIXTime -> EncryptOptions -> IO ()
doEncrypt cpt EncryptOptions {..} = do
when (encNoArmor && encArmor) $
failWith
IncompatibleOptions
"encrypt: --armor and --no-armor are mutually exclusive"
payload <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
when (encAs == AsText) $
ensureUTF8TextInput "encrypt" payload
when encWithoutIntegrityCheck $
failWith
UnsupportedOption
"encrypt: --without-integrity-check is not supported by this backend"
symmetricPasswordsRaw <-
loadPasswordFiles "encrypt" "--with-password" encPasswords
symmetricPasswords <-
mapM
(normalizeHumanReadablePassword "encrypt" "--with-password")
symmetricPasswordsRaw
signingKeyPasswordsRaw <-
loadPasswordFiles
"encrypt"
"--with-key-password"
encSignWithKeyPasswords
let signingKeyPasswords = concatMap passwordRetryCandidates signingKeyPasswordsRaw
encryptProfile <- parseEncryptProfile encProfile
when
(not (null encRecipientCerts) && not (null symmetricPasswords))
$ failWith
UnsupportedOption
"encrypt: combining recipient certificates with --with-password is not yet supported"
recipientKeys <-
if null encRecipientCerts
then pure []
else loadEncryptRecipients cpt encFor encRecipientCerts
recipientHashPrefs <-
if null encRecipientCerts
then pure []
else loadRecipientPreferredHashes cpt encRecipientCerts
signatures <-
if null encSignWithKeyFiles
then pure []
else do
signingKeys <-
loadSigningKeys encSignWithKeyFiles signingKeyPasswords
signPayloadWithKeys
cpt
encAs
payload
signingKeys
recipientHashPrefs
( case encryptProfile of
EncryptProfileRFC9580 -> rfc9580SigningHashFallbackOrder
EncryptProfileRFC4880 -> legacySigningHashFallbackOrder
)
out <-
case encRecipientCerts of
[] ->
doEncryptWithPassword
encryptProfile
payload
symmetricPasswords
encSessionKeyOutFile
_ ->
doEncryptForRecipients
encryptProfile
encAs
payload
signatures
recipientKeys
encSessionKeyOutFile
BL.putStr $
if encNoArmor
then out
else AA.encodeLazy [Armor ArmorMessage [] out]
doEncryptWithPassword
:: EncryptProfile
-> BL.ByteString
-> [BL.ByteString]
-> Maybe String
-> IO BL.ByteString
doEncryptWithPassword encryptProfile payload passwords sessionKeyOutFile = do
password <-
case passwords of
[] ->
failWith
MissingArg
"encrypt: supply at least one recipient certificate or --with-password"
[p] -> pure p
_ ->
failWith
UnsupportedOption
"encrypt: multiple --with-password values are not yet supported"
let exposure =
if isJust sessionKeyOutFile
then ExposeSessionMaterial
else DoNotExposeSessionMaterial
encrypted <-
case encryptProfile of
EncryptProfileRFC9580 -> do
s2kSalt <- Salt16 <$> getRandomBytes 16
iv <- IV <$> getRandomBytes 32
pure $
encryptMessage
RFC9580EncryptMessageOptions
{ rfc9580EncryptMessageExposure = exposure
, rfc9580EncryptMessageSymmetricAlgorithm = AES256
, rfc9580EncryptMessageS2K = Argon2 s2kSalt 1 4 15
, rfc9580EncryptMessageIV = iv
}
(mkPassphrase password)
(mkClearPayload payload)
EncryptProfileRFC4880 -> do
salt <- Salt8 <$> getRandomBytes 8
iv <- IV <$> getRandomBytes 16
pure $
encryptMessage
RFC4880EncryptMessageOptions
{ rfc4880EncryptMessageExposure = exposure
, rfc4880EncryptMessageSymmetricAlgorithm = AES256
, rfc4880EncryptMessageS2K = IteratedSalted SHA256 salt 65536
, rfc4880EncryptMessageIV = iv
}
(mkPassphrase password)
(mkClearPayload payload)
case encrypted of
Left err -> failWith BadData ("encrypt failed: " ++ show err)
Right (ciphertext, mRecoveredSession) -> do
forM_ sessionKeyOutFile $ \path ->
case mRecoveredSession of
Just recoveredSession ->
writeFileWithOutputExistsCheck
"encrypt"
path
( renderSessionKeyOutLine
(fromFVal (recoveredSessionAlgorithm recoveredSession))
(unSessionKey (recoveredSessionKey recoveredSession))
++ "\n"
)
Nothing ->
failWith
UnsupportedOption
"encrypt: --session-key-out unavailable for this password encryption mode"
pure (encryptedPayloadBytes ciphertext)
doEncryptForRecipients
:: EncryptProfile
-> AsBinaryText
-> BL.ByteString
-> [SignaturePayload]
-> [FunKey]
-> Maybe String
-> IO BL.ByteString
doEncryptForRecipients encryptProfile asMode payload signatures recipients sessionKeyOutFile = do
let targets = map recipientTargetFor recipients
payloadShape =
defaultRecipientPayloadShape
{ recipientPayloadDataType = literalDataType
, recipientPayloadUseOnePassSignatures = not (null signatures)
, recipientPayloadSignatures = signatures
}
result <-
if useStrictEncryptProfile
then
encryptForRecipients
RecipientEncryptRequest
{ recipientEncryptRequestTargets = targets
, recipientEncryptRequestPayloadShape = payloadShape
, recipientEncryptRequestPayload = BL.toStrict payload
, recipientEncryptRequestSymmetricOverride = symmetricOverride
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Nothing
, recipientEncryptRequestChunkSizeOverride = Nothing
, recipientEncryptRequestSaltOverride = Nothing
}
}
else
encryptForRecipients
RecipientEncryptRequest
{ recipientEncryptRequestTargets = targets
, recipientEncryptRequestPayloadShape = payloadShape
, recipientEncryptRequestPayload = BL.toStrict payload
, recipientEncryptRequestSymmetricOverride = symmetricOverride
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv1Overrides
{ recipientEncryptRequestIVOverride = Nothing
}
}
RecipientEncryptResult {..} <-
case result of
Left err ->
failWith
(sopFailureForPKESKEncryptError err)
("encrypt failed: " ++ renderPKESKEncryptError err)
Right 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
recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
else case _pkalgo recipient of
ECDH ->
-- Under strict (SEIPDv2) mode, keep Curve25519-compatible v4 ECDH keys on
-- the X25519/v6 path so ESK/payload versions stay aligned.
if recipientNeedsV6PKESK
then case normalizeX25519CompatibleECDHRecipient recipient of
Just x25519Recipient ->
recipientEncryptionTargetWithStrategy
x25519Recipient
RecipientPreferV6
Nothing ->
recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
else
recipientEncryptionTargetWithStrategy
recipient
RecipientForceV3Interop
DeprecatedRSAEncryptOnly ->
if recipientNeedsV6PKESK
then
recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
else
recipientEncryptionTargetWithStrategy
recipient
RecipientForceV3Interop
RSA ->
if recipientNeedsV6PKESK
then
recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
else
recipientEncryptionTargetWithStrategy
recipient
RecipientForceV3Interop
_ ->
if recipientNeedsV6PKESK
then
recipientEncryptionTargetWithStrategy recipient RecipientPreferV6
else recipientEncryptionTarget recipient
normalizeX25519CompatibleECDHRecipient pkp =
case _pubkey pkp of
ECDHPubKey (EdDSAPubKey Ed25519 _) _ _ ->
Just
( PKPayload
(_keyVersion pkp)
(_timestamp pkp)
(_v3exp pkp)
X25519
(_pubkey pkp)
)
_ -> Nothing
parseEncryptProfile :: Maybe String -> IO EncryptProfile
parseEncryptProfile Nothing = pure EncryptProfileRFC9580
parseEncryptProfile (Just profileName) =
case profileName of
"default" -> pure EncryptProfileRFC9580
"rfc9580" -> pure EncryptProfileRFC9580
"security" -> pure EncryptProfileRFC9580
"performance" -> pure EncryptProfileRFC9580
"rfc4880" -> pure EncryptProfileRFC4880
"compatibility" -> pure EncryptProfileRFC4880
_ ->
failWith
UnsupportedProfile
("encrypt: unsupported profile " ++ profileName)
doDecrypt :: POSIXTime -> DecryptOptions -> IO ()
doDecrypt cpt DecryptOptions {..} = do
when (decNoArmor && decArmor) $
failWith
IncompatibleOptions
"decrypt: --armor and --no-armor are mutually exclusive"
when decWithoutIntegrityCheck $
failWith
UnsupportedOption
"decrypt: --without-integrity-check is not supported by this backend"
sessionKeys <- parseDecryptSessionKeys decSessionKeys
(verificationOutputPath, usingDeprecatedVerifyOut) <-
resolveDecryptVerificationsOut
decVerificationsOutFile
decDeprecatedVerifyOutFile
let hasVerifyWith = not (null decVerifyCerts)
hasVerifyOut = isJust verificationOutputPath
hasVerifyBounds = isJust decVerifyNotBefore || isJust decVerifyNotAfter
doingVerification = hasVerifyWith && hasVerifyOut
when (hasVerifyWith /= hasVerifyOut) $
failWith
IncompleteVerification
"decrypt: verification requires both --verify-with and --verifications-out"
when (hasVerifyBounds && not doingVerification) $
failWith
IncompleteVerification
"decrypt: --verify-not-before/--verify-not-after require both --verify-with and --verifications-out"
passwords <-
loadPasswordFiles "decrypt" "--with-password" decPasswords
keyPasswordsRaw <-
loadPasswordFiles "decrypt" "--with-key-password" decKeyPasswords
let keyPasswords = concatMap passwordRetryCandidates keyPasswordsRaw
when (null passwords && null sessionKeys && null decKeyFiles) $
failWith
MissingArg
"decrypt: supply KEYS, --with-password, or --with-session-key"
ciphertextInput <-
runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
ciphertext <- decodeCiphertextInput ciphertextInput
validateDecryptPartialBodyEncoding ciphertext
ciphertextPktsRaw <-
parseRawOpenPGPPackets "decrypt input" ciphertext
let ciphertextPkts =
filter
( \pkt ->
not
( isForwardCompatUnknownESKPacket pkt
|| isUnsupportedSKESKPacket pkt
)
)
ciphertextPktsRaw
-- Pre-flight: reject messages with no encrypted payload at all (upstream
-- won't produce a useful DecryptMalformedStructure for the empty case).
when (not (any isEncryptedPayloadPacket ciphertextPkts)) $
failWith BadData "decrypt input: no encrypted data packet found"
validateCiphertextPacketLayout ciphertextPkts
recipientKeys <-
loadDecryptRecipientKeys cpt decKeyFiles keyPasswords
when
( null recipientKeys
&& not (null decKeyFiles)
&& null passwords
&& null sessionKeys
)
$ failWith
CannotDecrypt
"decrypt failed: no usable secret key material found in provided KEYS"
let passwordAttempts =
case passwords of
[] -> [[]]
_ ->
map
(\password -> [password])
(concatMap passwordRetryCandidates passwords)
runDecryptAttemptWithPolicy decryptPolicy keyCandidates passwordBytes = do
passwordQueue <- newIORef passwordBytes
sessionKeyQueue <-
newIORef (map decryptSessionKeyMaterial sessionKeys)
let decryptInputPkts = prioritizeDecryptablePKESKs keyCandidates ciphertextPkts
let keyResolutionResolver =
selectRecipientKeyInfosByRecipientIdentifier keyCandidates
let opts =
Decrypt.DecryptOptions
{ Decrypt.decryptOptionsKeyResolution =
DecryptWithUnwrapCandidatesCallback keyResolutionResolver
, Decrypt.decryptOptionsPolicy = decryptPolicy
, Decrypt.decryptOptionsPassphraseCallback =
decryptInputCallback passwordQueue sessionKeyQueue
}
(outcome, pkts) <-
runConduitRes $
CL.sourceList decryptInputPkts
.| fuseBoth (Decrypt.conduitDecrypt opts) CL.consume
case outcome of
DecryptMalformedStructure reason ->
pure (Left reason)
DecryptTruncated ->
failWith BadData "decrypt failed: encrypted message is truncated"
_ -> pure (Right pkts)
tryDecryptWithPasswords [passwordBytes] =
runDecryptAttempt recipientKeys passwordBytes
`catch` decryptIOFailureToSOP
tryDecryptWithPasswords (passwordBytes : rest) =
runDecryptAttempt recipientKeys passwordBytes `catch` retryNext
where
retryNext :: ExitCode -> IO [Pkt]
retryNext exitCode
| exitCode == ExitFailure (failureCode CannotDecrypt) =
tryDecryptWithPasswords rest
| otherwise = throwIO exitCode
tryDecryptWithPasswords [] =
failWith
CannotDecrypt
"decrypt failed: passphrase required but not provided"
decryptIOFailureToSOP :: IOException -> IO [Pkt]
decryptIOFailureToSOP err =
failWith
CannotDecrypt
("decrypt failed: " ++ displayException err)
runDecryptAttempt keyCandidates passwordBytes = do
strictOutcome <-
runDecryptAttemptWithPolicy
defaultDecryptPolicy
keyCandidates
passwordBytes
case strictOutcome of
Right pkts -> pure pkts
Left reason
| shouldRetryLenientDecrypt reason keyCandidates passwordBytes -> do
lenientOutcome <-
runDecryptAttemptWithPolicy
lenientDecryptPolicy
keyCandidates
passwordBytes
case lenientOutcome of
Right pkts -> pure pkts
Left lenientReason ->
failWith
BadData
( "decrypt failed: malformed encrypted message structure ("
++ lenientReason
++ ")"
)
| otherwise ->
failWith
BadData
( "decrypt failed: malformed encrypted message structure ("
++ reason
++ ")"
)
shouldRetryLenientDecrypt reason keyCandidates passwordBytes
| "ESK packets must immediately precede encrypted data"
`isInfixOf` reason =
True
| "ESK packets present but none are version-aligned with SEIPDv2 payload"
`isInfixOf` reason =
null passwordBytes
&& not (null keyCandidates)
&& any isLegacyRSAPKESK ciphertextPkts
| otherwise = False
isLegacyRSAPKESK (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) =
pka == RSA || pka == DeprecatedRSAEncryptOnly
isLegacyRSAPKESK _ = False
decryptedPktsRaw <- tryDecryptWithPasswords passwordAttempts
sessionKeyOutLine <-
resolveSessionKeyOut
decSessionKeyOutFile
sessionKeys
ciphertextPkts
recipientKeys
(concatMap passwordRetryCandidates passwords)
decryptedPkts <- do
decompressed <-
mapM
( either (\e -> failWith BadData (renderCompressionError e)) pure
. recursivelyDecompressPacket
)
decryptedPktsRaw
pure (concat decompressed)
validateDecryptedMessageStructure decryptedPktsRaw decryptedPkts
payload <- extractSingleLiteralPayload decryptedPkts
BL.putStr payload
case (decSessionKeyOutFile, sessionKeyOutLine) of
(Just path, Just line) -> writeFileWithOutputExistsCheck "decrypt" path (line ++ "\n")
_ -> pure ()
when doingVerification $
doDecryptVerifyOutput
cpt
decVerifyCerts
verificationOutputPath
decVerifyNotBefore
decVerifyNotAfter
decryptedPkts
when usingDeprecatedVerifyOut $
hPutStrLn
stderr
"Warning: --verify-out is deprecated; use --verifications-out instead."
data DecryptSessionKey
= DecryptSessionKey
{ decryptSessionKeyMaterial :: BL.ByteString
, decryptSessionKeyOutLine :: Maybe String
}
decryptInputCallback
:: IORef [BL.ByteString]
-> IORef [BL.ByteString]
-> String
-> IO BL.ByteString
decryptInputCallback _passwordQueue sessionKeyQueue prompt
| "PKESK session key material" `isInfixOf` prompt = do
mSessionKeyMaterial <-
atomicModifyIORef' sessionKeyQueue $ \keys ->
case keys of
[] -> ([], Nothing)
(k : rest) -> (rest, Just k)
case mSessionKeyMaterial of
Just sessionKeyMaterial -> pure sessionKeyMaterial
Nothing ->
failWith
CannotDecrypt
"decrypt failed: PKESK session key material required but not provided"
decryptInputCallback passwordQueue _ _ = do
mPassword <-
atomicModifyIORef' passwordQueue $ \passwords ->
case passwords of
[] -> ([], Nothing)
(p : rest) -> (rest, Just p)
case mPassword of
Just password -> pure password
Nothing ->
failWith
CannotDecrypt
"decrypt failed: passphrase required but not provided"
parseDecryptSessionKeys :: [String] -> IO [DecryptSessionKey]
parseDecryptSessionKeys = mapM parseSessionKeySpec
parseSessionKeySpec :: String -> IO DecryptSessionKey
parseSessionKeySpec spec =
case break (== ':') spec of
(_, "") -> do
material <- decodeHexBytes spec
pure
DecryptSessionKey
{ decryptSessionKeyMaterial = BL.fromStrict material
, decryptSessionKeyOutLine = sessionKeyOutLineFromMaterial material
}
(algoSpec, ':' : keyHex) -> do
algo <- parseAlgorithmOctet algoSpec
keyBytes <- decodeHexBytes keyHex
when (B.null keyBytes) $
failWith
BadData
"decrypt: --with-session-key key material cannot be empty"
pure
DecryptSessionKey
{ decryptSessionKeyMaterial =
BL.fromStrict (encodeOpenPGPSessionKey algo keyBytes)
, decryptSessionKeyOutLine =
Just (renderSessionKeyOutLine algo keyBytes)
}
_ -> failWith BadData "decrypt: invalid --with-session-key format"
resolveSessionKeyOut
:: Maybe String
-> [DecryptSessionKey]
-> [Pkt]
-> [PKESKRecipientKey]
-> [BL.ByteString]
-> IO (Maybe String)
resolveSessionKeyOut Nothing _ _ _ _ = pure Nothing
resolveSessionKeyOut (Just _) sessionKeys ciphertextPkts recipientKeys passwordCandidates =
case mapMaybe decryptSessionKeyOutLine sessionKeys of
(line : _) -> pure (Just line)
[] -> do
discoveredLine <-
recoverSessionKeyOutFromCiphertext
ciphertextPkts
recipientKeys
passwordCandidates
case discoveredLine of
Just line -> pure (Just line)
Nothing -> pure Nothing
recoverSessionKeyOutFromCiphertext
:: [Pkt]
-> [PKESKRecipientKey]
-> [BL.ByteString]
-> IO (Maybe String)
recoverSessionKeyOutFromCiphertext ciphertextPkts recipientKeys passwordCandidates =
case recoverFromSKESK of
Just line -> pure (Just line)
Nothing -> recoverFromLegacyRSAPKESK
where
recoverFromSKESK =
listToMaybe $
mapMaybe
( \(SKESKPayloadV4 sa s2k maybeEsk, passphrase) ->
case maybeEsk of
Nothing ->
case skesk2Key (SKESK4Packet sa s2k Nothing) passphrase of
Left _ -> Nothing
Right sessionKey ->
Just (renderSessionKeyOutLine (fromFVal sa) sessionKey)
Just esk ->
case skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase of
Left _ -> Nothing
Right (algo, sessionKey) ->
Just (renderSessionKeyOutLine (fromFVal algo) sessionKey)
)
[ (payload, passphrase)
| payload <- skeskPayloadsV4
, passphrase <- passwordCandidates
]
skeskPayloadsV4 =
mapMaybe
( \pkt ->
case pkt of
SKESKPkt (SKESKPayloadV4Packet payload) -> Just payload
_ -> Nothing
)
ciphertextPkts
recoverFromLegacyRSAPKESK =
recoverRSACombos
[(mpi, rsaKey) | mpi <- rsaPKESKMPIs, rsaKey <- rsaRecipientKeys]
recoverRSACombos [] = pure Nothing
recoverRSACombos ((mpi, rsaKey) : rest) = do
encodedResult <- decryptLegacyRSAPKESK rsaKey mpi
case encodedResult of
Left _ -> recoverRSACombos rest
Right encoded ->
case decodeOpenPGPEncodedSessionKey encoded of
Right (algo, keyBytes) ->
pure (Just (renderSessionKeyOutLine (fromFVal algo) keyBytes))
Left _ -> recoverRSACombos rest
rsaPKESKMPIs =
mapMaybe
( \pkt ->
case pkt of
PKESKPkt
(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka (mpi :| [])))
| pka == RSA || pka == DeprecatedRSAEncryptOnly ->
Just mpi
_ -> Nothing
)
ciphertextPkts
rsaRecipientKeys =
mapMaybe
( \keyInfo ->
case pkeskRecipientSKey keyInfo of
RSAPrivateKey (RSA_PrivateKey privateKey) -> Just privateKey
_ -> Nothing
)
recipientKeys
decryptLegacyRSAPKESK
:: RSA.PrivateKey -> MPI -> IO (Either String B.ByteString)
decryptLegacyRSAPKESK privateKey mpi = do
attempted <-
P15.decryptSafer privateKey (mpiToCiphertext privateKey mpi)
pure (first show attempted)
where
mpiToCiphertext rsaKey (MPI encodedMPI) =
let modulusBytes = rsaModulusOctets rsaKey
in i2ospOf_ modulusBytes encodedMPI
rsaModulusOctets rsaKey =
let modulusBits = integerBitLength (RSA.public_n (RSA.private_pub rsaKey))
in max 1 ((modulusBits + 7) `div` 8)
integerBitLength n
| n <= 0 = 0
| otherwise = go n 0
where
go 0 bits = bits
go 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 -> Maybe String -> IO (Maybe String, Bool)
resolveDecryptVerificationsOut newPath oldPath =
case (newPath, oldPath) of
(Just p, Nothing) -> pure (Just p, False)
(Nothing, Just p) -> pure (Just p, True)
(Just pNew, Just pOld)
| pNew == pOld -> pure (Just pNew, True)
| otherwise ->
failWith
IncompatibleOptions
"decrypt: --verifications-out and --verify-out cannot target different files"
(Nothing, Nothing) -> pure (Nothing, False)
renderSOPVerificationLine
:: [TKUnknown] -> Verification -> String
renderSOPVerificationLine verifyTks v =
ts ++ " " ++ signerFp ++ " " ++ certFp ++ " " ++ modeLabel
where
sig = _verificationSignature v
ts = renderSOPVerificationTimestamp sig
signer = fingerprint (_verificationSigner v)
signerFp = hexEncodeBytes (BL.toStrict (unFingerprint signer))
modeLabel = signatureModeField sig
certFp =
case find (\tk -> keyMatchesFingerprint True tk signer) verifyTks of
Just tk ->
hexEncodeBytes
(BL.toStrict (unFingerprint (fingerprint (fst (_tkuKey tk)))))
Nothing -> signerFp
signatureModeField :: SignaturePayload -> String
signatureModeField sig =
case sig of
SigV4 CanonicalTextSig _ _ _ _ _ _ -> "mode:text"
SigV6 CanonicalTextSig _ _ _ _ _ _ _ -> "mode:text"
_ -> "mode:binary"
renderSOPVerificationTimestamp :: SignaturePayload -> String
renderSOPVerificationTimestamp sig =
formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" $
case signatureCreationTime sig of
Just t -> t
Nothing -> posixSecondsToUTCTime 0
writeFileWithOutputExistsCheck
:: String -> FilePath -> String -> IO ()
writeFileWithOutputExistsCheck subcommand path content = do
ensureOutputPathAvailable subcommand path
writeFile path content
parseOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]
parseOpenPGPPackets context bytes =
( do
let packets =
concatMap
(either (const []) id . decompressPkt)
(parsePkts bytes)
_ <- evaluate (length packets)
pure packets
)
`catch` parseFailure
where
parseFailure :: SomeException -> IO [Pkt]
parseFailure err =
failWith
BadData
( context
++ ": failed to parse OpenPGP packets: "
++ displayException err
)
parseRawOpenPGPPackets :: String -> BL.ByteString -> IO [Pkt]
parseRawOpenPGPPackets context bytes =
( do
let packets = parsePkts bytes
_ <- evaluate (length packets)
pure packets
)
`catch` parseFailure
where
parseFailure :: SomeException -> IO [Pkt]
parseFailure err =
failWith
BadData
( context
++ ": failed to parse OpenPGP packets: "
++ displayException err
)
validateDecryptPartialBodyEncoding :: BL.ByteString -> IO ()
validateDecryptPartialBodyEncoding ciphertext =
case ensureNoShortFirstPartialBodyChunk (BL.toStrict ciphertext) of
Left err ->
failWith
BadData
("decrypt input: invalid partial body encoding (" ++ err ++ ")")
Right () -> pure ()
ensureNoShortFirstPartialBodyChunk
:: B.ByteString -> Either String ()
ensureNoShortFirstPartialBodyChunk = parsePackets
where
parsePackets bs
| B.null bs = Right ()
| otherwise = do
(header, rest) <-
noteLeft "truncated packet header" (B.uncons bs)
if header .&. 0x80 /= 0x80
then Left "invalid packet header octet"
else do
remaining <-
if header .&. 0x40 == 0x40
then parseNewPacketBody rest
else parseOldPacketBody (header .&. 0x03) rest
parsePackets remaining
parseOldPacketBody lengthType bs =
case lengthType of
0 -> do
(lenOctet, rest) <-
noteLeft "truncated old-format one-octet length" (B.uncons bs)
dropExact
"truncated old-format packet body"
(fromIntegral lenOctet)
rest
1 -> do
(hi, afterHi) <-
noteLeft "truncated old-format two-octet length" (B.uncons bs)
(lo, rest) <-
noteLeft
"truncated old-format two-octet length"
(B.uncons afterHi)
let len = fromIntegral hi * 256 + fromIntegral lo
dropExact "truncated old-format packet body" len rest
2 -> do
(b1, afterB1) <-
noteLeft "truncated old-format four-octet length" (B.uncons bs)
(b2, afterB2) <-
noteLeft
"truncated old-format four-octet length"
(B.uncons afterB1)
(b3, afterB3) <-
noteLeft
"truncated old-format four-octet length"
(B.uncons afterB2)
(b4, rest) <-
noteLeft
"truncated old-format four-octet length"
(B.uncons afterB3)
let len =
(fromIntegral b1 `shiftL` 24)
+ (fromIntegral b2 `shiftL` 16)
+ (fromIntegral b3 `shiftL` 8)
+ fromIntegral b4
dropExact "truncated old-format packet body" len rest
3 -> Right B.empty
_ -> Left "invalid old-format length type"
parseNewPacketBody = parseNewLengthChunks True
parseNewLengthChunks isFirstChunk bs = do
(chunkLength, isPartial, afterLength) <- parseNewLength bs
when (isFirstChunk && isPartial && chunkLength < 512) $
Left
( "first partial chunk is too short ("
++ show chunkLength
++ " octets, minimum is 512)"
)
afterChunk <-
dropExact
"truncated new-format packet body chunk"
chunkLength
afterLength
if isPartial
then parseNewLengthChunks False afterChunk
else Right afterChunk
parseNewLength bs = do
(lengthOctet, rest) <-
noteLeft "truncated new-format length" (B.uncons bs)
case lengthOctet of
_
| lengthOctet < 192 ->
Right (fromIntegral lengthOctet, False, rest)
| lengthOctet < 224 -> do
(nextOctet, afterNext) <-
noteLeft "truncated new-format two-octet length" (B.uncons rest)
let len =
((fromIntegral lengthOctet - 192) `shiftL` 8)
+ fromIntegral nextOctet
+ 192
Right (len, False, afterNext)
| lengthOctet < 255 ->
Right
( 1 `shiftL` fromIntegral (lengthOctet .&. 0x1f)
, True
, rest
)
| otherwise -> do
(b1, afterB1) <-
noteLeft "truncated new-format five-octet length" (B.uncons rest)
(b2, afterB2) <-
noteLeft
"truncated new-format five-octet length"
(B.uncons afterB1)
(b3, afterB3) <-
noteLeft
"truncated new-format five-octet length"
(B.uncons afterB2)
(b4, afterB4) <-
noteLeft
"truncated new-format five-octet length"
(B.uncons afterB3)
let len =
(fromIntegral b1 `shiftL` 24)
+ (fromIntegral b2 `shiftL` 16)
+ (fromIntegral b3 `shiftL` 8)
+ fromIntegral b4
Right (len, False, afterB4)
dropExact context n bs
| B.length bs < n = Left context
| otherwise = Right (B.drop n bs)
noteLeft err = maybe (Left err) Right
ensureOutputPathAvailable :: String -> FilePath -> IO ()
ensureOutputPathAvailable subcommand path = do
exists <- doesFileExist path
when exists $
failWith
OutputExists
(subcommand ++ ": output path already exists: " ++ path)
loadVerifyContext
:: POSIXTime -> [String] -> IO (PublicKeyring, [TKUnknown])
loadVerifyContext _ certFiles = do
allTks <-
mapMaybe enforceVerifyPrimaryKeyPolicy
. map sanitizeVerifyTK
. concat
<$> mapM (loadCertTKsFromFile "verify") certFiles
let publicTks =
mapMaybe
( \tk ->
case fromUnknownToTK tk of
Right (SomePublicTK publicTk) -> Just publicTk
_ -> Nothing
)
allTks
keyring <-
runConduitRes $ CL.sourceList publicTks .| sinkPublicKeyringMap
pure (keyring, allTks)
loadVerifyTKsFromFile :: String -> IO [TKUnknown]
loadVerifyTKsFromFile path = do
lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
certPkts <- decodeOpenPGPInput path lbs
runConduitRes $
CL.sourceList certPkts
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
loadCertTKsFromFile :: String -> String -> IO [TKUnknown]
loadCertTKsFromFile context path = do
lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
certPkts <- decodeOpenPGPInput path lbs
rejectSecretKeyPackets context path certPkts
runConduitRes $
CL.sourceList certPkts
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
rejectSecretKeyPackets :: String -> String -> [Pkt] -> IO ()
rejectSecretKeyPackets context path packets =
when (any isSecretKeyPacket packets) $
failWith
BadData
( context
++ ": certificate input contains secret key material in "
++ path
)
where
isSecretKeyPacket SecretKeyPkt {} = True
isSecretKeyPacket SecretSubkeyPkt {} = True
isSecretKeyPacket _ = False
sanitizeVerifyTK :: TKUnknown -> TKUnknown
sanitizeVerifyTK tk =
case primaryKeyIdentity (_tkuKey tk) of
Nothing -> tk
Just (primaryFp, primaryKeyId) ->
tk
{ _tkuSubs =
map
( \(pkt, sigs) ->
let sanitized =
mapMaybe (sanitizeBindingSignature primaryFp primaryKeyId) sigs
in if isSubkeyPacket pkt
then (pkt, sanitized)
else (pkt, sigs)
)
(_tkuSubs tk)
}
where
isSubkeyPacket PublicSubkeyPkt {} = True
isSubkeyPacket SecretSubkeyPkt {} = True
isSubkeyPacket _ = False
enforceVerifyPrimaryKeyPolicy :: TKUnknown -> Maybe TKUnknown
enforceVerifyPrimaryKeyPolicy tk =
if primaryKeyTooSmallForVerification (_tkuKey tk)
then Nothing
else Just tk
primaryKeyTooSmallForVerification
:: (SomePKPayload, Maybe SKAddendum) -> Bool
primaryKeyTooSmallForVerification (pkp, _) =
case _pkalgo pkp of
RSA -> rsaTooSmall
DeprecatedRSASignOnly -> rsaTooSmall
DeprecatedRSAEncryptOnly -> rsaTooSmall
_ -> False
where
rsaTooSmall =
case pubkeySize (_pubkey pkp) of
Right bits -> bits < 2048
Left _ -> False
primaryKeyIdentity
:: (SomePKPayload, Maybe SKAddendum)
-> Maybe (Fingerprint, EightOctetKeyId)
primaryKeyIdentity (pkp, _) = do
keyId <- either (const Nothing) Just (eightOctetKeyID pkp)
pure (fingerprint pkp, keyId)
sanitizeBindingSignature
:: Fingerprint
-> EightOctetKeyId
-> SignaturePayload
-> Maybe SignaturePayload
sanitizeBindingSignature _ _ sig
| hasUnsupportedCriticalSubpacket sig = Nothing
| hasUnsupportedCriticalEmbeddedBacksig sig = Nothing
| otherwise = Just sig
where
hasUnsupportedCriticalSubpacket sp =
any isUnsupportedCriticalSubpacket (signatureHashedSubpackets sp)
hasUnsupportedCriticalEmbeddedBacksig sp =
any
( \ssp ->
case _sspPayload ssp of
EmbeddedSignature embedded ->
any
isUnsupportedCriticalSubpacket
(signatureHashedSubpackets embedded)
_ -> False
)
(signatureHashedSubpackets sp)
isUnsupportedCriticalSubpacket (SigSubPacket isCritical payload) =
isCritical
&& case payload of
UserDefinedSigSub {} -> True
OtherSigSub {} -> True
NotationData {} -> True
_ -> False
loadDecryptRecipientKeys
:: POSIXTime
-> [String]
-> [BL.ByteString]
-> IO [PKESKRecipientKey]
loadDecryptRecipientKeys _ [] _ = pure []
loadDecryptRecipientKeys cpt keyFiles passwords = concat <$> mapM loadFromFile keyFiles
where
loadFromFile path = do
lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
packets <- decodeOpenPGPInput path lbs
-- Build the set of fingerprints that are explicitly non-encryption-capable.
-- Keys not resolvable via TK (processTK failure, bare material) are allowed.
nonEncFps <- buildNonEncryptionFingerprintSet packets
keys <-
mapM (packetRecipientKey path nonEncFps) packets
>>= pure . catMaybes
let brokenSecretKeyErrors =
nub
[ err
| BrokenPacketPkt err tag _ <- packets
, tag == 5 || tag == 7
]
when (null keys && not (null brokenSecretKeyErrors)) $
failWith
CannotDecrypt
( "decrypt failed: could not load usable secret key material from "
++ path
++ " ("
++ intercalate "; " brokenSecretKeyErrors
++ ")"
)
pure keys
-- Build a set of fingerprints that are EXPLICITLY non-encryption-capable.
-- Only keys whose binding signature carries a KeyFlags subpacket that does
-- NOT include any encryption bit are added. Keys with no binding-sig TK
-- (processTK failed, bare secret material, etc.) are NOT blocked — we fall
-- back to allowing them so that newly-generated or unusual keys still work.
buildNonEncryptionFingerprintSet packets = do
tks <-
runConduitRes $
CL.sourceList packets
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
let normTks = rights (map (processTK (Just cpt)) tks)
let tkDerived = S.fromList (concatMap nonEncryptionFingerprints normTks)
rawDerived = S.fromList (explicitNonEncryptionSubkeyFingerprints packets)
return (S.union tkDerived rawDerived)
nonEncryptionFingerprints tk =
-- Primary key: add to blocklist only if explicit key-flags are present
-- and all of them exclude encryption usage.
let (primaryPkp, _) = _tkuKey tk
primaryFp = unFingerprint (fingerprint primaryPkp)
primarySigs =
concatMap snd (_tkuUIDs tk)
++ concatMap snd (_tkuUAts tk)
++ _tkuRevs tk
primaryEntry = [primaryFp | not (sigsAllowEncryption primarySigs)]
-- Subkeys: same rule as primary.
subEntries =
[ unFingerprint (fingerprint pkp)
| (pkt, sigs) <- _tkuSubs tk
, Just pkp <- [secretOrPublicSubkeyPayload pkt]
, not (sigsAllowEncryption sigs)
]
blocked = primaryEntry ++ subEntries
in if tkHasAnyEncryptionCapableKey tk
then blocked
else []
explicitNonEncryptionSubkeyFingerprints packets =
let (mPending, blocked) = foldl' step (Nothing, []) packets
in maybe
blocked
( \(fp, hasEnc, sawKeyFlags) -> finalize fp hasEnc sawKeyFlags blocked
)
mPending
where
step (mPending, blocked) pkt =
case pkt of
PublicSubkeyPkt pkp ->
( Just (unFingerprint (fingerprint pkp), False, False)
, finalizePending mPending blocked
)
SecretSubkeyPkt pkp _ ->
( Just (unFingerprint (fingerprint pkp), False, False)
, finalizePending mPending blocked
)
SignaturePkt sig ->
case mPending of
Nothing -> (Nothing, blocked)
Just (fp, hasEnc, sawKeyFlags) ->
let usableSig =
if signatureHasUnsupportedCriticalSubpackets sig
then []
else keyFlagsFromSig sig
hasEnc' = hasEnc || any hasEncryptionFlag usableSig
sawKeyFlags' = sawKeyFlags || not (null usableSig)
in (Just (fp, hasEnc', sawKeyFlags'), blocked)
_ -> (Nothing, finalizePending mPending blocked)
finalizePending Nothing blocked = blocked
finalizePending (Just (fp, hasEnc, sawKeyFlags)) blocked =
finalize fp hasEnc sawKeyFlags blocked
finalize fp hasEnc sawKeyFlags blocked
| sawKeyFlags && not hasEnc = fp : blocked
| otherwise = blocked
tkHasAnyEncryptionCapableKey tk =
let (primaryPkp, _) = _tkuKey tk
primarySigs =
concatMap snd (_tkuUIDs tk)
++ concatMap snd (_tkuUAts tk)
++ _tkuRevs tk
primaryAllows =
supportsRecipientPKESKAlgorithm primaryPkp
&& sigsAllowEncryption primarySigs
subAllows =
any
( \(pkt, sigs) ->
case secretOrPublicSubkeyPayload pkt of
Just pkp ->
supportsRecipientPKESKAlgorithm pkp && sigsAllowEncryption sigs
Nothing -> False
)
(_tkuSubs tk)
in primaryAllows || subAllows
sigsAllowEncryption [] = True
sigsAllowEncryption sigs =
let usableSigs = filter (not . signatureHasUnsupportedCriticalSubpackets) sigs
flagSets = concatMap keyFlagsFromSig usableSigs
in if null usableSigs
then False
else null flagSets || any hasEncryptionFlag flagSets
hasEncryptionFlag flags =
S.member EncryptCommunicationsKey flags
|| S.member EncryptStorageKey flags
keyFlagsFromSig sig =
case sig of
SigV4 _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds
SigV6 _ _ _ _ hasheds _ _ _ -> keyFlagsFromSubpackets hasheds
_ -> []
signatureHasUnsupportedCriticalSubpackets sig =
let hasheds =
case sig of
SigV4 _ _ _ hs _ _ _ -> hs
SigV6 _ _ _ _ hs _ _ _ -> hs
_ -> []
in any isUnsupportedCritical hasheds
isUnsupportedCritical (SigSubPacket isCritical payload) =
isCritical
&& case payload of
OtherSigSub {} -> True
UserDefinedSigSub {} -> True
NotationData {} -> True
_ -> False
keyFlagsFromSubpackets subpackets =
[ flags
| SigSubPacket _ (KeyFlags flags) <- subpackets
]
secretOrPublicSubkeyPayload (SecretSubkeyPkt pkp _) = Just pkp
secretOrPublicSubkeyPayload (PublicSubkeyPkt pkp) = Just pkp
secretOrPublicSubkeyPayload _ = Nothing
packetRecipientKey path nonEncFps (SecretKeyPkt pkp ska) =
let fp = unFingerprint (fingerprint pkp)
in if S.member fp nonEncFps
then pure Nothing
else decryptRecipientKey path pkp ska
packetRecipientKey path nonEncFps (SecretSubkeyPkt pkp ska) =
let fp = unFingerprint (fingerprint pkp)
in if S.member fp nonEncFps
then pure Nothing
else decryptRecipientKey path pkp ska
packetRecipientKey _ _ _ = pure Nothing
decryptRecipientKey path pkp ska =
case secretKeyProtectionPolicyViolation pkp ska of
Just violation ->
failWith
KeyIsProtected
( "decrypt failed: unsupported secret key protection in "
++ path
++ " ("
++ violation
++ ")"
)
Nothing ->
case ska of
SUUnencrypted skey _ ->
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just pkp
, pkeskRecipientSKey = skey
}
)
)
_ ->
case passwords of
[] ->
failWith
KeyIsProtected
( "decrypt failed: encrypted key in "
++ path
++ " requires --with-key-password"
)
_ ->
case tryDecryptKey passwords of
Left _ ->
failWith
KeyIsProtected
( "decrypt failed: could not decrypt key in "
++ path
++ " with provided --with-key-password values"
)
Right (SUUnencrypted skey _) ->
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just pkp
, pkeskRecipientSKey = skey
}
)
)
Right _ ->
failWith
KeyIsProtected
("decrypt failed: unsupported secret key protection in " ++ path)
where
secretKeyProtectionPolicyViolation recipientPkp addendum =
let rejectArgon2WithoutAEAD s2k
| isArgon2S2K s2k =
Just "Argon2 S2K is only allowed with AEAD-protected secret keys"
| otherwise = Nothing
rejectSimpleForV6 s2k
| isSimpleS2K s2k =
Just "v6 secret key packets MUST NOT use simple S2K"
| otherwise = Nothing
in case addendum of
SUS16bit _ s2k _ _ ->
case _keyVersion recipientPkp of
V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k
_ -> rejectArgon2WithoutAEAD s2k
SUSSHA1 _ s2k _ _ ->
case _keyVersion recipientPkp of
V6 -> rejectArgon2WithoutAEAD s2k <|> rejectSimpleForV6 s2k
_ -> rejectArgon2WithoutAEAD s2k
SUSym {} ->
if _keyVersion recipientPkp == V6
then
Just
"v6 secret key packets MUST NOT use legacy CFB secret-key protection"
else Nothing
_ -> Nothing
isArgon2S2K Argon2 {} = True
isArgon2S2K _ = False
isSimpleS2K (Simple _) = True
isSimpleS2K _ = False
tryDecryptKey [] = Left ()
tryDecryptKey (password : rest) =
case decryptPrivateKey (pkp, ska) password of
Left _ -> tryDecryptKey rest
Right decrypted -> Right decrypted
decodeOpenPGPInput :: String -> BL.ByteString -> IO [Pkt]
decodeOpenPGPInput path input = do
decodedArmors <-
decodeAsciiArmorInput ("OpenPGP input in " ++ path) input
case decodedArmors of
Just armors ->
case firstBy isOpenPGPArmorBlock armors of
Just (Armor _ _ bs) ->
parseOpenPGPPackets
("armored OpenPGP input in " ++ path)
(BL.fromStrict (BLC8.toStrict bs))
_ ->
case firstBy isClearSignedArmor armors of
Just _ ->
failWith
BadData
("Expected key data in " ++ path ++ ", got cleartext signature")
_ -> parseOpenPGPPackets "OpenPGP input" input
Nothing -> parseOpenPGPPackets "OpenPGP input" input
loadRecipientPreferredHashes
:: POSIXTime -> [String] -> IO [HashAlgorithm]
loadRecipientPreferredHashes cpt certFiles =
concat <$> mapM loadFromFile certFiles
where
loadFromFile path = do
lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
pkts <- decodeOpenPGPInput path lbs
rejectSecretKeyPackets "encrypt" path pkts
tks <-
runConduitRes $
CL.sourceList pkts
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
normalized <- mapM (normalizeRecipient path) tks
pure
(concatMap (effectiveHashPreferencesAt cpt) normalized)
normalizeRecipient path tk =
case processTK (Just cpt) tk of
Left err ->
failWith
BadData
( "encrypt: invalid recipient certificate in "
++ path
++ ": "
++ show err
)
Right normalized -> pure normalized
loadEncryptRecipients
:: POSIXTime -> EncryptFor -> [String] -> IO [FunKey]
loadEncryptRecipients cpt encPurpose certFiles = do
recipients <- concat <$> mapM loadRecipientsFromFile certFiles
if null recipients
then
failWith
CertCannotEncrypt
"encrypt: no supported recipient encryption keys found in provided certificates"
else pure recipients
where
loadRecipientsFromFile path = do
lbs <- runConduitRes $ CB.sourceFile path .| CC.sinkLazy
pkts <- decodeOpenPGPInput path lbs
rejectSecretKeyPackets "encrypt" path pkts
rejectCriticalUnknownRecipientPackets path pkts
tks <-
runConduitRes $
CL.sourceList pkts
.| conduitToTKsDroppingEither
.| CL.mapFoldable (join . hush)
.| CC.sinkList
normalized <- mapM (normalizeEncryptRecipientTK path) tks
let selected =
selectEncryptRecipients
encPurpose
(concatMap (tkToFunKeysAt cpt) normalized)
packetFallback =
nub
( concatMap tkToEncryptPayloads normalized
++ mapMaybe extractEncryptRecipientPayload pkts
)
pure $
case encPurpose of
EncryptForAny
| null selected -> map payloadToFunKey packetFallback
_ -> selected
normalizeEncryptRecipientTK path tk =
case processTK (Just cpt) tk of
Left err ->
failWith
BadData
( "encrypt: invalid recipient certificate in "
++ path
++ ": "
++ show err
)
Right normalized ->
if not
(isTKTimeValid (posixSecondsToUTCTime (realToFrac cpt)) normalized)
then
failWith
CertCannotEncrypt
("encrypt: recipient certificate in " ++ path ++ " is expired")
else
if not (primaryUserIDExpirationAllowsAt cpt normalized)
then
failWith
CertCannotEncrypt
("encrypt: recipient certificate in " ++ path ++ " is expired")
else pure normalized
rejectCriticalUnknownRecipientPackets path =
mapM_
( \pkt ->
case pkt of
OtherPacketPkt tag _
| tag < 40 ->
if isForwardCompatRecipientPacketTag tag
then pure ()
else
failWith
BadData
( "encrypt: invalid recipient certificate in "
++ path
++ ": critical unknown packet tag "
++ show tag
)
BrokenPacketPkt _ tag _
| tag < 40 ->
if isForwardCompatRecipientPacketTag tag
then pure ()
else
failWith
BadData
( "encrypt: invalid recipient certificate in "
++ path
++ ": critical unknown packet tag "
++ show tag
)
_ -> pure ()
)
isForwardCompatRecipientPacketTag tag = tag `elem` [5, 6, 7, 14]
payloadToFunKey pkp = FunKey pkp Nothing S.empty [] [] False
primaryUserIDExpirationAllowsAt :: POSIXTime -> TKUnknown -> Bool
primaryUserIDExpirationAllowsAt now tk =
case primaryUidSigs of
[] -> True
_ ->
any
(signatureKeyExpirationAllowsAt now primaryCreatedAt)
primaryUidSigs
where
primaryCreatedAt = fromIntegral (_timestamp (fst (_tkuKey tk)))
primaryUidSigs =
[ sig
| (_, sigs) <- _tkuUIDs tk
, sig <- sigs
, signatureMarksPrimaryUserId sig
]
signatureMarksPrimaryUserId :: SignaturePayload -> Bool
signatureMarksPrimaryUserId sig =
any isPrimaryUIDSubpacket (signatureSubpackets sig)
where
isPrimaryUIDSubpacket (SigSubPacket _ (PrimaryUserId True)) = True
isPrimaryUIDSubpacket _ = False
signatureKeyExpirationAllowsAt
:: POSIXTime -> POSIXTime -> SignaturePayload -> Bool
signatureKeyExpirationAllowsAt now createdAt sig =
case signatureKeyValiditySeconds sig of
Nothing -> True
Just 0 -> True
Just validitySeconds -> now < createdAt + fromIntegral validitySeconds
signatureKeyValiditySeconds :: SignaturePayload -> Maybe Integer
signatureKeyValiditySeconds sig =
listToMaybe
[ fromIntegral secs
| SigSubPacket _ (KeyExpirationTime (ThirtyTwoBitDuration secs)) <-
signatureSubpackets sig
]
selectEncryptRecipients :: EncryptFor -> [FunKey] -> [FunKey]
selectEncryptRecipients encPurpose keys =
chosen
where
supported = filter (supportsRecipientPKESKAlgorithm . fpkp) keys
(matchingPurpose, unrestrictedPurpose) =
partition (keyMatchesEncryptPurpose encPurpose . fkufs) supported
chosen =
case encPurpose of
EncryptForAny
| null matchingPurpose -> unrestrictedPurpose
_ -> matchingPurpose
tkToEncryptPayloads :: TKUnknown -> [SomePKPayload]
tkToEncryptPayloads (TKUnknown (pkp, _) _ _ _ subs) =
filter
supportsRecipientPKESKAlgorithm
(pkp : mapMaybe extractSubkeyPayload subs)
where
extractSubkeyPayload (PublicSubkeyPkt subPkp, _) = Just subPkp
extractSubkeyPayload (SecretSubkeyPkt subPkp _, _) = Just subPkp
extractSubkeyPayload _ = Nothing
extractEncryptRecipientPayload :: Pkt -> Maybe SomePKPayload
extractEncryptRecipientPayload pkt =
case pkt of
PublicKeyPkt pkp
| supportsRecipientPKESKAlgorithm pkp -> Just pkp
PublicSubkeyPkt pkp
| supportsRecipientPKESKAlgorithm pkp -> Just pkp
SecretKeyPkt pkp _
| supportsRecipientPKESKAlgorithm pkp -> Just pkp
SecretSubkeyPkt pkp _
| supportsRecipientPKESKAlgorithm pkp -> Just pkp
_ -> Nothing
keyMatchesEncryptPurpose :: EncryptFor -> S.Set KeyFlag -> Bool
keyMatchesEncryptPurpose encPurpose keyFlags =
not (S.null (keyFlags `S.intersection` encryptUsageFlags))
where
encryptUsageFlags =
case encPurpose of
EncryptForAny -> S.fromList [EncryptStorageKey, EncryptCommunicationsKey]
EncryptForStorage -> S.singleton EncryptStorageKey
EncryptForCommunications -> S.singleton EncryptCommunicationsKey
supportsRecipientPKESKAlgorithm :: SomePKPayload -> Bool
supportsRecipientPKESKAlgorithm pkp =
_pkalgo pkp
`elem` [ RSA
, DeprecatedRSAEncryptOnly
, ElgamalEncryptOnly
, ECDH
, X25519
, X448
]
&& hasSupportedRecipientIdentifierLength pkp
hasSupportedRecipientIdentifierLength :: SomePKPayload -> Bool
hasSupportedRecipientIdentifierLength pkp =
let keyIdentifierLen = BL.length (unFingerprint (fingerprint pkp))
in keyIdentifierLen == 16
|| keyIdentifierLen == 20
|| keyIdentifierLen == 32
renderPKESKEncryptError :: PKESKEncryptError -> String
renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm symAlgo err) =
"unsupported session-key algorithm "
++ show symAlgo
++ ": "
++ err
renderPKESKEncryptError (InvalidSessionKeyLength symAlgo expected got) =
"invalid session-key length for "
++ show symAlgo
++ " (expected "
++ show expected
++ ", got "
++ show got
++ ")"
renderPKESKEncryptError (UnsupportedRecipientAlgorithm pka) =
"unsupported recipient public-key algorithm: " ++ show pka
renderPKESKEncryptError (InvalidRecipientKeyMaterial pka err) =
"invalid recipient key material for " ++ show pka ++ ": " ++ err
renderPKESKEncryptError (RecipientKdfFailure pka err) =
"recipient KDF failure for " ++ show pka ++ ": " ++ err
renderPKESKEncryptError (RecipientKeyWrapFailure pka err) =
"recipient key-wrap failure for " ++ show pka ++ ": " ++ err
renderPKESKEncryptError (PayloadBuildFailure err) = "payload build failure: " ++ err
renderPKESKEncryptError NoRecipientsProvided = "no recipients were provided"
renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) =
"recipient capability selection failure: " ++ show err
renderPKESKEncryptError (InvalidRecipientIdentifier err) =
"invalid recipient identifier: " ++ err
sopFailureForPKESKEncryptError :: PKESKEncryptError -> SopFailure
sopFailureForPKESKEncryptError err =
case err of
UnsupportedRecipientAlgorithm _ -> UnsupportedAsymmetricAlgo
RecipientCapabilitySelectionFailure _ -> CertCannotEncrypt
NoRecipientsProvided -> CertCannotEncrypt
_ -> BadData
{- | Resolve a PKESK recipient key using two strategies depending on whether
the probe carries a wildcard recipient ID (eight zero bytes) or a real key
ID / fingerprint.
* Non-wildcard probes: the callback is invoked once for each PKESK attempt,
so we do an idempotent lookup by recipient identifier from the full
candidate list to avoid consuming keys needed by later PKESKs.
* Wildcard probes (all-zero legacy recipient ID): hOpenPGP retries the
callback after failed unwrap attempts. We therefore pop one candidate from
a shared queue on each callback invocation.
-}
selectRecipientKeyInfosByRecipientIdentifier
:: [PKESKRecipientKey]
-> KeyIdentifier
-> PubKeyAlgorithm
-> IO [PKESKRecipientKey]
selectRecipientKeyInfosByRecipientIdentifier keyInfos keyIdentifier pka =
pure $
case keyIdentifier of
KeyIdentifierWildcard -> compatible
KeyIdentifierEightOctet recipientKeyId ->
filter (matchesLegacyRecipientKeyId recipientKeyId) compatible
KeyIdentifierFingerprint recipientFingerprint ->
filter
(matchesRecipientIdentifier (unFingerprint recipientFingerprint))
compatible
where
compatible =
[ keyInfo
| keyInfo <- keyInfos
, supportsPKESKAlgorithm pka keyInfo
]
prioritizeDecryptablePKESKs
:: [PKESKRecipientKey] -> [Pkt] -> [Pkt]
prioritizeDecryptablePKESKs keyInfos pkts =
nonMatchingPrefix ++ matchingPrefix ++ suffix
where
(prefix, suffix) = break isEncryptedPayloadPacket pkts
(matchingPrefix, nonMatchingPrefix) =
partition
( \pkt ->
case pkt of
PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)) ->
any (matchesRecipientIdentifier rid) keyInfos
PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ eoki _ _)) ->
any (matchesLegacyRecipientKeyId eoki) keyInfos
_ -> False
)
prefix
supportsPKESKAlgorithm
:: PubKeyAlgorithm -> PKESKRecipientKey -> Bool
supportsPKESKAlgorithm pka keyInfo =
case pkeskRecipientSKey keyInfo of
RSAPrivateKey {} -> pka == RSA || pka == DeprecatedRSAEncryptOnly
ElGamalPrivateKey {} -> pka == ElgamalEncryptOnly
ECDHPrivateKey {} -> pka == ECDH || pka == X25519
X25519PrivateKey {} -> pka == X25519
X448PrivateKey {} -> pka == X448
UnknownSKey {} ->
(pka == X25519 || pka == X448)
&& case pkeskRecipientPKPayload keyInfo of
Just pkp -> _pkalgo pkp == pka
Nothing -> False
_ -> False
matchesRecipientIdentifier
:: BL.ByteString -> PKESKRecipientKey -> Bool
matchesRecipientIdentifier rid keyInfo =
case pkeskRecipientPKPayload keyInfo of
Nothing -> False
Just pkp ->
let identifier = BL.toStrict rid
fps = recipientFingerprintsForMatch pkp
in any (identifier `elem`) (map recipientIdMatchVariants fps)
recipientFingerprintsForMatch :: SomePKPayload -> [B.ByteString]
recipientFingerprintsForMatch pkp =
baseFp : maybeToList normalizedX25519Fp
where
baseFp = BL.toStrict (unFingerprint (fingerprint pkp))
normalizedX25519Fp =
BL.toStrict . unFingerprint . fingerprint
<$> normalizeX25519CompatiblePKP pkp
normalizeX25519CompatiblePKP
:: SomePKPayload -> Maybe SomePKPayload
normalizeX25519CompatiblePKP pkp =
case _pubkey pkp of
ECDHPubKey (EdDSAPubKey Ed25519 _) _ _ ->
Just
( PKPayload
(_keyVersion pkp)
(_timestamp pkp)
(_v3exp pkp)
X25519
(_pubkey pkp)
)
_ -> Nothing
recipientIdMatchVariants :: B.ByteString -> [B.ByteString]
recipientIdMatchVariants fp =
[ fp
, B.cons 0x04 fp
, B.cons 0x06 fp
, B.cons 0xFE fp
]
matchesLegacyRecipientKeyId
:: EightOctetKeyId -> PKESKRecipientKey -> Bool
matchesLegacyRecipientKeyId eoki keyInfo =
case pkeskRecipientPKPayload keyInfo of
Nothing -> False
Just pkp ->
case eightOctetKeyID pkp of
Right keyId -> keyId == eoki
Left _ -> False
decodeCiphertextInput :: BL.ByteString -> IO BL.ByteString
decodeCiphertextInput input = do
decodedArmors <- decodeAsciiArmorInput "decrypt input" input
case decodedArmors of
Just armors ->
case firstBy isArmorMessageBlock armors of
Just (Armor ArmorMessage _ bs) -> return (BL.fromStrict (BLC8.toStrict bs))
_ ->
case firstBy isOpenPGPArmorBlock armors of
Just _ ->
failWith
BadData
"decrypt expects an armored OpenPGP message"
_ -> return input
Nothing -> return input
doInlineSign :: POSIXTime -> InlineSignOptions -> IO ()
doInlineSign pt InlineSignOptions {..} = do
when (inlineSignNoArmor && inlineSignArmor) $
failWith
IncompatibleOptions
"inline-sign: --armor and --no-armor are mutually exclusive"
forM_
inlineSignProfile
( \profile ->
failWith
UnsupportedOption
("inline-sign: unsupported option --profile=" ++ profile)
)
let inlineMode = fromMaybe InlineSignAsBinary inlineSignAs
mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
when (inlineMode /= InlineSignAsBinary) $
ensureUTF8TextInput "inline-sign" (BL.fromChunks mbs)
signingPasswordsRaw <-
loadPasswordFiles
"inline-sign"
"--with-key-password"
inlineSignKeyPasswords
let signingPasswords = concatMap passwordRetryCandidates signingPasswordsRaw
ks <- loadSigningKeys inlineSignKeyFiles signingPasswords
processedKeys <- mapM (normalizeSigningKey pt) ks
let ts = ThirtyTwoBitTimeStamp (floor pt)
payloadRaw = BL.fromChunks mbs
funkeys = concatMap (tkToFunKeysAt pt) processedKeys
signingKeys = filter isInlineRSASigner funkeys
inlineSignHash =
selectSigningHash signingKeys [] legacySigningHashFallbackOrder
when (null signingKeys) $
failWith MissingInput "inline-sign: no signing-capable key found"
sigs <-
mapM
( signInlineData
ts
(inlineSignSignatureMode inlineMode)
inlineSignHash
payloadRaw
)
signingKeys
case inlineMode of
InlineSignAsClearSigned -> doInlineSignCleartext inlineSignHash payloadRaw sigs
InlineSignAsText -> doInlineSignText payloadRaw sigs
InlineSignAsBinary -> doInlineSignBinary payloadRaw sigs
where
inlineSignSignatureMode mode =
case mode of
InlineSignAsBinary -> AsBinary
InlineSignAsText -> AsText
InlineSignAsClearSigned -> AsText
doInlineSignCleartext inlineSignHash payloadRaw sigs = do
when inlineSignNoArmor $
failWith
IncompatibleOptions
"inline-sign --as=clearsigned requires armored output"
let cleartextPayload =
if not (BL.null payloadRaw) && BL.last payloadRaw == 0x0a
then payloadRaw <> BL.singleton 0x0a
else payloadRaw
sigBytes = runPut $ mapM_ (Bin.put . SignaturePkt) sigs
hashHeader = ("Hash", hashAlgorithmHeaderName inlineSignHash)
clearSigned =
ClearSigned
[hashHeader]
(BLC8.fromStrict (BL.toStrict cleartextPayload))
(Armor ArmorSignature [] (BLC8.fromStrict (BL.toStrict sigBytes)))
BLC8.putStr (AA.encodeLazy [clearSigned])
doInlineSignText payloadRaw sigs =
doInlineSignMessage UTF8Data payloadRaw sigs
doInlineSignBinary payloadRaw sigs = do
doInlineSignMessage BinaryData payloadRaw sigs
doInlineSignMessage literalDataType payloadRaw sigs = do
let pktBytes =
runPut $
Bin.put
( Block
( map SignaturePkt sigs
++ [LiteralDataPkt literalDataType BL.empty 0 payloadRaw]
)
)
BL.putStr $
if not inlineSignNoArmor && not inlineSignArmor
then AA.encodeLazy [Armor ArmorMessage [] pktBytes]
else
if inlineSignArmor
then AA.encodeLazy [Armor ArmorMessage [] pktBytes]
else pktBytes
inlineSignModeReader :: String -> Either String InlineSignMode
inlineSignModeReader "binary" = Right InlineSignAsBinary
inlineSignModeReader "text" = Right InlineSignAsText
inlineSignModeReader "clearsigned" = Right InlineSignAsClearSigned
inlineSignModeReader _ =
Left "signature mode must be one of: binary, text, clearsigned"
isInlineSigningCapable :: FunKey -> Bool
isInlineSigningCapable k =
(S.null (fkufs k) || S.member SignDataKey (fkufs k))
&& case fmska k of
Just (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey _)) _) -> True
Just (SUUnencrypted (EdDSAPrivateKey _ _) _) -> True
Just (SUUnencrypted (UnknownSKey _) _) ->
isEd25519PKA (_pkalgo (fpkp k))
|| isEdDSAPKA (_pkalgo (fpkp k))
|| isEd448PKA (_pkalgo (fpkp k))
_ -> False
-- Legacy alias.
isInlineRSASigner :: FunKey -> Bool
isInlineRSASigner = isInlineSigningCapable
signInlineData
:: ThirtyTwoBitTimeStamp
-> AsBinaryText
-> HashAlgorithm
-> BL.ByteString
-> FunKey
-> IO SignaturePayload
signInlineData ts mode signHash payload k =
do
issuerPackets <- inlineUnhashed (fpkp k)
signWithKey
"inline-sign"
(fpkp k)
sigType
signHash
(inlineHashed (fpkp k) ts)
issuerPackets
payload
(fmska k)
where
sigType =
case mode of
AsBinary -> BinarySig
AsText -> CanonicalTextSig
inlineHashed
:: SomePKPayload -> ThirtyTwoBitTimeStamp -> [SigSubPacket]
inlineHashed pkp ts =
[ SigSubPacket False (SigCreationTime ts)
, SigSubPacket
False
( IssuerFingerprint
(issuerFingerprintVersionFor pkp)
(fingerprint pkp)
)
]
inlineUnhashed :: SomePKPayload -> IO [SigSubPacket]
inlineUnhashed pkp =
issuerSubpacketsFor "inline-sign" pkp
doInlineDetach :: POSIXTime -> InlineDetachOptions -> IO ()
doInlineDetach _ InlineDetachOptions {..} = do
ensureOutputPathAvailable "inline-detach" inlineDetachOutputSigs
input <- runConduitRes $ CB.sourceHandle stdin .| CC.sinkLazy
(msgData, sigPkts) <- splitInlineSigned input
writeDetachedSignatures
inlineDetachNoArmor
inlineDetachOutputSigs
sigPkts
BL.putStr msgData
splitInlineSigned :: BL.ByteString -> IO (BL.ByteString, [Pkt])
splitInlineSigned lbs = do
decodedArmors <- decodeAsciiArmorInput "inline-detach input" lbs
case decodedArmors of
Just armors ->
case firstBy isInlineSignedArmorCandidate armors of
Just (Armor ArmorMessage _ bs) ->
parseOpenPGPPackets
"inline-detach armored message"
(BL.fromStrict (BLC8.toStrict bs))
>>= splitInlineSignedPackets
Just (ClearSigned headers cleartext signatureArmor) -> do
validateClearSignedHeaders headers
sigPkts <- clearSignedSignaturePackets signatureArmor
return (BL.fromStrict (BLC8.toStrict cleartext), sigPkts)
_ ->
parseOpenPGPPackets "inline-detach input" lbs
>>= splitInlineSignedPackets
Nothing ->
parseOpenPGPPackets "inline-detach input" lbs
>>= splitInlineSignedPackets
firstBy :: (a -> Bool) -> [a] -> Maybe a
firstBy predicate = find predicate
decodeAsciiArmorInput
:: String -> BL.ByteString -> IO (Maybe [Armor])
decodeAsciiArmorInput context input =
case validateAsciiArmorEnvelope input of
Just err ->
failWith BadData (context ++ ": malformed ASCII armor: " ++ err)
Nothing -> do
let primaryDecode = AA.decodeLazy input :: Either String [Armor]
case primaryDecode of
Right (_ : _) -> pure (Just (fromRight [] primaryDecode))
_ -> do
let normalizedInput = normalizeAsciiArmorForLenientDecode input
fallbackDecode =
if normalizedInput /= input
then AA.decodeLazy normalizedInput :: Either String [Armor]
else primaryDecode
case fallbackDecode of
Right []
| looksLikeAsciiArmor input ->
failWith
BadData
(context ++ ": malformed ASCII armor: no armor blocks found")
Right [] -> pure Nothing
Right armors -> pure (Just armors)
Left err
| looksLikeAsciiArmor input ->
failWith BadData (context ++ ": malformed ASCII armor: " ++ err)
| otherwise -> pure Nothing
normalizeAsciiArmorForLenientDecode
:: BL.ByteString -> BL.ByteString
normalizeAsciiArmorForLenientDecode input
| not (looksLikeAsciiArmor input) = input
| otherwise =
BL.fromStrict
. TE.encodeUtf8
. T.unlines
. normalizeAsciiArmorLines
$ T.lines normalizedLineEndings
where
normalizedLineEndings =
T.replace
(T.pack "\r")
(T.pack "\n")
( T.replace
(T.pack "\r\n")
(T.pack "\n")
(TE.decodeUtf8 (BL.toStrict input))
)
data LenientArmorDecodeState
= LenientOutsideArmor
| LenientArmorHeaders Bool Bool
| LenientArmorBody Bool
normalizeAsciiArmorLines :: [Text] -> [Text]
normalizeAsciiArmorLines = go LenientOutsideArmor
where
go _ [] = []
go state (line : rest) =
let trimmedLine = T.dropWhileEnd isSpace line
whitespaceOnly = T.all isSpace line
beginLabel = beginArmorLabelText trimmedLine
isBegin = isJust beginLabel
isEnd = T.isPrefixOf (T.pack "-----END PGP ") trimmedLine
hasHeaderSeparator = T.any (== ':') trimmedLine
in case state of
LenientOutsideArmor
| isBegin ->
let isClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")
shouldStripHeaders = not isClearSigned
in trimmedLine
: go (LenientArmorHeaders shouldStripHeaders isClearSigned) rest
| otherwise -> trimmedLine : go LenientOutsideArmor rest
LenientArmorHeaders stripHeaders isClearSigned
| whitespaceOnly ->
T.empty : go (LenientArmorBody isClearSigned) rest
| isEnd -> T.empty : trimmedLine : go LenientOutsideArmor rest
| stripHeaders && hasHeaderSeparator ->
go (LenientArmorHeaders stripHeaders isClearSigned) rest
| otherwise ->
trimmedLine : go (LenientArmorBody isClearSigned) rest
LenientArmorBody isClearSigned
| isEnd -> trimmedLine : go LenientOutsideArmor rest
| isBegin ->
let nestedClearSigned = beginLabel == Just (T.pack "SIGNED MESSAGE")
shouldStripHeaders = not nestedClearSigned
in trimmedLine
: go
(LenientArmorHeaders shouldStripHeaders nestedClearSigned)
rest
| otherwise ->
let bodyLine =
if isClearSigned
then line
else trimmedLine
in bodyLine : go (LenientArmorBody isClearSigned) rest
beginArmorLabelText :: Text -> Maybe Text
beginArmorLabelText line = do
rest <- T.stripPrefix (T.pack "-----BEGIN PGP ") line
T.stripSuffix (T.pack "-----") rest
validateClearSignedHeaders :: [(String, String)] -> IO ()
validateClearSignedHeaders headers =
unless (all (isAllowedHeaderKey . fst) headers) $
failWith
BadData
"cleartext signed message contains unsupported armor headers"
where
isAllowedHeaderKey hkey =
map toLower hkey `elem` ["hash"]
validateClearSignedEnvelopeBounds :: BL.ByteString -> IO ()
validateClearSignedEnvelopeBounds input = do
let text = TE.decodeUtf8With lenientDecode (BL.toStrict input)
normalized = T.replace (T.pack "\r") (T.pack "") text
ls = T.lines normalized
beginMarker = T.pack "-----BEGIN PGP SIGNED MESSAGE-----"
endMarker = T.pack "-----END PGP SIGNATURE-----"
firstBegin = findIndex ((== beginMarker) . T.strip) ls
hasVisibleText line = not (T.all isSpace line)
findIndexFrom start predicate =
fmap (+ start) (findIndex predicate (drop start ls))
case firstBegin of
Nothing -> pure ()
Just beginIx -> do
when (any hasVisibleText (take beginIx ls)) $
failWith
BadData
"cleartext signed message has non-whitespace text before armor header"
case findIndexFrom beginIx ((== endMarker) . T.strip) of
Nothing -> pure ()
Just endIx ->
when (any hasVisibleText (drop (endIx + 1) ls)) $
failWith
BadData
"cleartext signed message has non-whitespace text after signature block"
looksLikeAsciiArmor :: BL.ByteString -> Bool
looksLikeAsciiArmor input =
BLC8.pack "-----BEGIN PGP "
`BL.isPrefixOf` BLC8.dropWhile isAsciiArmorLeadingWhitespace input
isAsciiArmorLeadingWhitespace :: Char -> Bool
isAsciiArmorLeadingWhitespace c = c `elem` [' ', '\t', '\r', '\n']
validateAsciiArmorEnvelope :: BL.ByteString -> Maybe String
validateAsciiArmorEnvelope input
| not (looksLikeAsciiArmor input) = Nothing
| otherwise =
validateArmorBlocks
(BLC8.lines (BLC8.dropWhile isAsciiArmorLeadingWhitespace input))
validateArmorBlocks :: [BL.ByteString] -> Maybe String
validateArmorBlocks [] = Nothing
validateArmorBlocks (line : rest) =
case beginArmorLabel line of
-- UPSTREAM: openpgp-asciiarmor should export detectCleartextSignedBlock helper
-- to encapsulate this RFC 4880 cleartext signature framework detection
Just "SIGNED MESSAGE" -> validateClearSignedBlock rest
Just label -> validateBinaryArmorBlock label rest
Nothing -> Nothing
validateClearSignedBlock :: [BL.ByteString] -> Maybe String
validateClearSignedBlock ls =
case break hasBeginArmorLabel ls of
(_, []) ->
Just
"cleartext signed message is missing an armored signature block"
(_, beginLine : rest) ->
case beginArmorLabel beginLine of
Just "SIGNATURE" -> validateBinaryArmorBlock "SIGNATURE" rest
Just label ->
Just
( "cleartext signed message must be followed by a PGP SIGNATURE block, found PGP "
++ label
)
Nothing ->
Just
"cleartext signed message has an invalid armored signature header"
validateBinaryArmorBlock
:: String -> [BL.ByteString] -> Maybe String
validateBinaryArmorBlock label ls =
case break hasEndArmorLabel ls of
(_, []) -> Just ("missing END PGP " ++ label ++ " footer")
(_, endLine : rest) ->
case endArmorLabel endLine of
Just endLabel
| endLabel == label -> validateArmorBlocks rest
| otherwise ->
Just
( "mismatched footer: expected END PGP "
++ label
++ ", found END PGP "
++ endLabel
)
Nothing -> Just ("invalid END PGP " ++ label ++ " footer")
hasBeginArmorLabel :: BL.ByteString -> Bool
hasBeginArmorLabel = isJust . beginArmorLabel
hasEndArmorLabel :: BL.ByteString -> Bool
hasEndArmorLabel = isJust . endArmorLabel
beginArmorLabel :: BL.ByteString -> Maybe String
beginArmorLabel = armorBoundaryLabel "-----BEGIN PGP " "-----"
endArmorLabel :: BL.ByteString -> Maybe String
endArmorLabel = armorBoundaryLabel "-----END PGP " "-----"
armorBoundaryLabel
:: String -> String -> BL.ByteString -> Maybe String
armorBoundaryLabel prefix suffix line = do
rest <- stripPrefix prefix (BLC8.unpack line)
if suffix `isSuffixOf` rest
then pure (take (length rest - length suffix) rest)
else Nothing
isOpenPGPArmorBlock :: Armor -> Bool
isOpenPGPArmorBlock (Armor _ _ _) = True
isOpenPGPArmorBlock _ = False
isArmorMessageBlock :: Armor -> Bool
isArmorMessageBlock (Armor ArmorMessage _ _) = True
isArmorMessageBlock _ = False
isDetachedSignatureArmor :: Armor -> Bool
isDetachedSignatureArmor (Armor ArmorSignature _ _) = True
isDetachedSignatureArmor _ = False
isDetachedSignatureUnsupportedArmor :: Armor -> Bool
isDetachedSignatureUnsupportedArmor (Armor _ _ _) = True
isDetachedSignatureUnsupportedArmor ClearSigned {} = True
isClearSignedArmor :: Armor -> Bool
isClearSignedArmor ClearSigned {} = True
isClearSignedArmor _ = False
isInlineSignedArmorCandidate :: Armor -> Bool
isInlineSignedArmorCandidate (Armor ArmorMessage _ _) = True
isInlineSignedArmorCandidate ClearSigned {} = True
isInlineSignedArmorCandidate _ = False
splitInlineSignedPackets :: [Pkt] -> IO (BL.ByteString, [Pkt])
splitInlineSignedPackets pkts = do
let msgPkts = [p | p@LiteralDataPkt {} <- pkts]
sigPkts = [p | p@SignaturePkt {} <- pkts]
case msgPkts of
[LiteralDataPkt _ _ _ payload]
| null sigPkts ->
failWith BadData "inline-detach input has no signatures"
| otherwise -> return (payload, sigPkts)
[] ->
failWith
BadData
"inline-detach input has no literal message payload"
_ ->
failWith
BadData
"inline-detach input contains multiple literal payloads"
writeDetachedSignatures :: Bool -> String -> [Pkt] -> IO ()
writeDetachedSignatures noArmor outPath sigPkts = do
let sigBytes = runPut $ mapM_ Bin.put sigPkts
out =
if noArmor
then sigBytes
else
BL.fromStrict
(BLC8.toStrict (AA.encodeLazy [Armor ArmorSignature [] sigBytes]))
BL.writeFile outPath out
doListProfiles :: ListProfilesOptions -> IO ()
doListProfiles lpos =
case profileSubcommand lpos of
"generate-key" ->
putStr
"default: implementation defaults\nrfc4880: RSA-4096 interoperability-focused key generation\ncompatibility: broad interoperability defaults (alias of rfc4880)\nsecurity: security-oriented key generation\nperformance: performance-oriented key generation\n"
"encrypt" ->
putStr
"default: implementation defaults (alias of rfc9580, security, and performance)\nrfc9580: RFC 9580 packet format preferences\nrfc4880: RFC 4880 packet format preferences\ncompatibility: broad interoperability defaults (alias of rfc4880)\n"
_ ->
failWith
UnsupportedProfile
"Subcommand does not support profiles"