hOpenPGP-3.0.0: Codec/Encryption/OpenPGP/Message.hs
-- Message.hs: OpenPGP (RFC9580) message helpers
-- Copyright © 2026 Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Codec.Encryption.OpenPGP.Message
( Passphrase
, mkPassphrase
, passphraseBytes
, EncryptedPayload
, mkEncryptedPayload
, encryptedPayloadBytes
, ClearPayload
, mkClearPayload
, clearPayloadBytes
, WrappedSessionMaterial
, SigningAlgorithm(..)
, SecretKeyFor
, VersionedPKPayload
, asV4PKPayload
, asV6PKPayload
, Signer
, SigningCapability
, mkRSASignerV4
, mkRSASignerV6
, mkEd25519SignerV4
, mkEd25519SignerV6
, mkEd448SignerV4
, mkEd448SignerV6
, MessageParseFailure(..)
, MessageDecryptFailure(..)
, MessageError(..)
, SessionMaterialExposure(..)
, EncryptMessageProfile
, EncryptMessageOptions(..)
, RecoveredSessionMaterial(..)
, encryptMessage
, decryptMessage
, signMessage
, signMessageWith
, ConduitMessage.VerificationPolicy(..)
, ConduitMessage.VerificationOptions(..)
, ConduitMessage.defaultVerificationOptions
, verifySignedMessage
) where
import Data.Bifunctor (first)
import Data.Kind (Type)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import qualified Crypto.Hash as CH
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA.Types as RSATypes
import qualified Data.ByteArray as BA
import Crypto.Random.Types (MonadRandom, getRandomBytes)
import Data.Binary (put)
import Data.Binary.Put (runPut)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Word (Word8)
import Codec.Encryption.OpenPGP.BlockCipher (CipherError, renderCipherError, keySize, withSymmetricCipher)
import Codec.Encryption.OpenPGP.CFB
( OpenPGPCFBModeW(..)
, decryptOpenPGPCfb
, decryptPreservingNonce
, encryptOpenPGPCfbRaw
, mdcTrailerForSEIPDv1
, seipdv1NonceFromIV
, validateSEIPD1MDC
)
import Codec.Encryption.OpenPGP.Encrypt (encryptSEIPDv2WithSKESKBlock)
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..))
import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2
( decryptSKESK6SessionKey
, deriveSKESK6KEK
)
import Codec.Encryption.OpenPGP.Policy
( OpenPGPPolicy
, defaultPolicy
, deprecatedHashAlgorithms
, messageDefaultAEADAlgorithm
, messageDefaultChunkSize
, messageSEIPDv2SaltOctets
, policyGenerationDeprecations
, policyMessageEncryption
, supportsSEIPDv2Symmetric
, OpenPGPRFCW(..)
, HashAlgorithmW(..)
)
import Codec.Encryption.OpenPGP.S2K (S2KError(..), renderS2KError, skesk2SessionKey, string2Key)
import Codec.Encryption.OpenPGP.Serialize (parsePkts)
import Codec.Encryption.OpenPGP.Signatures
( SignError(..)
, VerificationError
, signDataWithRSABuilder
, signDataWithRSAV6Builder
, signDataWithEd25519Builder
, signDataWithEd25519V6Builder
, signDataWithEd448Builder
, signDataWithEd448V6Builder
)
import Codec.Encryption.OpenPGP.Subpackets
( sigBuilderInitTyped
, sigBuilderInitV6Typed
, addHashedSubs
, addUnhashedSubs
, listToHashedSubs
, listToUnhashedSubs
)
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA
import Data.Conduit.OpenPGP.Decrypt (decryptSEIPDv2Payload)
import qualified Data.Conduit.OpenPGP.Message as ConduitMessage
newtype Passphrase = Passphrase { unPassphrase :: BL.ByteString }
deriving (Eq, Ord, Show)
newtype EncryptedPayload = EncryptedPayload { unEncryptedPayload :: BL.ByteString }
deriving (Eq, Ord, Show)
newtype ClearPayload = ClearPayload { unClearPayload :: BL.ByteString }
deriving (Eq, Ord, Show)
newtype WrappedSessionMaterial = WrappedSessionMaterial { unWrappedSessionMaterial :: B.ByteString }
deriving (Eq, Ord, Show)
data SigningAlgorithm = AlgoRSA | AlgoEd25519 | AlgoEd448
type family SecretKeyFor (alg :: SigningAlgorithm) where
SecretKeyFor 'AlgoRSA = RSATypes.PrivateKey
SecretKeyFor 'AlgoEd25519 = Ed25519.SecretKey
SecretKeyFor 'AlgoEd448 = Ed448.SecretKey
type family KeyVersionForSig (v :: Type) :: KeyVersion where
KeyVersionForSig V4Sig = 'V4
KeyVersionForSig V6Sig = 'V6
data VersionedPKPayload (v :: KeyVersion) where
VersionedPKPayloadV4 :: PKPayload 'V4 -> VersionedPKPayload 'V4
VersionedPKPayloadV6 :: PKPayload 'V6 -> VersionedPKPayload 'V6
asV4PKPayload :: SomePKPayload -> Either String (VersionedPKPayload 'V4)
asV4PKPayload (SomePKPayload pk@(PKPayloadV4 _ _ _)) =
Right (VersionedPKPayloadV4 pk)
asV4PKPayload _ = Left "Expected a v4 PKPayload"
asV6PKPayload :: SomePKPayload -> Either String (VersionedPKPayload 'V6)
asV6PKPayload (SomePKPayload pk@(PKPayloadV6 _ _ _)) =
Right (VersionedPKPayloadV6 pk)
asV6PKPayload _ = Left "Expected a v6 PKPayload"
data Signer (alg :: SigningAlgorithm) (v :: Type) where
RSASigner :: VersionedPKPayload (KeyVersionForSig v) -> SecretKeyFor 'AlgoRSA -> Signer 'AlgoRSA v
Ed25519Signer :: VersionedPKPayload (KeyVersionForSig v) -> SecretKeyFor 'AlgoEd25519 -> Signer 'AlgoEd25519 v
Ed448Signer :: VersionedPKPayload (KeyVersionForSig v) -> SecretKeyFor 'AlgoEd448 -> Signer 'AlgoEd448 v
class SigningCapability (alg :: SigningAlgorithm) v
instance SigningCapability 'AlgoRSA V4Sig
instance SigningCapability 'AlgoRSA V6Sig
instance SigningCapability 'AlgoEd25519 V4Sig
instance SigningCapability 'AlgoEd25519 V6Sig
instance SigningCapability 'AlgoEd448 V4Sig
instance SigningCapability 'AlgoEd448 V6Sig
mkRSASignerV4 :: VersionedPKPayload 'V4 -> SecretKeyFor 'AlgoRSA -> Signer 'AlgoRSA V4Sig
mkRSASignerV4 = RSASigner
mkRSASignerV6 :: VersionedPKPayload 'V6 -> SecretKeyFor 'AlgoRSA -> Signer 'AlgoRSA V6Sig
mkRSASignerV6 = RSASigner
mkEd25519SignerV4 :: VersionedPKPayload 'V4 -> SecretKeyFor 'AlgoEd25519 -> Signer 'AlgoEd25519 V4Sig
mkEd25519SignerV4 = Ed25519Signer
mkEd25519SignerV6 :: VersionedPKPayload 'V6 -> SecretKeyFor 'AlgoEd25519 -> Signer 'AlgoEd25519 V6Sig
mkEd25519SignerV6 = Ed25519Signer
mkEd448SignerV4 :: VersionedPKPayload 'V4 -> SecretKeyFor 'AlgoEd448 -> Signer 'AlgoEd448 V4Sig
mkEd448SignerV4 = Ed448Signer
mkEd448SignerV6 :: VersionedPKPayload 'V6 -> SecretKeyFor 'AlgoEd448 -> Signer 'AlgoEd448 V6Sig
mkEd448SignerV6 = Ed448Signer
data MessageError
= MessageEncryptError String
| MessageDecryptError String
| MessageSignError SignError
| MessageParseError String
| MessageParseFailureError MessageParseFailure
| MessageDecryptFailureError MessageDecryptFailure
deriving (Eq, Show)
newtype MessageFlow a =
MessageFlow
{ runMessageFlow :: Either MessageError a
}
instance Functor MessageFlow where
fmap f (MessageFlow result) = MessageFlow (fmap f result)
instance Applicative MessageFlow where
pure = MessageFlow . Right
MessageFlow ff <*> MessageFlow fa = MessageFlow (ff <*> fa)
instance Monad MessageFlow where
MessageFlow result >>= f =
case result of
Left err -> MessageFlow (Left err)
Right x -> f x
messageStep :: Either MessageError a -> MessageFlow a
messageStep = MessageFlow
type MessageFlowT m = ExceptT MessageError m
runMessageFlowT :: MessageFlowT m a -> m (Either MessageError a)
runMessageFlowT = runExceptT
liftMessageFlowT :: Monad m => MessageFlow a -> MessageFlowT m a
liftMessageFlowT (MessageFlow result) =
case result of
Left err -> throwE err
Right x -> pure x
data MessageParseFailure
= MissingEncryptedMessage
| ExpectedSKESKThenEncryptedData
| SKESKSEIPDAlgorithmMismatch
| UnsupportedEncryptedSKESK
| MissingLiteralDataPacket
| UnknownCriticalPacketType Word8
| BrokenCriticalPacketType Word8 String
deriving (Eq, Show)
data MessageDecryptFailure
= SessionMaterialDerivationFailed S2KError
| PayloadDecryptFailed String
deriving (Eq, Show)
data ParsedEncryptedPayloadKind
= LegacySEDPayloadKind
| LegacySEIPDv1PayloadKind
| SEIPDv2PayloadKind
data EncryptedPreludeKind
= LegacyEncryptedPreludeKind
| SEIPDv2EncryptedPreludeKind
data SessionMaterialExposure
= DoNotExposeSessionMaterial
| ExposeSessionMaterial
deriving (Eq, Show)
data EncryptMessageProfile
= RFC4880Message
| RFC9580Message
data EncryptMessageOptions (p :: EncryptMessageProfile) where
RFC4880EncryptMessageOptions ::
{ rfc4880EncryptMessageExposure :: SessionMaterialExposure
, rfc4880EncryptMessageSymmetricAlgorithm :: SymmetricAlgorithm
, rfc4880EncryptMessageS2K :: S2K
, rfc4880EncryptMessageIV :: IV
}
-> EncryptMessageOptions 'RFC4880Message
RFC9580EncryptMessageOptions ::
{ rfc9580EncryptMessageExposure :: SessionMaterialExposure
, rfc9580EncryptMessageSymmetricAlgorithm :: SymmetricAlgorithm
, rfc9580EncryptMessageS2K :: S2K
, rfc9580EncryptMessageIV :: IV
}
-> EncryptMessageOptions 'RFC9580Message
deriving instance Eq (EncryptMessageOptions p)
deriving instance Show (EncryptMessageOptions p)
data RecoveredSessionMaterial =
RecoveredSessionMaterial
{ recoveredSessionAlgorithm :: SymmetricAlgorithm
, recoveredSessionKey :: SessionKey
}
deriving (Eq, Show)
renderMessageParseFailure :: MessageParseFailure -> String
renderMessageParseFailure MissingEncryptedMessage =
"Could not parse encrypted OpenPGP message"
renderMessageParseFailure ExpectedSKESKThenEncryptedData =
"Expected an SKESK packet followed by symmetrically encrypted data or SEIPD v2 data"
renderMessageParseFailure SKESKSEIPDAlgorithmMismatch =
"SKESK and SEIPD v2 algorithms do not match"
renderMessageParseFailure UnsupportedEncryptedSKESK =
"Cannot decrypt SKESK packets with encrypted session keys"
renderMessageParseFailure MissingLiteralDataPacket =
"Decrypted message does not contain a literal data packet"
renderMessageParseFailure (UnknownCriticalPacketType t) =
"Unknown critical packet type: " ++ show t
renderMessageParseFailure (BrokenCriticalPacketType t err) =
"Broken critical packet type " ++ show t ++ ": " ++ err
renderMessageDecryptFailure :: MessageDecryptFailure -> String
renderMessageDecryptFailure (SessionMaterialDerivationFailed err) = renderS2KError err
renderMessageDecryptFailure (PayloadDecryptFailed err) = err
mkPassphrase :: BL.ByteString -> Passphrase
mkPassphrase = Passphrase
passphraseBytes :: Passphrase -> BL.ByteString
passphraseBytes = unPassphrase
mkEncryptedPayload :: BL.ByteString -> EncryptedPayload
mkEncryptedPayload = EncryptedPayload
mkClearPayload :: BL.ByteString -> ClearPayload
mkClearPayload = ClearPayload
clearPayloadBytes :: ClearPayload -> BL.ByteString
clearPayloadBytes = unClearPayload
encryptedPayloadBytes :: EncryptedPayload -> BL.ByteString
encryptedPayloadBytes = unEncryptedPayload
firstLeft :: (e -> e') -> Either e a -> Either e' a
firstLeft f = either (Left . f) Right
-- | Lift a parse failure step into the unified MessageError channel
parseStep :: Either MessageParseFailure a -> MessageFlow a
parseStep = messageStep . firstLeft MessageParseFailureError
-- | Lift a decrypt failure step into the unified MessageError channel
decryptStep :: Either MessageDecryptFailure a -> MessageFlow a
decryptStep = messageStep . firstLeft MessageDecryptFailureError
-- | Lift a string encrypt error step into the unified MessageError channel
encryptStep :: Either String a -> MessageFlow a
encryptStep = messageStep . firstLeft MessageEncryptError
-- | Lift a sign error step into the unified MessageError channel
signStep :: Either SignError a -> MessageFlow a
signStep = messageStep . firstLeft MessageSignError
signStepT :: Monad m => Either SignError a -> MessageFlowT m a
signStepT = liftMessageFlowT . signStep
signBackendStep :: Either String a -> Either SignError a
signBackendStep = firstLeft SignBackendError
decryptSessionStep :: Either S2KError a -> Either MessageDecryptFailure a
decryptSessionStep = firstLeft SessionMaterialDerivationFailed
decryptSessionKeySizeStep :: Either CipherError a -> Either MessageDecryptFailure a
decryptSessionKeySizeStep =
firstLeft (SessionMaterialDerivationFailed . S2KUnsupportedAlgorithm)
decryptCipherStep :: Either CipherError a -> Either MessageDecryptFailure a
decryptCipherStep = firstLeft (PayloadDecryptFailed . renderCipherError)
decryptPayloadStep :: Either String a -> Either MessageDecryptFailure a
decryptPayloadStep = firstLeft PayloadDecryptFailed
encryptMessage ::
EncryptMessageOptions p
-> Passphrase
-> ClearPayload
-> Either MessageError (EncryptedPayload, Maybe RecoveredSessionMaterial)
encryptMessage options passphrase payload = runMessageFlow $
case options of
RFC4880EncryptMessageOptions exposure sa s2k iv -> do
encryptedPayload <- encryptMessageWithRFC4880Fallback sa s2k iv passphrase payload
sessionKeyMaterial <- deriveSessionMaterial sa s2k passphrase
pure (encryptedPayload, exposedSessionMaterial exposure sa sessionKeyMaterial)
RFC9580EncryptMessageOptions exposure sa s2k iv -> do
encryptStep $ validateRFC9580MessageSymmetric defaultPolicy sa
encryptStep $ validateModernMessageS2K defaultPolicy s2k
encrypted <-
encryptStep $
encryptSEIPDv2WithSKESKBlock
sa
(messageDefaultAEADAlgorithm messagePolicy)
(messageDefaultChunkSize messagePolicy)
(defaultSEIPDv2SaltFromIV (messageSEIPDv2SaltOctets messagePolicy) iv)
s2k
(unPassphrase passphrase)
(Block [LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload)])
sessionKeyMaterial <- deriveSessionMaterial sa s2k passphrase
pure
( EncryptedPayload (runPut (put (Block encrypted)))
, exposedSessionMaterial exposure sa sessionKeyMaterial
)
where
messagePolicy = policyMessageEncryption defaultPolicy
defaultSEIPDv2SaltFromIV :: Int -> IV -> Salt
defaultSEIPDv2SaltFromIV outputLen (IV ivBytes) =
Salt (B.take outputLen (B.concat (replicate outputLen seed)))
where
seed
| B.null ivBytes = B.singleton 0
| otherwise = ivBytes
encryptMessageWithRFC4880Fallback ::
SymmetricAlgorithm
-> S2K
-> IV
-> Passphrase
-> ClearPayload
-> MessageFlow EncryptedPayload
encryptMessageWithRFC4880Fallback sa s2k iv passphrase payload = do
keyLen <- encryptStep . first renderCipherError $ keySize sa
sessionMaterial <- encryptStep . first renderS2KError $
WrappedSessionMaterial <$> string2Key s2k keyLen (unPassphrase passphrase)
let literal = LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload)
cleartext = BL.toStrict (runPut (put (Block [literal])))
cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext
encrypted <- encryptStep . first renderCipherError $
encryptOpenPGPCfbRaw OpenPGPCFBNoResyncW sa iv cleartextWithMDC (unWrappedSessionMaterial sessionMaterial)
return . EncryptedPayload . runPut . put $
Block
[ SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing))
, SymEncIntegrityProtectedDataPkt (SEIPD1 1 (BL.fromStrict encrypted))
]
deriveSessionMaterial ::
SymmetricAlgorithm -> S2K -> Passphrase -> MessageFlow B.ByteString
deriveSessionMaterial sa s2k passphrase = do
keyLen <- encryptStep . first renderCipherError $ keySize sa
encryptStep . first renderS2KError $ string2Key s2k keyLen (unPassphrase passphrase)
exposedSessionMaterial ::
SessionMaterialExposure
-> SymmetricAlgorithm
-> B.ByteString
-> Maybe RecoveredSessionMaterial
exposedSessionMaterial DoNotExposeSessionMaterial _ _ = Nothing
exposedSessionMaterial ExposeSessionMaterial sa sessionKeyMaterial =
Just
(RecoveredSessionMaterial
{ recoveredSessionAlgorithm = sa
, recoveredSessionKey = SessionKey sessionKeyMaterial
})
decryptMessage :: Passphrase -> EncryptedPayload -> Either MessageError ClearPayload
decryptMessage passphrase encrypted = runMessageFlow $ do
encryptedPackets <- parseStep $ rejectUnknownCriticalPacketsTyped (parsePkts (unEncryptedPayload encrypted))
payload <- parseStep $ extractEncryptedPayload encryptedPackets
cleartext <- decryptStep $ decryptPayloadTyped passphrase payload
clearPackets <- parseStep $ rejectUnknownCriticalPacketsTyped (parsePkts (unClearPayload cleartext))
parseStep $ extractLiteralPayload clearPackets
signMessageWith ::
(MonadRandom m, SigningCapability alg v)
=> Signer alg v
-> ClearPayload
-> m (Either MessageError BL.ByteString)
signMessageWith signer payload = runMessageFlowT $
case signer of
RSASigner signerPK signingKey ->
case signerPK of
VersionedPKPayloadV4 pk ->
signV4Message
pk
(\hashed unhashed clear ->
let builder =
sigBuilderInitTyped @'PKA.RSA RFC9580W BinarySig SHA512W
withHashed = addHashedSubs (listToHashedSubs hashed) builder
withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
in signDataWithRSABuilder withUnhashed signingKey clear)
payload
VersionedPKPayloadV6 pk ->
signV6Message
pk
(\salt hashed unhashed clear ->
let builder =
sigBuilderInitV6Typed @'PKA.RSA RFC9580W BinarySig SHA512W salt
withHashed = addHashedSubs (listToHashedSubs hashed) builder
withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
in signDataWithRSAV6Builder withUnhashed signingKey clear)
payload
Ed25519Signer signerPK signingKey ->
case signerPK of
VersionedPKPayloadV4 pk ->
signV4Message
pk
(\hashed unhashed clear ->
let builder =
sigBuilderInitTyped @'PKA.Ed25519 RFC9580W BinarySig SHA512W
withHashed = addHashedSubs (listToHashedSubs hashed) builder
withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
in signDataWithEd25519Builder withUnhashed signingKey clear)
payload
VersionedPKPayloadV6 pk ->
signV6Message
pk
(\salt hashed unhashed clear ->
let builder =
sigBuilderInitV6Typed @'PKA.Ed25519 RFC9580W BinarySig SHA512W salt
withHashed = addHashedSubs (listToHashedSubs hashed) builder
withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
in signDataWithEd25519V6Builder withUnhashed signingKey clear)
payload
Ed448Signer signerPK signingKey ->
case signerPK of
VersionedPKPayloadV4 pk ->
signV4Message
pk
(\hashed unhashed clear ->
let builder =
sigBuilderInitTyped @'PKA.Ed448 RFC9580W BinarySig SHA512W
withHashed = addHashedSubs (listToHashedSubs hashed) builder
withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
in signDataWithEd448Builder withUnhashed signingKey clear)
payload
VersionedPKPayloadV6 pk ->
signV6Message
pk
(\salt hashed unhashed clear ->
let builder =
sigBuilderInitV6Typed @'PKA.Ed448 RFC9580W BinarySig SHA512W salt
withHashed = addHashedSubs (listToHashedSubs hashed) builder
withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
in signDataWithEd448V6Builder withUnhashed signingKey clear)
payload
signMessage ::
(MonadRandom m, SigningCapability alg v)
=> Signer alg v
-> BL.ByteString
-> m (Either MessageError BL.ByteString)
signMessage signer = signMessageWith signer . mkClearPayload
versionedPKPayload :: VersionedPKPayload v -> PKPayload v
versionedPKPayload (VersionedPKPayloadV4 pk) = pk
versionedPKPayload (VersionedPKPayloadV6 pk) = pk
verifySignedMessage ::
ConduitMessage.VerificationOptions
-> PublicKeyring
-> BL.ByteString
-> [Either VerificationError Verification]
verifySignedMessage = ConduitMessage.verifyMessage
signV4Message ::
Monad m
=> PKPayload 'V4
-> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload)
-> ClearPayload
-> MessageFlowT m BL.ByteString
signV4Message signer signingFn payload =
signStepT (signV4WithIssuers signer signingFn payload)
signV6Message ::
MonadRandom m
=> PKPayload 'V6
-> (SignatureSalt -> [SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload)
-> ClearPayload
-> MessageFlowT m BL.ByteString
signV6Message signer signingFn payload = do
salt <- lift randomSHA512SignatureSalt
signStepT (signV6WithFingerprintOnly signer (signingFn salt) payload)
randomSHA512SignatureSalt :: MonadRandom m => m SignatureSalt
randomSHA512SignatureSalt =
SignatureSalt . BL.fromStrict <$> getRandomBytes 32
signV4WithIssuers ::
PKPayload 'V4
-> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload)
-> ClearPayload
-> Either SignError BL.ByteString
signV4WithIssuers signer signingFn payload = do
issuerKeyId <- signBackendStep (eightOctetKeyID (SomePKPayload signer))
let hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint (SomePKPayload signer)))]
unhashed = [SigSubPacket False (Issuer issuerKeyId)]
signWithSubpackets hashed unhashed signingFn payload
signV6WithFingerprintOnly ::
PKPayload 'V6
-> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload)
-> ClearPayload
-> Either SignError BL.ByteString
signV6WithFingerprintOnly signer signingFn payload = do
let hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 (fingerprint (SomePKPayload signer)))]
unhashed = []
signWithSubpackets hashed unhashed signingFn payload
signWithSubpackets ::
[SigSubPacket]
-> [SigSubPacket]
-> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload)
-> ClearPayload
-> Either SignError BL.ByteString
signWithSubpackets hashed unhashed signingFn payload = do
let clear = unClearPayload payload
literal = LiteralDataPkt BinaryData BL.empty 0 clear
signature <- signingFn hashed unhashed clear
return . runPut . put $ Block [literal, SignaturePkt signature]
encryptOpenPGPCfb ::
SymmetricAlgorithm
-> IV
-> B.ByteString
-> WrappedSessionMaterial
-> Either CipherError B.ByteString
encryptOpenPGPCfb sa iv cleartext (WrappedSessionMaterial keydata) =
encryptOpenPGPCfbRaw OpenPGPCFBResyncW sa iv cleartext keydata
extractEncryptedPayload ::
[Pkt] -> Either MessageParseFailure SomeParsedEncryptedPayload
extractEncryptedPayload =
fmap parsedEncryptedPayloadFromPrelude . extractEncryptedPreludeTyped
data EncryptedPrelude (k :: EncryptedPreludeKind) where
LegacySEDPrelude ::
SKESK 'SKESKV4
-> B.ByteString
-> EncryptedPrelude 'LegacyEncryptedPreludeKind
LegacySEIPDv1Prelude ::
SKESK 'SKESKV4
-> B.ByteString
-> EncryptedPrelude 'LegacyEncryptedPreludeKind
SEIPDv2SKESK4Prelude ::
SymmetricAlgorithm
-> S2K
-> AEADAlgorithm
-> Word8
-> Salt
-> B.ByteString
-> EncryptedPrelude 'SEIPDv2EncryptedPreludeKind
SEIPDv2SKESK6Prelude ::
SymmetricAlgorithm
-> AEADAlgorithm
-> S2K
-> BL.ByteString
-> BL.ByteString
-> BL.ByteString
-> Word8
-> Salt
-> B.ByteString
-> EncryptedPrelude 'SEIPDv2EncryptedPreludeKind
data SomeEncryptedPrelude where
SomeEncryptedPrelude :: EncryptedPrelude k -> SomeEncryptedPrelude
extractEncryptedPreludeTyped ::
[Pkt] -> Either MessageParseFailure SomeEncryptedPrelude
extractEncryptedPreludeTyped (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k esk)):SymEncDataPkt payload:_) =
Right
(SomeEncryptedPrelude
(LegacySEDPrelude
(SKESK4Packet sa s2k esk)
(BL.toStrict payload)))
extractEncryptedPreludeTyped (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k esk)):SymEncIntegrityProtectedDataPkt (SEIPD1 _ payload):_) =
Right
(SomeEncryptedPrelude
(LegacySEIPDv1Prelude
(SKESK4Packet sa s2k esk)
(BL.toStrict payload)))
extractEncryptedPreludeTyped (SKESKPkt skesk:SymEncIntegrityProtectedDataPkt (SEIPD2 payloadSA aead chunkSize salt payload):_) =
toSEIPDv2Prelude skesk payloadSA aead chunkSize salt payload
extractEncryptedPreludeTyped [] = Left MissingEncryptedMessage
extractEncryptedPreludeTyped _ = Left ExpectedSKESKThenEncryptedData
toSEIPDv2Prelude ::
SKESKPayload
-> SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> BL.ByteString
-> Either MessageParseFailure SomeEncryptedPrelude
toSEIPDv2Prelude (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) payloadSA aead chunkSize salt payload
| sa /= payloadSA = Left SKESKSEIPDAlgorithmMismatch
| otherwise =
Right
(SomeEncryptedPrelude
(SEIPDv2SKESK4Prelude
sa
s2k
aead
chunkSize
salt
(BL.toStrict payload)))
toSEIPDv2Prelude (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) payloadSA aead chunkSize salt payload
| sa /= payloadSA = Left SKESKSEIPDAlgorithmMismatch
| otherwise =
Right
(SomeEncryptedPrelude
(SEIPDv2SKESK6Prelude
sa
aa
s2k
iv
esk
tag
chunkSize
salt
(BL.toStrict payload)))
toSEIPDv2Prelude (SKESKPayloadV4Packet (SKESKPayloadV4 _ _ (Just _))) _ _ _ _ _ = Left UnsupportedEncryptedSKESK
toSEIPDv2Prelude _ _ _ _ _ _ = Left ExpectedSKESKThenEncryptedData
parsedEncryptedPayloadFromPrelude :: SomeEncryptedPrelude -> SomeParsedEncryptedPayload
parsedEncryptedPayloadFromPrelude (SomeEncryptedPrelude prelude) =
case prelude of
LegacySEDPrelude skesk payload ->
SomeParsedEncryptedPayload (LegacySEDPayload skesk payload)
LegacySEIPDv1Prelude skesk payload ->
SomeParsedEncryptedPayload (LegacySEIPDv1Payload skesk payload)
SEIPDv2SKESK4Prelude sa s2k aead chunkSize salt payload ->
SomeParsedEncryptedPayload
(SEIPDv2Payload
sa
aead
chunkSize
salt
(SEIPDv2SKESK4 sa s2k)
payload)
SEIPDv2SKESK6Prelude sa aa s2k iv esk tag chunkSize salt payload ->
SomeParsedEncryptedPayload
(SEIPDv2Payload
sa
aa
chunkSize
salt
(SEIPDv2SKESK6 sa aa s2k iv esk tag)
payload)
data SEIPDv2SKESKInfo (v :: KeyVersion) where
SEIPDv2SKESK4 :: SymmetricAlgorithm -> S2K -> SEIPDv2SKESKInfo 'V4
SEIPDv2SKESK6 ::
SymmetricAlgorithm
-> AEADAlgorithm
-> S2K
-> BL.ByteString
-> BL.ByteString
-> BL.ByteString
-> SEIPDv2SKESKInfo 'V6
data ParsedEncryptedPayload (k :: ParsedEncryptedPayloadKind) where
LegacySEDPayload ::
SKESK 'SKESKV4
-> B.ByteString
-> ParsedEncryptedPayload 'LegacySEDPayloadKind
LegacySEIPDv1Payload ::
SKESK 'SKESKV4
-> B.ByteString
-> ParsedEncryptedPayload 'LegacySEIPDv1PayloadKind
SEIPDv2Payload ::
SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> SEIPDv2SKESKInfo v
-> B.ByteString
-> ParsedEncryptedPayload 'SEIPDv2PayloadKind
data SomeParsedEncryptedPayload where
SomeParsedEncryptedPayload ::
ParsedEncryptedPayload k
-> SomeParsedEncryptedPayload
decryptPayload :: Passphrase -> SomeParsedEncryptedPayload -> Either String ClearPayload
decryptPayload passphrase =
first renderMessageDecryptFailure . decryptPayloadTyped passphrase
decryptPayloadTyped ::
Passphrase -> SomeParsedEncryptedPayload -> Either MessageDecryptFailure ClearPayload
decryptPayloadTyped passphrase (SomeParsedEncryptedPayload payload) =
case payload of
LegacySEDPayload skesk encryptedPayload ->
decryptLegacySEDPayloadTyped passphrase skesk encryptedPayload
LegacySEIPDv1Payload skesk encryptedPayload ->
decryptLegacySEIPDv1PayloadTyped passphrase skesk encryptedPayload
SEIPDv2Payload sa aead chunkSize salt skeskInfo encryptedPayload ->
decryptSEIPDv2PayloadTyped
passphrase
sa
aead
chunkSize
salt
skeskInfo
encryptedPayload
decryptLegacySEDPayloadTyped ::
Passphrase
-> SKESK 'SKESKV4
-> B.ByteString
-> Either MessageDecryptFailure ClearPayload
decryptLegacySEDPayloadTyped passphrase skesk payload = do
(sessionAlgorithm, sessionKeyBytes) <-
decryptSessionStep $
skesk2SessionKey skesk (unPassphrase passphrase)
decryptCipherStep $
ClearPayload . BL.fromStrict <$>
decryptOpenPGPCfb
sessionAlgorithm
payload
sessionKeyBytes
decryptLegacySEIPDv1PayloadTyped ::
Passphrase
-> SKESK 'SKESKV4
-> B.ByteString
-> Either MessageDecryptFailure ClearPayload
decryptLegacySEIPDv1PayloadTyped passphrase skesk payload = do
(sessionAlgorithm, sessionKeyBytes) <-
decryptSessionStep $
skesk2SessionKey skesk (unPassphrase passphrase)
(nonce, decrypted) <-
decryptCipherStep $
decryptPreservingNonce sessionAlgorithm payload sessionKeyBytes
cleartext <- decryptPayloadStep $ validateSEIPD1MDC nonce decrypted
Right (ClearPayload (BL.fromStrict cleartext))
decryptSEIPDv2PayloadTyped ::
Passphrase
-> SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> SEIPDv2SKESKInfo v
-> B.ByteString
-> Either MessageDecryptFailure ClearPayload
decryptSEIPDv2PayloadTyped passphrase sa aead chunkSize salt skeskInfo payload = do
sessionKey <- SessionKey <$> deriveSEIPDv2SessionKeyBytes passphrase skeskInfo
decryptPayloadStep $
ClearPayload . BL.fromStrict <$>
decryptSEIPDv2Payload sa aead chunkSize salt payload sessionKey
deriveSEIPDv2SessionKeyBytes ::
Passphrase
-> SEIPDv2SKESKInfo v
-> Either MessageDecryptFailure B.ByteString
deriveSEIPDv2SessionKeyBytes passphrase (SEIPDv2SKESK4 sa s2k) =
deriveSessionKeyBytes passphrase sa s2k
deriveSEIPDv2SessionKeyBytes passphrase (SEIPDv2SKESK6 sa aead s2k iv esk tag) = do
ikm <- deriveSessionKeyBytes passphrase sa s2k
kek <- decryptPayloadStep $ deriveSKESK6KEK sa aead ikm
decryptPayloadStep $
decryptSKESK6SessionKey sa aead kek (BL.toStrict iv) (BL.toStrict esk) (BL.toStrict tag)
deriveSessionKeyBytes ::
Passphrase
-> SymmetricAlgorithm
-> S2K
-> Either MessageDecryptFailure B.ByteString
deriveSessionKeyBytes passphrase sa s2k = do
keyLen <- decryptSessionKeySizeStep $ keySize sa
decryptSessionStep $ string2Key s2k keyLen (unPassphrase passphrase)
extractLiteralPayload :: [Pkt] -> Either MessageParseFailure ClearPayload
extractLiteralPayload pkts =
case [p | LiteralDataPkt _ _ _ p <- pkts] of
payload:_ -> Right (ClearPayload payload)
[] -> Left MissingLiteralDataPacket
rejectUnknownCriticalPacketsTyped :: [Pkt] -> Either MessageParseFailure [Pkt]
rejectUnknownCriticalPacketsTyped =
go []
where
go acc [] = Right (reverse acc)
go acc (pkt:rest) =
case pkt of
OtherPacketPkt t _ | t < 40 -> Left (UnknownCriticalPacketType t)
BrokenPacketPkt err t _ | t < 40 -> Left (BrokenCriticalPacketType t err)
_ -> go (pkt : acc) rest
validateModernMessageS2K :: OpenPGPPolicy -> S2K -> Either String ()
validateModernMessageS2K policy s2k =
case s2kHashAlgorithm s2k of
Just ha
| ha `elem` deprecatedHashAlgorithms (policyGenerationDeprecations policy) ->
Left
("deprecated hash algorithm disallowed for modern message generation: " ++
show ha)
_ -> Right ()
validateRFC9580MessageSymmetric ::
OpenPGPPolicy -> SymmetricAlgorithm -> Either String ()
validateRFC9580MessageSymmetric policy sa
| supportsSEIPDv2Symmetric policy sa = Right ()
| otherwise =
Left
("symmetric algorithm disallowed for RFC9580 message generation: " ++
show sa)
s2kHashAlgorithm :: S2K -> Maybe HashAlgorithm
s2kHashAlgorithm (Simple ha) = Just ha
s2kHashAlgorithm (Salted ha _) = Just ha
s2kHashAlgorithm (IteratedSalted ha _ _) = Just ha
s2kHashAlgorithm Argon2 {} = Nothing
s2kHashAlgorithm (OtherS2K _ _) = Nothing