diff --git a/Codec/Encryption/OpenPGP/Arbitrary.hs b/Codec/Encryption/OpenPGP/Arbitrary.hs --- a/Codec/Encryption/OpenPGP/Arbitrary.hs +++ b/Codec/Encryption/OpenPGP/Arbitrary.hs @@ -2,379 +2,404 @@ -- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} module Codec.Encryption.OpenPGP.Arbitrary - ( - ) where + ( + ) where -import Codec.Encryption.OpenPGP.Types import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import Network.URI (nullURI, parseURI) import Test.QuickCheck - ( Arbitrary(..) - , Gen - , choose - , elements - , frequency - , getPositive - , listOf1 - , oneof - , sized - , suchThat - , vector - ) + ( Arbitrary (..) + , Gen + , choose + , elements + , frequency + , getPositive + , listOf1 + , oneof + , sized + , suchThat + , vector + ) import Test.QuickCheck.Instances () +import Codec.Encryption.OpenPGP.Types + instance Arbitrary (PKESK 'PKESKV3) where - arbitrary = do - eoki <- arbitrary - pka <- arbitrary - mpis <- - case pka of - RSA -> (\mpi -> mpi NE.:| []) <$> arbitrary - DeprecatedRSAEncryptOnly -> (\mpi -> mpi NE.:| []) <$> arbitrary - ElgamalEncryptOnly -> do - mpi1 <- arbitrary - mpi2 <- arbitrary - pure (mpi1 NE.:| [mpi2]) - ForbiddenElgamal -> do - mpi1 <- arbitrary - mpi2 <- arbitrary - pure (mpi1 NE.:| [mpi2]) - ECDH -> do - mpi1 <- arbitrary - mpi2 <- arbitrary - pure (mpi1 NE.:| [mpi2]) - _ -> arbitrary - pure (PKESK3Packet 3 eoki pka mpis) + arbitrary = do + eoki <- arbitrary + pka <- arbitrary + mpis <- + case pka of + RSA -> (\mpi -> mpi NE.:| []) <$> arbitrary + DeprecatedRSAEncryptOnly -> (\mpi -> mpi NE.:| []) <$> arbitrary + ElgamalEncryptOnly -> do + mpi1 <- arbitrary + mpi2 <- arbitrary + pure (mpi1 NE.:| [mpi2]) + ForbiddenElgamal -> do + mpi1 <- arbitrary + mpi2 <- arbitrary + pure (mpi1 NE.:| [mpi2]) + ECDH -> do + mpi1 <- arbitrary + mpi2 <- arbitrary + pure (mpi1 NE.:| [mpi2]) + _ -> arbitrary + pure (PKESK3Packet 3 eoki pka mpis) instance Arbitrary (PKESK 'PKESKV6) where - arbitrary = do - rid <- - oneof - [ pure BL.empty - , BL.pack <$> vector 20 - , BL.pack . (4 :) <$> vector 20 - , BL.pack <$> vector 32 - , BL.pack . (6 :) <$> vector 32 - ] - pka <- arbitrary - esk <- BL.pack <$> listOf1 arbitrary - pure (PKESK6Packet rid pka esk) + arbitrary = do + rid <- + oneof + [ pure BL.empty + , BL.pack <$> vector 20 + , BL.pack . (4 :) <$> vector 20 + , BL.pack <$> vector 32 + , BL.pack . (6 :) <$> vector 32 + ] + pka <- arbitrary + esk <- BL.pack <$> listOf1 arbitrary + pure (PKESK6Packet rid pka esk) instance Arbitrary (SKESK 'SKESKV4) where - arbitrary = do - sa <- elements [AES128, AES192, AES256] - s2k <- arbitrarySKESKv4S2K - esk <- oneof [pure Nothing, Just . BL.pack <$> listOf1 arbitrary] - pure (SKESK4Packet sa s2k esk) + arbitrary = do + sa <- elements [AES128, AES192, AES256] + s2k <- arbitrarySKESKv4S2K + esk <- oneof [pure Nothing, Just . BL.pack <$> listOf1 arbitrary] + pure (SKESK4Packet sa s2k esk) instance Arbitrary (SKESK 'SKESKV6) where - arbitrary = do - sa <- elements [AES128, AES192, AES256] - aead <- elements [EAX, OCB, GCM] - s2k <- arbitrarySKESKv6S2K - iv <- BL.pack <$> vector 16 - esk <- BL.pack <$> listOf1 arbitrary - tag <- BL.pack <$> vector 16 - pure (SKESK6Packet sa aead s2k iv esk tag) + arbitrary = do + sa <- elements [AES128, AES192, AES256] + aead <- elements [EAX, OCB, GCM] + s2k <- arbitrarySKESKv6S2K + iv <- BL.pack <$> vector 16 + esk <- BL.pack <$> listOf1 arbitrary + tag <- BL.pack <$> vector 16 + pure (SKESK6Packet sa aead s2k iv esk tag) arbitrarySKESKv4S2K :: Gen S2K arbitrarySKESKv4S2K = - oneof - [ Simple <$> elements supportedSKESKHashAlgorithms - , Salted <$> elements supportedSKESKHashAlgorithms <*> (Salt8 . B.pack <$> vector 8) - ] + oneof + [ Simple <$> elements supportedSKESKHashAlgorithms + , Salted + <$> elements supportedSKESKHashAlgorithms + <*> (Salt8 . B.pack <$> vector 8) + ] arbitrarySKESKv6S2K :: Gen S2K arbitrarySKESKv6S2K = - Argon2 <$> - (Salt16 . B.pack <$> vector 16) <*> - choose (1, 4) <*> - choose (1, 4) <*> - choose (3, 31) + Argon2 + <$> (Salt16 . B.pack <$> vector 16) + <*> choose (1, 4) + <*> choose (1, 4) + <*> choose (3, 31) supportedSKESKHashAlgorithms :: [HashAlgorithm] supportedSKESKHashAlgorithms = [SHA1, SHA256, SHA384, SHA512] instance Arbitrary Signature where - arbitrary = fmap Signature arbitrary + arbitrary = fmap Signature arbitrary instance Arbitrary UserId where - arbitrary = fmap UserId arbitrary + arbitrary = fmap UserId arbitrary -- instance Arbitrary SignaturePayload where - arbitrary = frequency [(2, three), (3, four), (1, other)] - where - three = do - st <- arbitrary - w32 <- arbitrary - eoki <- arbitrary - pka <- arbitrary - ha <- arbitrary - w16 <- arbitrary - SigV3 st w32 eoki pka ha w16 <$> arbitrary - four = do - st <- arbitrary - pka <- arbitrary - ha <- arbitrary - has <- arbitrary - uhas <- arbitrary - w16 <- arbitrary - SigV4 st pka ha has uhas w16 <$> arbitrary - other = do - v <- oneof [pure 5, choose (7, maxBound)] - SigVOther v <$> arbitrary + arbitrary = frequency [(2, three), (3, four), (1, other)] + where + three = do + st <- arbitrary + w32 <- arbitrary + eoki <- arbitrary + pka <- arbitrary + ha <- arbitrary + w16 <- arbitrary + SigV3 st w32 eoki pka ha w16 <$> arbitrary + four = do + st <- arbitrary + pka <- arbitrary + ha <- arbitrary + has <- arbitrary + uhas <- arbitrary + w16 <- arbitrary + SigV4 st pka ha has uhas w16 <$> arbitrary + other = do + v <- oneof [pure 5, choose (7, maxBound)] + SigVOther v <$> arbitrary instance Arbitrary SigSubPacket where - arbitrary = do - crit <- arbitrary - SigSubPacket crit <$> arbitrary + arbitrary = do + crit <- arbitrary + SigSubPacket crit <$> arbitrary instance Arbitrary SigSubPacketPayload where - arbitrary = - sized $ \n -> - oneof - ([ sct - , set - , ec - , ts - , re - , ket - , psa - , rk - , i - , nd - , phas - , pcas - , ksps - , pks - , puid - , purl - , kfs - , suid - , rfr - , fs - , st - , udss - , oss - , ifp - ] ++ - [es n | n > 0]) - where - sct = fmap SigCreationTime arbitrary - set = fmap SigExpirationTime arbitrary - ec = fmap ExportableCertification arbitrary - ts = - arbitrary >>= \tl -> arbitrary >>= \ta -> return (TrustSignature tl ta) - re = fmap RegularExpression arbitrary - ket = fmap KeyExpirationTime arbitrary - psa = fmap PreferredSymmetricAlgorithms arbitrary - rk = - arbitrary >>= \rcs -> - arbitrary >>= \pka -> - fmap (RevocationKey rcs pka . Fingerprint . BL.pack) (vector 20) - i = fmap Issuer arbitrary - nd = - arbitrary >>= \nfs -> - arbitrary >>= \nn -> - arbitrary >>= \nv -> return (NotationData nfs nn nv) - phas = fmap PreferredHashAlgorithms arbitrary - pcas = fmap PreferredCompressionAlgorithms arbitrary - ksps = fmap KeyServerPreferences arbitrary - pks = fmap PreferredKeyServer arbitrary - puid = fmap PrimaryUserId arbitrary - purl = fmap (PolicyURL . URL . fromMaybe nullURI . parseURI) arbitrary - kfs = fmap KeyFlags arbitrary - suid = fmap SignersUserId arbitrary - rfr = - arbitrary >>= \rc -> - arbitrary >>= \rr -> return (ReasonForRevocation rc rr) - fs = fmap Features arbitrary - st = - arbitrary >>= \pka -> - arbitrary >>= \ha -> - arbitrary >>= \sh -> return (SignatureTarget pka ha sh) - es _ = pure (EmbeddedSignature (SigVOther 5 BL.empty)) - ifp = - elements [IssuerFingerprintV4, IssuerFingerprintV6] >>= \v -> - fmap - (IssuerFingerprint v) - (if v == IssuerFingerprintV6 - then fmap (Fingerprint . BL.pack) (vector 32) - else fmap (Fingerprint . BL.pack) (vector 20)) - udss = - choose (100, 110) >>= \a -> - arbitrary >>= \b -> return (UserDefinedSigSub a b) - oss = - suchThat arbitrary isOtherSigSubType >>= \a -> - arbitrary >>= \b -> return (OtherSigSub a b) - isOtherSigSubType a = - a <= 127 && - a `notElem` - [ 2 - , 3 - , 4 - , 5 - , 6 - , 7 - , 9 - , 11 - , 12 - , 16 - , 20 - , 21 - , 22 - , 23 - , 24 - , 25 - , 26 - , 27 - , 28 - , 29 - , 30 - , 31 - , 32 - , 33 - ] && - (a < 100 || a > 110) + arbitrary = + sized $ \n -> + oneof + ( [ sct + , set + , ec + , ts + , re + , ket + , psa + , rk + , i + , nd + , phas + , pcas + , ksps + , pks + , puid + , purl + , kfs + , suid + , rfr + , fs + , st + , udss + , oss + , ifp + , irfp + , pacs + ] + ++ [es n | n > 0] + ) + where + sct = fmap SigCreationTime arbitrary + set = fmap SigExpirationTime arbitrary + ec = fmap ExportableCertification arbitrary + ts = + arbitrary >>= \tl -> arbitrary >>= \ta -> return (TrustSignature tl ta) + re = fmap RegularExpression arbitrary + ket = fmap KeyExpirationTime arbitrary + psa = fmap PreferredSymmetricAlgorithms arbitrary + rk = + arbitrary >>= \rcs -> + arbitrary >>= \pka -> + fmap (RevocationKey rcs pka . Fingerprint . BL.pack) (vector 20) + i = fmap Issuer arbitrary + nd = + arbitrary >>= \nfs -> + arbitrary >>= \nn -> + arbitrary >>= \nv -> return (NotationData nfs nn nv) + phas = fmap PreferredHashAlgorithms arbitrary + pcas = fmap PreferredCompressionAlgorithms arbitrary + ksps = fmap KeyServerPreferences arbitrary + pks = fmap PreferredKeyServer arbitrary + puid = fmap PrimaryUserId arbitrary + purl = + fmap (PolicyURL . URL . fromMaybe nullURI . parseURI) arbitrary + kfs = fmap KeyFlags arbitrary + suid = fmap SignersUserId arbitrary + rfr = + arbitrary >>= \rc -> + arbitrary >>= \rr -> return (ReasonForRevocation rc rr) + fs = fmap Features arbitrary + st = + arbitrary >>= \pka -> + arbitrary >>= \ha -> + arbitrary >>= \sh -> return (SignatureTarget pka ha sh) + es _ = pure (EmbeddedSignature (SigVOther 5 BL.empty)) + ifp = + elements [IssuerFingerprintV4, IssuerFingerprintV6] >>= \v -> + fmap + (IssuerFingerprint v) + ( if v == IssuerFingerprintV6 + then fmap (Fingerprint . BL.pack) (vector 32) + else fmap (Fingerprint . BL.pack) (vector 20) + ) + irfp = + elements [IssuerFingerprintV4, IssuerFingerprintV6] >>= \v -> + fmap + (IntendedRecipient v) + ( if v == IssuerFingerprintV6 + then fmap (Fingerprint . BL.pack) (vector 32) + else fmap (Fingerprint . BL.pack) (vector 20) + ) + pacs = fmap PreferredAEADCiphersuites arbitrary + udss = + choose (100, 110) >>= \a -> + arbitrary >>= \b -> return (UserDefinedSigSub a b) + oss = + suchThat arbitrary isOtherSigSubType >>= \a -> + arbitrary >>= \b -> return (OtherSigSub a b) + isOtherSigSubType a = + a <= 127 + && a + `notElem` [ 2 + , 3 + , 4 + , 5 + , 6 + , 7 + , 9 + , 11 + , 12 + , 16 + , 20 + , 21 + , 22 + , 23 + , 24 + , 25 + , 26 + , 27 + , 28 + , 29 + , 30 + , 31 + , 32 + , 33 + , 35 + , 39 + ] + && (a < 100 || a > 110) -- instance Arbitrary PubKeyAlgorithm where - arbitrary = elements [RSA, DSA, ECDH, ECDSA, DH, EdDSA] + arbitrary = elements [RSA, DSA, ECDH, ECDSA, DH, EdDSA] instance Arbitrary EightOctetKeyId where - arbitrary = fmap (EightOctetKeyId . BL.pack) (vector 8) + arbitrary = fmap (EightOctetKeyId . BL.pack) (vector 8) instance Arbitrary Fingerprint where - arbitrary = - oneof - [ fmap (Fingerprint . BL.pack) (vector 16) -- v3 - , fmap (Fingerprint . BL.pack) (vector 20) -- v4 - , fmap (Fingerprint . BL.pack) (vector 32) -- v6 - ] + arbitrary = + oneof + [ fmap (Fingerprint . BL.pack) (vector 16) -- v3 + , fmap (Fingerprint . BL.pack) (vector 20) -- v4 + , fmap (Fingerprint . BL.pack) (vector 32) -- v6 + ] instance Arbitrary MPI where - arbitrary = fmap (MPI . getPositive) arbitrary + arbitrary = fmap (MPI . getPositive) arbitrary instance Arbitrary SigType where - arbitrary = - elements - [ BinarySig - , CanonicalTextSig - , StandaloneSig - , GenericCert - , PersonaCert - , CasualCert - , PositiveCert - , SubkeyBindingSig - , PrimaryKeyBindingSig - , SignatureDirectlyOnAKey - , KeyRevocationSig - , SubkeyRevocationSig - , CertRevocationSig - , TimestampSig - , ThirdPartyConfirmationSig - ] + arbitrary = + elements + [ BinarySig + , CanonicalTextSig + , StandaloneSig + , GenericCert + , PersonaCert + , CasualCert + , PositiveCert + , SubkeyBindingSig + , PrimaryKeyBindingSig + , SignatureDirectlyOnAKey + , KeyRevocationSig + , SubkeyRevocationSig + , CertRevocationSig + , TimestampSig + , ThirdPartyConfirmationSig + ] instance Arbitrary HashAlgorithm where - arbitrary = - elements - [ DeprecatedMD5 - , SHA1 - , RIPEMD160 - , SHA256 - , SHA384 - , SHA512 - , SHA224 - , SHA3_256 - , SHA3_512 - ] + arbitrary = + elements + [ DeprecatedMD5 + , SHA1 + , RIPEMD160 + , SHA256 + , SHA384 + , SHA512 + , SHA224 + , SHA3_256 + , SHA3_512 + ] instance Arbitrary SymmetricAlgorithm where - arbitrary = - elements - [ Plaintext - , IDEA - , TripleDES - , CAST5 - , Blowfish - , ReservedSAFER - , ReservedDES - , AES128 - , AES192 - , AES256 - , Twofish - , Camellia128 - , Camellia192 - , Camellia256 - ] + arbitrary = + elements + [ Plaintext + , IDEA + , TripleDES + , CAST5 + , Blowfish + , ReservedSAFER + , ReservedDES + , AES128 + , AES192 + , AES256 + , Twofish + , Camellia128 + , Camellia192 + , Camellia256 + ] +instance Arbitrary AEADAlgorithm where + arbitrary = elements [EAX, OCB, GCM] + instance Arbitrary RevocationClass where - arbitrary = frequency [(9, srk), (1, rco)] - where - srk = return SensitiveRK - rco = fmap mkRevocationClass (choose (2, 6)) + arbitrary = frequency [(9, srk), (1, rco)] + where + srk = return SensitiveRK + rco = fmap mkRevocationClass (choose (2, 6)) instance Arbitrary NotationFlag where - arbitrary = frequency [(9, hr), (1, onf)] - where - hr = return HumanReadable - onf = fmap mkNotationFlag (choose (1, 15)) + arbitrary = frequency [(9, hr), (1, onf)] + where + hr = return HumanReadable + onf = fmap mkNotationFlag (choose (1, 15)) instance Arbitrary CompressionAlgorithm where - arbitrary = elements [Uncompressed, ZIP, ZLIB, BZip2] + arbitrary = elements [Uncompressed, ZIP, ZLIB, BZip2] instance Arbitrary KSPFlag where - arbitrary = frequency [(9, nm), (1, kspo)] - where - nm = return NoModify - kspo = fmap KSPOther (choose (2, 63)) + arbitrary = frequency [(9, nm), (1, kspo)] + where + nm = return NoModify + kspo = fmap KSPOther (choose (2, 63)) instance Arbitrary KeyFlag where - arbitrary = - elements - [ GroupKey - , AuthKey - , SplitKey - , EncryptStorageKey - , EncryptCommunicationsKey - , SignDataKey - , CertifyKeysKey - ] + arbitrary = + elements + [ GroupKey + , AuthKey + , SplitKey + , EncryptStorageKey + , EncryptCommunicationsKey + , SignDataKey + , CertifyKeysKey + ] instance Arbitrary RevocationCode where - arbitrary = - elements - [ NoReason - , KeySuperseded - , KeyMaterialCompromised - , KeyRetiredAndNoLongerUsed - , UserIdInfoNoLongerValid - ] + arbitrary = + elements + [ NoReason + , KeySuperseded + , KeyMaterialCompromised + , KeyRetiredAndNoLongerUsed + , UserIdInfoNoLongerValid + ] instance Arbitrary FeatureFlag where - arbitrary = frequency [(8, seipdV1), (1, seipdV2), (1, fo)] - where - seipdV1 = return FeatureSEIPDv1 - seipdV2 = return FeatureSEIPDv2 - fo = fmap FeatureOther (suchThat (choose (0, 63)) (`notElem` [4, 7])) + arbitrary = frequency [(8, seipdV1), (1, seipdV2), (1, fo)] + where + seipdV1 = return FeatureSEIPDv1 + seipdV2 = return FeatureSEIPDv2 + fo = + fmap FeatureOther (suchThat (choose (0, 63)) (`notElem` [4, 7])) instance Arbitrary ThirtyTwoBitTimeStamp where - arbitrary = fmap ThirtyTwoBitTimeStamp arbitrary + arbitrary = fmap ThirtyTwoBitTimeStamp arbitrary instance Arbitrary ThirtyTwoBitDuration where - arbitrary = fmap ThirtyTwoBitDuration arbitrary + arbitrary = fmap ThirtyTwoBitDuration arbitrary instance Arbitrary NotationName where - arbitrary = fmap NotationName arbitrary + arbitrary = fmap NotationName arbitrary instance Arbitrary NotationValue where - arbitrary = fmap NotationValue arbitrary + arbitrary = fmap NotationValue arbitrary + +instance Arbitrary Padding where + arbitrary = fmap Padding arbitrary diff --git a/Codec/Encryption/OpenPGP/Encrypt.hs b/Codec/Encryption/OpenPGP/Encrypt.hs --- a/Codec/Encryption/OpenPGP/Encrypt.hs +++ b/Codec/Encryption/OpenPGP/Encrypt.hs @@ -2,2418 +2,2935 @@ -- Copyright © 2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} - -module Codec.Encryption.OpenPGP.Encrypt - ( PKESKEncryptError(..) - , RecipientCapabilityNegotiationMode(..) - , RecipientCapabilityError(..) - , renderRecipientCapabilityError - , RecipientCapabilities(..) - , recipientCapabilitiesFromSubpacketPayloads - , recipientCapabilitySupportsEncryption - , RecipientTargetRejectionReason(..) - , RecipientEncryptionTargetRejected(..) - , RecipientEncryptionTargetsReport(..) - , recipientEncryptionTargetsReportFromTKAtTimestamp - , recipientEncryptionTargetsReportFromTK - , recipientEncryptionTargetFromTKAtTimestamp - , recipientEncryptionTargetFromTKAtTimestampWithPolicy - , recipientEncryptionTargetsFromTKAtTimestamp - , recipientEncryptionTargetFromTK - , recipientEncryptionTargetFromTKWithPolicy - , recipientEncryptionTargetsFromTK - , RecipientTargetSelectionPolicy(..) - , PassphraseSKESKVersionPolicy(..) - , PassphraseEncryptRequest(..) - , encryptPassphraseWithPolicy - , PKESKVersionPolicy(..) - , RecipientPKESKVersionStrategy(..) - , RecipientPKESKVersionStrategyW(..) - , SomeRecipientPKESKVersionStrategyW(..) - , RecipientPKESKVersionSelector - , RecipientPKESKVersionSelectorTyped - , EncryptCompatibilityProfile(..) - , EncryptCompatibilityProfileW(..) - , SomeEncryptCompatibilityProfileW(..) - , RecipientEncryptionTarget(..) - , recipientEncryptionTarget - , recipientEncryptionTargetWithStrategy - , recipientEncryptionTargetWithCapabilities - , recipientEncryptionTargetWithStrategyTyped - , recipientVersionStrategyForProfile - , recipientVersionStrategyForProfileTyped - , RecipientPayloadShape(..) - , defaultRecipientPayloadShape - , SEIPDVersion(..) - , RecipientEncryptResult(..) - , RecipientEncryptRequest(..) - , RecipientEncryptRequestOverrides(..) - , encryptForRecipients - , encryptForRecipientsLegacy - , encryptForRecipientsWithCapabilityNegotiation - , PKESKV3SessionMaterial - , PKESKV6RawSessionMaterial - , PKESKSessionMaterial - , pkeskSessionAlgorithm - , pkeskSessionKey - , mkPKESKSessionMaterial - , mkPKESKV3SessionMaterial - , mkPKESKV6RawSessionMaterial - , pkeskV3SessionMaterial - , pkeskV6RawSessionMaterial - , encodeOpenPGPSessionMaterial - , generateSessionKeyMaterial - , canonicalizePKESKRecipientId - , canonicalizePKESKPacketRecipientIds - , buildPKESKv3PayloadForRecipient - , buildPKESKv3PktForRecipient - , buildPKESKPayloadForRecipient - , buildPKESKPktForRecipient - , buildPKESKPktsForRecipientTargetsWithSelector - , buildPKESKPktsForRecipientTargetsWithSelectorTyped - , encryptSEIPDv2Payload - , encryptSEIPDv1Payload - , encryptSEIPDv2WithSKESK - , encryptSEIPDv2WithSKESKBlock - , encryptSEIPDv2LiteralDataWithSKESK - , composeMessageWithSEIPDv2 - ) where - -import Codec.Encryption.OpenPGP.BlockCipher (CipherError, renderCipherError, keySize, withSymmetricCipher) -import Codec.Encryption.OpenPGP.CFB - ( OpenPGPCFBModeW(..) - , encryptOpenPGPCfbRaw - , mdcTrailerForSEIPDv1 - ) -import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..)) -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) -import Codec.Encryption.OpenPGP.Internal (leftPadTo, point2MBS) -import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher) -import Codec.Encryption.OpenPGP.Internal.CryptoECDH - ( normalizeMontgomeryPublic - , buildECDHKDFParam - , deriveECDHKek - ) -import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 - ( aeadModeAndNonceSizeForSEIPDv2 - , deriveSKESK6KEK - , encryptSKESK6SessionKey - , seipdv2SymmetricKeySize - ) -import Codec.Encryption.OpenPGP.Policy - ( PKESKVersionPolicy(..) - , OpenPGPRFC(..) - , MessageEncryptionPolicy - , policyForRFC - , policyMessageEncryption - , messageDefaultSymmetricAlgorithm - , messageSEIPDv2SymmetricAlgorithms - , messageDefaultAEADAlgorithm - , messageDefaultChunkSize - , messageSEIPDv2SaltOctets - , defaultPKESKVersionPolicy - ) -import Codec.Encryption.OpenPGP.Expirations - ( effectiveKeyPreferencesAtTimestamp - , isPKTimeValidWithSelfSignatures - , keyStateAt - , keyStateValid - , signatureEffectiveAt - ) -import Codec.Encryption.OpenPGP.Ontology (isSubkeyBindingSig, isSubkeyRevocation) -import Codec.Encryption.OpenPGP.SignatureQualities (sigCT, signatureHashedSubpacketsKnown) -import Codec.Encryption.OpenPGP.Serialize () -import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key) -import Codec.Encryption.OpenPGP.Types -import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes -import Codec.Encryption.OpenPGP.Internal.RFC7253OCB (encryptWithOCBRFC7253) -import Control.Applicative ((<|>)) -import Control.Lens ((.~), ix) -import Control.Monad (when) -import Data.List (find, foldl', maximumBy) -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) -import Data.Ord (comparing) -import Data.Time.Clock (UTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import qualified "crypton" Crypto.Cipher.Types as CCT -import qualified Crypto.Error as CE -import qualified Crypto.Hash.Algorithms as CHAlg -import Crypto.KDF.HKDF (expand, extract) -import Crypto.Number.Serialize (i2osp, os2ip) -import qualified Crypto.PubKey.Curve25519 as C25519 -import qualified Crypto.PubKey.Curve448 as C448 -import qualified Crypto.PubKey.ECC.DH as ECCDH -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.ECC.Generate as ECCGen -import qualified Crypto.PubKey.RSA.PKCS15 as RSA15 -import Crypto.Random.Types (MonadRandom, getRandomBytes) -import Data.Binary (put) -import qualified Data.ByteArray as BA -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Bits ((.&.), shiftL, shiftR, xor) -import Data.Binary.Put (putWord64be, runPut) -import Data.Bifunctor (first) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.Set as Set -import Data.Word (Word8, Word16, Word64) -import Data.Int (Int64) - --- | Typed failures from one-pass signature packet construction. -data OPSBuildError - = OPSBuildMissingIssuerKeyId - | OPSBuildMissingIssuerFingerprint - | OPSBuildFingerprintWrongLength Int64 - | OPSBuildUnsupportedSigVersion PacketVersion - deriving (Eq, Show) - -renderOPSBuildError :: OPSBuildError -> String -renderOPSBuildError OPSBuildMissingIssuerKeyId = - "cannot build OPS3 packet from v4 signature without issuer metadata" -renderOPSBuildError OPSBuildMissingIssuerFingerprint = - "cannot build OPS6 packet from v6 signature without issuer fingerprint" -renderOPSBuildError (OPSBuildFingerprintWrongLength n) = - "cannot build OPS6 packet: issuer fingerprint must be 32 octets, got " ++ show n -renderOPSBuildError (OPSBuildUnsupportedSigVersion v) = - "cannot build one-pass signature packet for unsupported signature version " ++ show v - --- | Typed failures surfaced by encrypt-side PKESK and SEIPD-v2 helpers. -data PKESKEncryptError - = UnsupportedSessionKeyAlgorithm SymmetricAlgorithm String - | InvalidSessionKeyLength SymmetricAlgorithm Int Int - | InvalidRecipientIdentifier String - | UnsupportedRecipientAlgorithm PubKeyAlgorithm - | InvalidRecipientKeyMaterial PubKeyAlgorithm String - | RecipientKdfFailure PubKeyAlgorithm String - | RecipientKeyWrapFailure PubKeyAlgorithm String - | RecipientCapabilitySelectionFailure RecipientCapabilityError - | PayloadBuildFailure String - | NoRecipientsProvided - deriving (Eq, Show) - -renderPKESKEncryptError :: PKESKEncryptError -> String -renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm algo reason) = - "unsupported session key algorithm " ++ show algo ++ ": " ++ reason -renderPKESKEncryptError (InvalidSessionKeyLength algo expected actual) = - "invalid session key length for " ++ show algo ++ ": expected " ++ show expected ++ ", got " ++ show actual -renderPKESKEncryptError (InvalidRecipientIdentifier reason) = - "invalid recipient identifier: " ++ reason -renderPKESKEncryptError (UnsupportedRecipientAlgorithm algo) = - "unsupported recipient public-key algorithm: " ++ show algo -renderPKESKEncryptError (InvalidRecipientKeyMaterial algo reason) = - "invalid recipient key material for " ++ show algo ++ ": " ++ reason -renderPKESKEncryptError (RecipientKdfFailure algo reason) = - "KDF failure for recipient algorithm " ++ show algo ++ ": " ++ reason -renderPKESKEncryptError (RecipientKeyWrapFailure algo reason) = - "key wrap failure for recipient algorithm " ++ show algo ++ ": " ++ reason -renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) = - renderRecipientCapabilityError err -renderPKESKEncryptError (PayloadBuildFailure reason) = - "payload build failure: " ++ reason -renderPKESKEncryptError NoRecipientsProvided = - "no recipients provided" - -data RecipientCapabilityNegotiationMode - = RecipientCapabilityNegotiationOff - | RecipientCapabilityNegotiationOn - deriving (Eq, Show) - -data RecipientCapabilityError - = RecipientCapabilityMissingEncryptionFlags SomePKPayload (Set.Set KeyFlag) - | RecipientCapabilityNoEncryptableKeyMaterialInTK - | RecipientCapabilityMissingSEIPDv1Support [SomePKPayload] - | RecipientCapabilityMissingSEIPDv2Support [SomePKPayload] - | RecipientCapabilityNoCommonSymmetricAlgorithms [SymmetricAlgorithm] - | RecipientCapabilityNoCommonAEADAlgorithms [AEADAlgorithm] - deriving (Eq, Show) - -renderRecipientCapabilityError :: RecipientCapabilityError -> String -renderRecipientCapabilityError (RecipientCapabilityMissingEncryptionFlags recipient flags) = - "recipient " ++ show (_keyVersion recipient, _pkalgo recipient) ++ - " does not advertise encryption-capable key flags; observed flags: " ++ - show (Set.toList flags) -renderRecipientCapabilityError RecipientCapabilityNoEncryptableKeyMaterialInTK = - "no encryption-capable primary key or subkey was found in transferable key material" -renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv1Support recipients) = - "recipient set does not advertise SEIPDv1 (MDC) support: " ++ - show (map (\r -> (_keyVersion r, _pkalgo r)) recipients) -renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv2Support recipients) = - "recipient set does not advertise SEIPDv2 support: " ++ - show (map (\r -> (_keyVersion r, _pkalgo r)) recipients) -renderRecipientCapabilityError (RecipientCapabilityNoCommonSymmetricAlgorithms syms) = - "no common recipient-supported symmetric algorithms: " ++ show syms -renderRecipientCapabilityError (RecipientCapabilityNoCommonAEADAlgorithms aeads) = - "no common recipient-supported AEAD algorithms: " ++ show aeads - -data RecipientCapabilities = - RecipientCapabilities - { recipientCapabilityKeyVersion :: KeyVersion - , recipientCapabilityPublicKeyAlgorithm :: PubKeyAlgorithm - , recipientCapabilityKeyFlags :: Set.Set KeyFlag - , recipientCapabilityFeatures :: Set.Set FeatureFlag - , recipientCapabilityPreferredSymmetricAlgorithms :: [SymmetricAlgorithm] - , recipientCapabilityPreferredAEADAlgorithms :: [AEADAlgorithm] - } - deriving (Eq, Show) - -data RecipientTargetRejectionReason - = RecipientTargetUnsupportedAlgorithm PubKeyAlgorithm - | RecipientTargetMissingEncryptionFlags SomePKPayload (Set.Set KeyFlag) - | RecipientTargetRevoked SomePKPayload - | RecipientTargetNotValidAtTimestamp SomePKPayload ThirtyTwoBitTimeStamp - deriving (Eq, Show) - -data RecipientEncryptionTargetRejected = - RecipientEncryptionTargetRejected - { recipientEncryptionTargetRejectedKey :: SomePKPayload - , recipientEncryptionTargetRejectedCapabilities :: Maybe RecipientCapabilities - , recipientEncryptionTargetRejectedReason :: RecipientTargetRejectionReason - } - deriving (Eq, Show) - -data RecipientEncryptionTargetsReport = - RecipientEncryptionTargetsReport - { recipientEncryptionTargetsAccepted :: [RecipientEncryptionTarget] - , recipientEncryptionTargetsRejected :: [RecipientEncryptionTargetRejected] - } - deriving (Eq, Show) - --- | Extract encrypt-relevant recipient capabilities from effective --- self-signature subpackets. --- --- RFC 9580 preferred AEAD ciphersuites are currently carried through --- 'OtherSigSub' type 39 and decoded into AEAD preferences here. -recipientCapabilitiesFromSubpacketPayloads :: - SomePKPayload - -> [SigSubPacketPayload] - -> RecipientCapabilities -recipientCapabilitiesFromSubpacketPayloads recipient payloads = - foldl' step (emptyRecipientCapabilities recipient) payloads - where - preferredAEADCiphersuitesSubpacketType :: Word8 - preferredAEADCiphersuitesSubpacketType = 39 - - step caps payload = - case payload of - KeyFlags flags -> - caps - { recipientCapabilityKeyFlags = - recipientCapabilityKeyFlags caps `Set.union` flags - } - Features features -> - caps - { recipientCapabilityFeatures = - recipientCapabilityFeatures caps `Set.union` features - } - PreferredSymmetricAlgorithms syms -> - caps - { recipientCapabilityPreferredSymmetricAlgorithms = - recipientCapabilityPreferredSymmetricAlgorithms caps ++ syms - } - OtherSigSub subpacketType rawPayload - | subpacketType == preferredAEADCiphersuitesSubpacketType -> - caps - { recipientCapabilityPreferredAEADAlgorithms = - recipientCapabilityPreferredAEADAlgorithms caps ++ - preferredAEADAlgorithmsFromCiphersuites rawPayload - } - _ -> caps - - emptyRecipientCapabilities key = - RecipientCapabilities - { recipientCapabilityKeyVersion = _keyVersion key - , recipientCapabilityPublicKeyAlgorithm = _pkalgo key - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.empty - , recipientCapabilityPreferredSymmetricAlgorithms = [] - , recipientCapabilityPreferredAEADAlgorithms = [] - } - - preferredAEADAlgorithmsFromCiphersuites :: BL.ByteString -> [AEADAlgorithm] - preferredAEADAlgorithmsFromCiphersuites = - dedupePreservingOrder . parsePairs . BL.unpack - where - parsePairs (_symAlgo:aeadAlgo:rest) = - (toFVal aeadAlgo :: AEADAlgorithm) : parsePairs rest - parsePairs _ = [] - - dedupePreservingOrder = foldl' addIfMissing [] - addIfMissing acc x - | x `elem` acc = acc - | otherwise = acc ++ [x] - -recipientCapabilitySupportsEncryption :: RecipientCapabilities -> Bool -recipientCapabilitySupportsEncryption caps = - let flags = recipientCapabilityKeyFlags caps - in Set.null flags || - Set.member EncryptStorageKey flags || - Set.member EncryptCommunicationsKey flags - -recipientCapabilityAdvertisesSEIPDv1Support :: RecipientCapabilities -> Bool -recipientCapabilityAdvertisesSEIPDv1Support caps = - let features = recipientCapabilityFeatures caps - in Set.null features || Set.member FeatureSEIPDv1 features - -recipientCapabilityAdvertisesSEIPDv2Support :: RecipientCapabilities -> Bool -recipientCapabilityAdvertisesSEIPDv2Support caps = - recipientCapabilityAdvertisesSEIPDv1Support caps && - Set.member FeatureSEIPDv2 (recipientCapabilityFeatures caps) - -recipientEncryptionTargetFromTKAtTimestamp :: - ThirtyTwoBitTimeStamp - -> TKUnknown - -> Either RecipientCapabilityError RecipientEncryptionTarget -recipientEncryptionTargetFromTKAtTimestamp timestamp tk = - recipientEncryptionTargetFromTKAtTimestampWithPolicy - RecipientTargetSelectionFirstValid - timestamp - tk - -data RecipientTargetSelectionPolicy - = RecipientTargetSelectionFirstValid - | RecipientTargetSelectionPreferPrimary - | RecipientTargetSelectionPreferSubkey - | RecipientTargetSelectionPreferNewestCreationTime - deriving (Eq, Show) - -recipientEncryptionTargetFromTKAtTimestampWithPolicy :: - RecipientTargetSelectionPolicy - -> ThirtyTwoBitTimeStamp - -> TKUnknown - -> Either RecipientCapabilityError RecipientEncryptionTarget -recipientEncryptionTargetFromTKAtTimestampWithPolicy policy timestamp tk = - case chooseRecipientTarget policy tk acceptedTargets of - Just target -> Right target - Nothing -> Left RecipientCapabilityNoEncryptableKeyMaterialInTK - where - acceptedTargets = - recipientEncryptionTargetsAccepted - (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) - -recipientEncryptionTargetFromTK :: TK 'PublicTK -> Either RecipientCapabilityError RecipientEncryptionTarget -recipientEncryptionTargetFromTK tk = - recipientEncryptionTargetFromTKAtTimestampWithPolicy - RecipientTargetSelectionFirstValid - (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) - (tkToUnknown tk) - -recipientEncryptionTargetFromTKWithPolicy :: - RecipientTargetSelectionPolicy - -> TK 'PublicTK - -> Either RecipientCapabilityError RecipientEncryptionTarget -recipientEncryptionTargetFromTKWithPolicy policy tk = - recipientEncryptionTargetFromTKAtTimestampWithPolicy - policy - (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) - (tkToUnknown tk) - -recipientEncryptionTargetsFromTKAtTimestamp :: - ThirtyTwoBitTimeStamp - -> TKUnknown - -> [RecipientEncryptionTarget] -recipientEncryptionTargetsFromTKAtTimestamp timestamp tk = - recipientEncryptionTargetsAccepted (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) - -recipientEncryptionTargetsReportFromTKAtTimestamp :: - ThirtyTwoBitTimeStamp - -> TKUnknown - -> RecipientEncryptionTargetsReport -recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk = - foldr classifyCandidate emptyReport (subkeyCandidates ++ [primaryCandidate]) - where - emptyReport = RecipientEncryptionTargetsReport [] [] - primaryCandidate = fst (_tkuKey tk) - primaryPreferencePayloads = - fromMaybe [] (effectiveKeyPreferencesAtTimestamp timestamp tk) - subkeyCandidates = - mapMaybe - (\(pkt, _) -> - case pkt of - PublicSubkeyPkt pkp -> Just pkp - SecretSubkeyPkt pkp _ -> Just pkp - _ -> Nothing) - (_tkuSubs tk) - classifyCandidate key report = - let caps = - recipientCapabilitiesFromSubpacketPayloads - key - (primaryPreferencePayloads ++ subkeyBindingCapabilityPayloads timestamp tk key) - keyStateRejection = recipientValidityRejectionReason timestamp tk key - in case keyStateRejection of - Just rejectionReason -> - report - { recipientEncryptionTargetsRejected = - RecipientEncryptionTargetRejected - { recipientEncryptionTargetRejectedKey = key - , recipientEncryptionTargetRejectedCapabilities = Just caps - , recipientEncryptionTargetRejectedReason = rejectionReason - } : - recipientEncryptionTargetsRejected report - } - Nothing -> - if not (supportsPKESKRecipientAlgorithm key) - then - report - { recipientEncryptionTargetsRejected = - RecipientEncryptionTargetRejected - { recipientEncryptionTargetRejectedKey = key - , recipientEncryptionTargetRejectedCapabilities = Just caps - , recipientEncryptionTargetRejectedReason = - RecipientTargetUnsupportedAlgorithm (_pkalgo key) - } : - recipientEncryptionTargetsRejected report - } - else - if recipientCapabilitySupportsEncryption caps - then - report - { recipientEncryptionTargetsAccepted = - recipientEncryptionTargetWithCapabilities key caps : - recipientEncryptionTargetsAccepted report - } - else - report - { recipientEncryptionTargetsRejected = - RecipientEncryptionTargetRejected - { recipientEncryptionTargetRejectedKey = key - , recipientEncryptionTargetRejectedCapabilities = Just caps - , recipientEncryptionTargetRejectedReason = - RecipientTargetMissingEncryptionFlags key (recipientCapabilityKeyFlags caps) - } : - recipientEncryptionTargetsRejected report - } - -recipientEncryptionTargetsFromTK :: TK 'PublicTK -> [RecipientEncryptionTarget] -recipientEncryptionTargetsFromTK tk = - recipientEncryptionTargetsFromTKAtTimestamp - (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) - (tkToUnknown tk) - -recipientEncryptionTargetsReportFromTK :: TK 'PublicTK -> RecipientEncryptionTargetsReport -recipientEncryptionTargetsReportFromTK tk = - recipientEncryptionTargetsReportFromTKAtTimestamp - (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) - (tkToUnknown tk) - -subkeyBindingCapabilityPayloads :: - ThirtyTwoBitTimeStamp - -> TKUnknown - -> SomePKPayload - -> [SigSubPacketPayload] -subkeyBindingCapabilityPayloads timestamp tk recipient = - maybe [] latestEffectiveBindingPayloads matchingSubkey - where - matchingSubkey = - find - (\(pkt, _) -> - case pkt of - PublicSubkeyPkt pkp -> fingerprint pkp == fingerprint recipient - SecretSubkeyPkt pkp _ -> fingerprint pkp == fingerprint recipient - _ -> False) - (_tkuSubs tk) - latestEffectiveBindingPayloads (_, sigs) = - maybe [] signaturePayloadsFromSignature (latestEffectiveSubkeyBindingSignature timestamp sigs) - -latestEffectiveSubkeyBindingSignature :: - ThirtyTwoBitTimeStamp - -> [SignaturePayload] - -> Maybe SignaturePayload -latestEffectiveSubkeyBindingSignature timestamp sigs = - case filter (isEffectiveSubkeyBindingSignature timestamp) sigs of - [] -> Nothing - candidates -> Just (maximumBy (comparing signatureCreationTimestamp) candidates) - -isEffectiveSubkeyBindingSignature :: - ThirtyTwoBitTimeStamp - -> SignaturePayload - -> Bool -isEffectiveSubkeyBindingSignature timestamp sig = - isSubkeyBindingSig sig && - maybe False - (\created -> - let tsValue = toInteger (unThirtyTwoBitTimeStamp timestamp) - createdValue = toInteger (unThirtyTwoBitTimeStamp created) - in createdValue <= tsValue && - maybe True - (\duration -> - if unThirtyTwoBitDuration duration == 0 - then True - else tsValue < createdValue + toInteger (unThirtyTwoBitDuration duration)) - (signatureExpirationDuration sig)) - (sigCT sig) - -signatureCreationTimestamp :: SignaturePayload -> ThirtyTwoBitTimeStamp -signatureCreationTimestamp sig = - fromMaybe (ThirtyTwoBitTimeStamp 0) (sigCT sig) - -signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration -signatureExpirationDuration sig = - case signatureHashedSubpacketsKnown sig of - Just hashed -> - foldr - (\subpacket acc -> - case subpacket of - SigSubPacket _ (SigExpirationTime duration) -> Just duration - _ -> acc) - Nothing - hashed - Nothing -> Nothing - -signaturePayloadsFromSignature :: SignaturePayload -> [SigSubPacketPayload] -signaturePayloadsFromSignature sig = - case signatureHashedSubpacketsKnown sig of - Just hashed -> map (\(SigSubPacket _ payload) -> payload) hashed - Nothing -> [] - -recipientValidityRejectionReason :: - ThirtyTwoBitTimeStamp - -> TKUnknown - -> SomePKPayload - -> Maybe RecipientTargetRejectionReason -recipientValidityRejectionReason timestamp tk key - | fingerprint key == fingerprint (fst (_tkuKey tk)) = - if keyStateValid (keyStateAt (timestampToUTC timestamp) tk) - then Nothing - else Just (RecipientTargetNotValidAtTimestamp key timestamp) - | otherwise = - case findMatchingSubkeySignatures tk key of - Nothing -> Nothing - Just sigs - | subkeyRevokedAtTimestamp timestamp sigs -> - Just (RecipientTargetRevoked key) - | isPKTimeValidWithSelfSignatures (timestampToUTC timestamp) key sigs -> - Nothing - | otherwise -> - Just (RecipientTargetNotValidAtTimestamp key timestamp) - -findMatchingSubkeySignatures :: TKUnknown -> SomePKPayload -> Maybe [SignaturePayload] -findMatchingSubkeySignatures tk recipient = - snd <$> - find - (\(pkt, _) -> - case pkt of - PublicSubkeyPkt pkp -> fingerprint pkp == fingerprint recipient - SecretSubkeyPkt pkp _ -> fingerprint pkp == fingerprint recipient - _ -> False) - (_tkuSubs tk) - -subkeyRevokedAtTimestamp :: ThirtyTwoBitTimeStamp -> [SignaturePayload] -> Bool -subkeyRevokedAtTimestamp timestamp = - any (\sig -> isSubkeyRevocation sig && signatureEffectiveAt (timestampToUTC timestamp) sig) - -timestampToUTC :: ThirtyTwoBitTimeStamp -> UTCTime -timestampToUTC = - posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp - -supportsPKESKRecipientAlgorithm :: SomePKPayload -> Bool -supportsPKESKRecipientAlgorithm recipient = - case _pkalgo recipient of - RSA -> True - DeprecatedRSAEncryptOnly -> True - ECDH -> True - X25519 -> True - X448 -> True - _ -> False - -chooseRecipientTarget :: - RecipientTargetSelectionPolicy - -> TKUnknown - -> [RecipientEncryptionTarget] - -> Maybe RecipientEncryptionTarget -chooseRecipientTarget policy tk targets = - case policy of - RecipientTargetSelectionFirstValid -> listToMaybe targets - RecipientTargetSelectionPreferPrimary -> - listToMaybe (filter (isPrimaryTarget tk) targets) <|> listToMaybe targets - RecipientTargetSelectionPreferSubkey -> - listToMaybe (filter (not . isPrimaryTarget tk) targets) <|> listToMaybe targets - RecipientTargetSelectionPreferNewestCreationTime -> - case targets of - [] -> Nothing - (target:rest) -> - Just - (foldl' - (\best candidate -> - if _timestamp (recipientEncryptionTargetKey candidate) > - _timestamp (recipientEncryptionTargetKey best) - then candidate - else best) - target - rest) - where - isPrimaryTarget currentTK target = - fingerprint (recipientEncryptionTargetKey target) == - fingerprint (fst (_tkuKey currentTK)) - --- | Session-key bundle for PKESK/SKESK packet construction. -newtype PKESKV3SessionMaterial = - PKESKV3SessionMaterial - { unPKESKV3SessionMaterial :: B.ByteString - } - deriving (Eq, Show) - -newtype PKESKV6RawSessionMaterial = - PKESKV6RawSessionMaterial - { unPKESKV6RawSessionMaterial :: B.ByteString - } - deriving (Eq, Show) - -data PKESKSessionMaterial = - PKESKSessionMaterial - { pkeskSessionAlgorithm :: SymmetricAlgorithm - , pkeskSessionKey :: SessionKey - , pkeskEncodedSessionMaterial :: B.ByteString - } - deriving (Eq, Show) - -mkPKESKSessionMaterial :: - SymmetricAlgorithm - -> SessionKey - -> Either PKESKEncryptError PKESKSessionMaterial -mkPKESKSessionMaterial symalgo sessionKey = do - v3Material <- mkPKESKV3SessionMaterial symalgo sessionKey - _v6Material <- mkPKESKV6RawSessionMaterial symalgo sessionKey - pure - PKESKSessionMaterial - { pkeskSessionAlgorithm = symalgo - , pkeskSessionKey = sessionKey - , pkeskEncodedSessionMaterial = unPKESKV3SessionMaterial v3Material - } - -mkPKESKV3SessionMaterial :: - SymmetricAlgorithm - -> SessionKey - -> Either PKESKEncryptError PKESKV3SessionMaterial -mkPKESKV3SessionMaterial symalgo sessionKey = do - keyBytes <- validatedSessionKeyBytes symalgo sessionKey - pure $ - PKESKV3SessionMaterial - (B.singleton (fromFVal symalgo) <> keyBytes <> checksum16Bytes keyBytes) - -mkPKESKV6RawSessionMaterial :: - SymmetricAlgorithm - -> SessionKey - -> Either PKESKEncryptError PKESKV6RawSessionMaterial -mkPKESKV6RawSessionMaterial symalgo sessionKey = - PKESKV6RawSessionMaterial <$> validatedSessionKeyBytes symalgo sessionKey - -pkeskV3SessionMaterial :: PKESKSessionMaterial -> PKESKV3SessionMaterial -pkeskV3SessionMaterial = - PKESKV3SessionMaterial . pkeskEncodedSessionMaterial - -pkeskV6RawSessionMaterial :: PKESKSessionMaterial -> PKESKV6RawSessionMaterial -pkeskV6RawSessionMaterial = - PKESKV6RawSessionMaterial . unSessionKey . pkeskSessionKey - -validatedSessionKeyBytes :: - SymmetricAlgorithm - -> SessionKey - -> Either PKESKEncryptError B.ByteString -validatedSessionKeyBytes symalgo (SessionKey sessionKey) = do - keyLen <- - first - (UnsupportedSessionKeyAlgorithm symalgo . renderCipherError) - (keySize symalgo) - let actualLen = B.length sessionKey - if actualLen /= keyLen - then Left (InvalidSessionKeyLength symalgo keyLen actualLen) - else Right sessionKey - -data RecipientPKESKVersionStrategy - = RecipientPreferV6 - | RecipientForceV3Interop - deriving (Eq, Show) - -data RecipientPKESKVersionStrategyW (strategy :: RecipientPKESKVersionStrategy) where - RecipientPreferV6W :: RecipientPKESKVersionStrategyW 'RecipientPreferV6 - RecipientForceV3InteropW :: RecipientPKESKVersionStrategyW 'RecipientForceV3Interop - -data SomeRecipientPKESKVersionStrategyW where - SomeRecipientPKESKVersionStrategyW :: - RecipientPKESKVersionStrategyW strategy - -> SomeRecipientPKESKVersionStrategyW - -type RecipientPKESKVersionSelector = - SomePKPayload -> Either PKESKEncryptError RecipientPKESKVersionStrategy - -type RecipientPKESKVersionSelectorTyped = - SomePKPayload -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW - -data EncryptCompatibilityProfile - = EncryptStrictDefault - | EncryptInteropLegacy - deriving (Eq, Show) - -data EncryptCompatibilityProfileW (profile :: EncryptCompatibilityProfile) where - EncryptStrictDefaultW :: EncryptCompatibilityProfileW 'EncryptStrictDefault - EncryptInteropLegacyW :: EncryptCompatibilityProfileW 'EncryptInteropLegacy - -data SomeEncryptCompatibilityProfileW where - SomeEncryptCompatibilityProfileW :: - EncryptCompatibilityProfileW profile - -> SomeEncryptCompatibilityProfileW - -data SEIPDVersion - = SEIPDv1 - | SEIPDv2 - deriving (Eq, Show) - -type family PayloadVersionForProfile (profile :: EncryptCompatibilityProfile) :: SEIPDVersion where - PayloadVersionForProfile 'EncryptStrictDefault = 'SEIPDv2 - PayloadVersionForProfile 'EncryptInteropLegacy = 'SEIPDv1 - -type family ProfileForPayloadVersion (version :: SEIPDVersion) :: EncryptCompatibilityProfile where - ProfileForPayloadVersion 'SEIPDv1 = 'EncryptInteropLegacy - ProfileForPayloadVersion 'SEIPDv2 = 'EncryptStrictDefault - -data RecipientEncryptionTarget = - RecipientEncryptionTarget - { -- | Recipient key packet selected for PKESK wrapping. - recipientEncryptionTargetKey :: SomePKPayload - -- | Optional explicit PKESK version strategy hint. - -- When absent, profile defaults and auto-detection apply. - , recipientEncryptionTargetStrategy :: Maybe RecipientPKESKVersionStrategy - -- | Optional recipient capability hints used by negotiation-enabled - -- encryption to choose common symmetric/AEAD algorithms. - , recipientEncryptionTargetCapabilities :: Maybe RecipientCapabilities - } - deriving (Eq, Show) - -recipientEncryptionTarget :: SomePKPayload -> RecipientEncryptionTarget -recipientEncryptionTarget recipient = - RecipientEncryptionTarget recipient Nothing Nothing - -recipientEncryptionTargetWithStrategy :: SomePKPayload -> RecipientPKESKVersionStrategy -> RecipientEncryptionTarget -recipientEncryptionTargetWithStrategy recipient strategy = - RecipientEncryptionTarget recipient (Just strategy) Nothing - -recipientEncryptionTargetWithCapabilities :: - SomePKPayload - -> RecipientCapabilities - -> RecipientEncryptionTarget -recipientEncryptionTargetWithCapabilities recipient capabilities = - RecipientEncryptionTarget recipient Nothing (Just capabilities) - -recipientEncryptionTargetWithStrategyTyped :: SomePKPayload - -> RecipientPKESKVersionStrategyW strategy - -> RecipientEncryptionTarget -recipientEncryptionTargetWithStrategyTyped recipient strategyW = - recipientEncryptionTargetWithStrategy recipient (demoteRecipientStrategy strategyW) - -recipientVersionStrategyForProfile :: - EncryptCompatibilityProfile - -> RecipientEncryptionTarget - -> Either PKESKEncryptError RecipientPKESKVersionStrategy -recipientVersionStrategyForProfile profile target = - case promoteEncryptCompatibilityProfile profile of - SomeEncryptCompatibilityProfileW profileW -> - demoteSomeRecipientStrategy <$> - recipientVersionStrategyForProfileTyped profileW target - -recipientVersionStrategyForProfileTyped :: - EncryptCompatibilityProfileW profile - -> RecipientEncryptionTarget - -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW -recipientVersionStrategyForProfileTyped profile target = - Right $ - case recipientEncryptionTargetStrategy target of - Just strategy -> - promoteRecipientStrategy strategy - Nothing -> - case profile of - EncryptStrictDefaultW -> - autoDetectRecipientVersionStrategy - (recipientEncryptionTargetKey target) - EncryptInteropLegacyW -> - SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW - -profileForPayloadVersionW :: - RecipientEncryptRequestOverrides version - -> EncryptCompatibilityProfileW (ProfileForPayloadVersion version) -profileForPayloadVersionW overrides = - case overrides of - RecipientEncryptRequestSEIPDv2Overrides {} -> EncryptStrictDefaultW - RecipientEncryptRequestSEIPDv1Overrides {} -> EncryptInteropLegacyW - -autoDetectRecipientVersionStrategy :: SomePKPayload - -> SomeRecipientPKESKVersionStrategyW -autoDetectRecipientVersionStrategy recipient - | _keyVersion recipient == V6 = - SomeRecipientPKESKVersionStrategyW RecipientPreferV6W - | _pkalgo recipient `elem` [X25519, X448] = - SomeRecipientPKESKVersionStrategyW RecipientPreferV6W - | otherwise = - SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW - -data RecipientPayloadShape = - RecipientPayloadShape - { recipientPayloadDataType :: DataType - , recipientPayloadFileName :: FileName - , recipientPayloadTimestamp :: ThirtyTwoBitTimeStamp - , recipientPayloadUseOnePassSignatures :: Bool - , recipientPayloadSignatures :: [SignaturePayload] - } - deriving (Eq, Show) - -data PassphraseSKESKVersionPolicy - = PassphraseSKESKPreferV6 - | PassphraseSKESKForceV4Interop - deriving (Eq, Show) - -data PassphraseEncryptRequest = - PassphraseEncryptRequest - { passphraseEncryptVersionPolicy :: PassphraseSKESKVersionPolicy - , passphraseEncryptSymmetricAlgorithm :: SymmetricAlgorithm - , passphraseEncryptS2K :: S2K - , passphraseEncryptPassphrase :: BL.ByteString - , passphraseEncryptPayload :: B.ByteString - , passphraseEncryptSEIPDv1IVOverride :: Maybe IV - , passphraseEncryptSEIPDv2AEADOverride :: Maybe AEADAlgorithm - , passphraseEncryptSEIPDv2ChunkSizeOverride :: Maybe Word8 - , passphraseEncryptSEIPDv2SaltOverride :: Maybe Salt - } - deriving (Eq, Show) - -encryptPassphraseWithPolicy :: - MonadRandom m - => PassphraseEncryptRequest - -> m (Either String [Pkt]) -encryptPassphraseWithPolicy request = - case passphraseEncryptVersionPolicy request of - PassphraseSKESKForceV4Interop -> - encryptSEIPDv1WithSKESK - (passphraseEncryptSymmetricAlgorithm request) - (passphraseEncryptS2K request) - (passphraseEncryptSEIPDv1IVOverride request) - (passphraseEncryptPassphrase request) - (passphraseEncryptPayload request) - PassphraseSKESKPreferV6 -> do - let messagePolicy = policyMessageEncryption (policyForRFC RFC9580) - aead = - fromMaybe - (messageDefaultAEADAlgorithm messagePolicy) - (passphraseEncryptSEIPDv2AEADOverride request) - chunkSize = - fromMaybe - (messageDefaultChunkSize messagePolicy) - (passphraseEncryptSEIPDv2ChunkSizeOverride request) - salt <- - maybe - (Salt <$> getRandomBytes (messageSEIPDv2SaltOctets messagePolicy)) - pure - (passphraseEncryptSEIPDv2SaltOverride request) - pure $ - encryptSEIPDv2WithSKESK - (passphraseEncryptSymmetricAlgorithm request) - aead - chunkSize - salt - (passphraseEncryptS2K request) - (passphraseEncryptPassphrase request) - (passphraseEncryptPayload request) - -defaultRecipientPayloadShape :: RecipientPayloadShape -defaultRecipientPayloadShape = - RecipientPayloadShape - { recipientPayloadDataType = BinaryData - , recipientPayloadFileName = BL.empty - , recipientPayloadTimestamp = 0 - , recipientPayloadUseOnePassSignatures = False - , recipientPayloadSignatures = [] - } - -data RecipientEncryptResult = - RecipientEncryptResult - { recipientEncryptPackets :: [Pkt] - , recipientEncryptSessionMaterial :: PKESKSessionMaterial - } - deriving (Eq, Show) - -data RecipientEncryptRequestOverrides (v :: SEIPDVersion) where - RecipientEncryptRequestSEIPDv1Overrides :: - { recipientEncryptRequestIVOverride :: Maybe IV - } -> RecipientEncryptRequestOverrides 'SEIPDv1 - -- | For SEIPDv2 requests: - -- - when AEAD override is 'Nothing', encrypt-side capability negotiation - -- selects a common recipient-supported AEAD algorithm (if enabled). - -- - when AEAD override is 'Just', the explicit AEAD wins. - RecipientEncryptRequestSEIPDv2Overrides :: - { recipientEncryptRequestAEADOverride :: Maybe AEADAlgorithm - , recipientEncryptRequestChunkSizeOverride :: Maybe Word8 - , recipientEncryptRequestSaltOverride :: Maybe Salt - } -> RecipientEncryptRequestOverrides 'SEIPDv2 - -data RecipientEncryptRequest (v :: SEIPDVersion) = - RecipientEncryptRequest - { -- | Recipient encryption targets. At least one target is required. - recipientEncryptRequestTargets :: [RecipientEncryptionTarget] - , recipientEncryptRequestPayloadShape :: RecipientPayloadShape - , recipientEncryptRequestPayload :: B.ByteString - -- | Explicit symmetric algorithm override. When 'Nothing', the selected - -- mode (negotiated or legacy) determines algorithm selection. - , recipientEncryptRequestSymmetricOverride :: Maybe SymmetricAlgorithm - , recipientEncryptRequestOverrides :: RecipientEncryptRequestOverrides v - } - -deriving instance Eq (RecipientEncryptRequestOverrides v) -deriving instance Show (RecipientEncryptRequestOverrides v) -deriving instance Eq (RecipientEncryptRequest v) -deriving instance Show (RecipientEncryptRequest v) - --- | Encode the RFC 9580 PKESK/SKESK session-key material: --- one-octet algorithm ID, raw session key, then 16-bit checksum. -encodeOpenPGPSessionMaterial :: - SymmetricAlgorithm -> SessionKey -> Either PKESKEncryptError B.ByteString -encodeOpenPGPSessionMaterial symalgo sessionKey = - unPKESKV3SessionMaterial <$> mkPKESKV3SessionMaterial symalgo sessionKey - --- | Generate a fresh session key and return both raw and encoded forms. -generateSessionKeyMaterial :: - MonadRandom m - => SymmetricAlgorithm - -> m (Either PKESKEncryptError PKESKSessionMaterial) -generateSessionKeyMaterial symalgo = - case keySize symalgo of - Left err -> pure (Left (UnsupportedSessionKeyAlgorithm symalgo (renderCipherError err))) - Right keyLen -> do - sessionKeyBytes <- getRandomBytes keyLen - let sessionKey = SessionKey sessionKeyBytes - pure (mkPKESKSessionMaterial symalgo sessionKey) - -canonicalizePKESKRecipientId :: - PKESKPayload -> Either PKESKEncryptError PKESKPayload -canonicalizePKESKRecipientId payload = - case payload of - PKESKPayloadV6Packet payloadV6 -> - PKESKPayloadV6Packet <$> canonicalizePKESKRecipientIdV6 payloadV6 - _ -> Right payload - -canonicalizePKESKRecipientIdV6 :: - PKESKPayloadV6 -> Either PKESKEncryptError PKESKPayloadV6 -canonicalizePKESKRecipientIdV6 (PKESKPayloadV6 rid pka esk) = - (\normalizedRid -> PKESKPayloadV6 normalizedRid pka esk) <$> - canonicalizeRecipientKeyIdentifier rid - -canonicalizeRecipientKeyIdentifier :: - BL.ByteString -> Either PKESKEncryptError BL.ByteString -canonicalizeRecipientKeyIdentifier rid - | BL.length rid == 20 || BL.length rid == 32 = Right rid - | BL.length rid == 21 && BL.head rid == 0x04 = Right (BL.tail rid) - | BL.length rid == 33 && BL.head rid == 0x06 = Right (BL.tail rid) - | otherwise = - Left - (InvalidRecipientIdentifier - ("unsupported PKESK recipient identifier length/prefix: " ++ - show (BL.length rid))) - -canonicalizePKESKPacketRecipientIds :: - [Pkt] -> Either PKESKEncryptError [Pkt] -canonicalizePKESKPacketRecipientIds = - mapM - (\pkt -> - case pkt of - PKESKPkt payload -> fmap PKESKPkt (canonicalizePKESKRecipientId payload) - _ -> Right pkt) - --- | Build a v6 PKESK payload for one recipient key according to the selected version policy. -buildPKESKPayloadForRecipient :: - MonadRandom m - => PKESKVersionPolicy - -> SomePKPayload - -> PKESKSessionMaterial - -> m (Either PKESKEncryptError PKESKPayload) -buildPKESKPayloadForRecipient policy recipient material = - case policy of - ForceV3Interop -> - buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial material) - PreferV6 -> - case _pkalgo recipient of - RSA -> fmap (fmap PKESKPayloadV6Packet) (buildRsaPKESKv6 recipient material) - ECDH -> fmap (fmap PKESKPayloadV6Packet) (buildECDHPKESKv6 recipient material) - X25519 -> - fmap - (fmap PKESKPayloadV6Packet) - (buildX25519PKESKv6 recipient (pkeskV6RawSessionMaterial material)) - X448 -> - fmap - (fmap PKESKPayloadV6Packet) - (buildX448PKESKv6 recipient (pkeskV6RawSessionMaterial material)) - pka -> pure (Left (UnsupportedRecipientAlgorithm pka)) - - --- | Build a PKESK packet for one recipient key according to the selected version policy. -buildPKESKPktForRecipient :: - MonadRandom m - => PKESKVersionPolicy - -> SomePKPayload - -> PKESKSessionMaterial - -> m (Either PKESKEncryptError Pkt) -buildPKESKPktForRecipient policy recipient material = - fmap - (fmap PKESKPkt) - (buildPKESKPayloadForRecipient policy recipient material) - - --- | Build a legacy PKESKv3 payload for v4/v3 RSA recipient interop. -buildPKESKv3PayloadForRecipient :: - MonadRandom m - => SomePKPayload - -> PKESKV3SessionMaterial - -> m (Either PKESKEncryptError PKESKPayload) -buildPKESKv3PayloadForRecipient recipient material = - fmap (fmap PKESKPayloadV3Packet) (buildPKESKv3PayloadForRecipientTyped recipient material) - -buildPKESKv3PayloadForRecipientTyped :: - MonadRandom m - => SomePKPayload - -> PKESKV3SessionMaterial - -> m (Either PKESKEncryptError PKESKPayloadV3) -buildPKESKv3PayloadForRecipientTyped recipient material = - case _pkalgo recipient of - RSA -> buildRsaPKESKv3 recipient material - DeprecatedRSAEncryptOnly -> buildRsaPKESKv3 recipient material - ECDH -> buildECDHPKESKv3 recipient material - pka -> pure (Left (UnsupportedRecipientAlgorithm pka)) - --- | Build a legacy PKESKv3 packet for v4/v3 RSA recipient interop. -buildPKESKv3PktForRecipient :: - MonadRandom m - => SomePKPayload - -> PKESKV3SessionMaterial - -> m (Either PKESKEncryptError Pkt) -buildPKESKv3PktForRecipient recipient material = - fmap (fmap PKESKPkt) (buildPKESKv3PayloadForRecipient recipient material) - --- | Build PKESK packets for all recipients with a single shared session key. - -buildPKESKPktsForRecipientTargetsWithSelector :: - MonadRandom m - => (RecipientEncryptionTarget -> Either PKESKEncryptError RecipientPKESKVersionStrategy) - -> [RecipientEncryptionTarget] - -> PKESKSessionMaterial - -> m (Either PKESKEncryptError [Pkt]) -buildPKESKPktsForRecipientTargetsWithSelector selector targets material - = buildPKESKPktsForRecipientTargetsWithSelectorTyped - (\target -> - promoteRecipientStrategy <$> selector target) - targets - material - -buildPKESKPktsForRecipientTargetsWithSelectorTyped :: - MonadRandom m - => (RecipientEncryptionTarget -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW) - -> [RecipientEncryptionTarget] - -> PKESKSessionMaterial - -> m (Either PKESKEncryptError [Pkt]) -buildPKESKPktsForRecipientTargetsWithSelectorTyped selector targets material - | null targets = pure (Left NoRecipientsProvided) - | otherwise = - case preparePKESKVersionedMaterial material of - Left err -> pure (Left err) - Right (v3Material, v6RawMaterial) -> do - pkeskResults <- - mapM - (\target -> - case selector target of - Left err -> pure (Left err) - Right (SomeRecipientPKESKVersionStrategyW RecipientPreferV6W) -> - buildPKESKPktForRecipientWithPreparedPayload - RecipientPreferV6W - (recipientEncryptionTargetKey target) - (RecipientPreferV6Payload material v6RawMaterial) - Right (SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW) -> - buildPKESKPktForRecipientWithPreparedPayload - RecipientForceV3InteropW - (recipientEncryptionTargetKey target) - (RecipientForceV3Payload v3Material)) - targets - pure (sequence pkeskResults >>= canonicalizePKESKPacketRecipientIds) - -preparePKESKVersionedMaterial :: - PKESKSessionMaterial - -> Either PKESKEncryptError (PKESKV3SessionMaterial, PKESKV6RawSessionMaterial) -preparePKESKVersionedMaterial material = do - v3Material <- - mkPKESKV3SessionMaterial - (pkeskSessionAlgorithm material) - (pkeskSessionKey material) - v6RawMaterial <- - mkPKESKV6RawSessionMaterial - (pkeskSessionAlgorithm material) - (pkeskSessionKey material) - pure (v3Material, v6RawMaterial) - -data RecipientPKESKRequestPayload (strategy :: RecipientPKESKVersionStrategy) where - RecipientForceV3Payload :: - PKESKV3SessionMaterial - -> RecipientPKESKRequestPayload 'RecipientForceV3Interop - RecipientPreferV6Payload :: - PKESKSessionMaterial - -> PKESKV6RawSessionMaterial - -> RecipientPKESKRequestPayload 'RecipientPreferV6 - -buildPKESKPktForRecipientWithPreparedPayload :: - MonadRandom m - => RecipientPKESKVersionStrategyW strategy - -> SomePKPayload - -> RecipientPKESKRequestPayload strategy - -> m (Either PKESKEncryptError Pkt) -buildPKESKPktForRecipientWithPreparedPayload strategy recipient payload = - fmap fmapPKESKPkt payloadResult - where - fmapPKESKPkt = fmap PKESKPkt - payloadResult = - case (strategy, payload) of - (RecipientForceV3InteropW, RecipientForceV3Payload v3Material) -> - buildPKESKv3PayloadForRecipient recipient v3Material - (RecipientPreferV6W, RecipientPreferV6Payload material v6RawMaterial) -> - case _pkalgo recipient of - RSA -> - fmap (fmap PKESKPayloadV6Packet) (buildRsaPKESKv6 recipient material) - ECDH -> - fmap (fmap PKESKPayloadV6Packet) (buildECDHPKESKv6 recipient material) - X25519 -> - fmap - (fmap PKESKPayloadV6Packet) - (buildX25519PKESKv6 recipient v6RawMaterial) - X448 -> - fmap - (fmap PKESKPayloadV6Packet) - (buildX448PKESKv6 recipient v6RawMaterial) - pka -> - pure (Left (UnsupportedRecipientAlgorithm pka)) - --- | Encrypt for recipient targets with capability negotiation enabled. --- --- By default this negotiates a common symmetric and (for SEIPDv2) AEAD --- algorithm from recipient capabilities when available. Explicit request --- overrides still take precedence. -encryptForRecipients :: - MonadRandom m - => RecipientEncryptRequest v - -> m (Either PKESKEncryptError RecipientEncryptResult) -encryptForRecipients = - encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn - --- | Encrypt for recipient targets without recipient capability negotiation. --- --- This preserves legacy behavior by using policy defaults unless request --- overrides are provided. -encryptForRecipientsLegacy :: - MonadRandom m - => RecipientEncryptRequest v - -> m (Either PKESKEncryptError RecipientEncryptResult) -encryptForRecipientsLegacy = - encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOff - --- | Encrypt for recipient targets with an explicit capability-negotiation mode. --- --- When negotiation is on, symmetric and AEAD selection use the common --- intersection of recipient preferences constrained by the active policy. --- When off, policy defaults are used. -encryptForRecipientsWithCapabilityNegotiation :: - MonadRandom m - => RecipientCapabilityNegotiationMode - -> RecipientEncryptRequest v - -> m (Either PKESKEncryptError RecipientEncryptResult) -encryptForRecipientsWithCapabilityNegotiation negotiationMode request - | null targets = pure (Left NoRecipientsProvided) - | otherwise = - case selectSymmetricAlgorithm negotiationMode request messagePolicy targets of - Left err -> pure (Left err) - Right symalgo -> do - sessionMaterialResult <- generateSessionKeyMaterial symalgo - case sessionMaterialResult of - Left err -> pure (Left err) - Right sessionMaterial -> do - pkeskResult <- - buildPKESKPktsForRecipientTargetsWithSelectorTyped - (recipientVersionStrategyForProfileTyped profileW) - targets - sessionMaterial - case pkeskResult of - Left err -> pure (Left err) - Right pkeskPkts -> do - payloadResult <- case recipientEncryptRequestOverrides request of - RecipientEncryptRequestSEIPDv2Overrides - { recipientEncryptRequestAEADOverride = aeadOverride - , recipientEncryptRequestChunkSizeOverride = chunkSizeOverride - , recipientEncryptRequestSaltOverride = saltOverride - } -> - case recipientsMissingSEIPDv2Support targets of - [] -> do - case selectAEADAlgorithm negotiationMode messagePolicy targets aeadOverride of - Left err -> pure (Left err) - Right aead -> do - salt <- maybe (Salt <$> getRandomBytes 32) pure saltOverride - let chunkSize = - maybe - (messageDefaultChunkSize messagePolicy) - id - chunkSizeOverride - pure $ - buildEncryptedPacketSequenceWithShape - symalgo - aead - chunkSize - (recipientEncryptRequestPayloadShape request) - salt - (pkeskSessionKey sessionMaterial) - pkeskPkts - (recipientEncryptRequestPayload request) - _missingSEIPDv2 -> - case recipientsMissingSEIPDv1Support targets of - [] -> - buildSEIPDv1PayloadWithIV - symalgo - sessionMaterial - pkeskPkts - Nothing - missingSEIPDv1 -> - pure - (Left - (RecipientCapabilitySelectionFailure - (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1))) - RecipientEncryptRequestSEIPDv1Overrides - { recipientEncryptRequestIVOverride = ivOverride } -> - case recipientsMissingSEIPDv1Support targets of - [] -> - buildSEIPDv1PayloadWithIV - symalgo - sessionMaterial - pkeskPkts - ivOverride - missingSEIPDv1 -> - pure - (Left - (RecipientCapabilitySelectionFailure - (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1))) - pure $ - fmap - (\pkts -> - RecipientEncryptResult - { recipientEncryptPackets = pkts - , recipientEncryptSessionMaterial = sessionMaterial - }) - payloadResult - where - targets = recipientEncryptRequestTargets request - profileW = - profileForPayloadVersionW (recipientEncryptRequestOverrides request) - messagePolicy = - case profileW of - EncryptStrictDefaultW -> - policyMessageEncryption (policyForRFC RFC9580) - EncryptInteropLegacyW -> - policyMessageEncryption (policyForRFC RFC4880) - - buildSEIPDv1PayloadWithIV :: - MonadRandom m - => SymmetricAlgorithm - -> PKESKSessionMaterial - -> [Pkt] - -> Maybe IV - -> m (Either PKESKEncryptError [Pkt]) - buildSEIPDv1PayloadWithIV symalgo sessionMaterial pkeskPkts ivOverride = do - ivResult <- - case ivOverride of - Just iv -> pure (Right iv) - Nothing -> - let keyBytes = unSessionKey (pkeskSessionKey sessionMaterial) - in case withSymmetricCipher symalgo keyBytes (\c -> Right (blockSize c)) of - Left err -> pure (Left (PayloadBuildFailure (renderCipherError err))) - Right n -> fmap (Right . IV) (getRandomBytes n) - case ivResult of - Left err -> pure (Left err) - Right iv -> - pure $ - buildEncryptedPacketSequenceWithShapeSEIPDv1 - symalgo - iv - (recipientEncryptRequestPayloadShape request) - (pkeskSessionKey sessionMaterial) - pkeskPkts - (recipientEncryptRequestPayload request) - - recipientsMissingSEIPDv1Support :: [RecipientEncryptionTarget] -> [SomePKPayload] - recipientsMissingSEIPDv1Support = - map recipientEncryptionTargetKey . - filter (not . targetAdvertisesSEIPDv1Support) - - recipientsMissingSEIPDv2Support :: [RecipientEncryptionTarget] -> [SomePKPayload] - recipientsMissingSEIPDv2Support = - map recipientEncryptionTargetKey . - filter (not . targetAdvertisesSEIPDv2Support) - - targetAdvertisesSEIPDv1Support :: RecipientEncryptionTarget -> Bool - targetAdvertisesSEIPDv1Support target = - case recipientEncryptionTargetCapabilities target of - Nothing -> True - Just caps -> recipientCapabilityAdvertisesSEIPDv1Support caps - - targetAdvertisesSEIPDv2Support :: RecipientEncryptionTarget -> Bool - targetAdvertisesSEIPDv2Support target = - case recipientEncryptionTargetCapabilities target of - Nothing -> True - Just caps -> recipientCapabilityAdvertisesSEIPDv2Support caps - -selectSymmetricAlgorithm :: - RecipientCapabilityNegotiationMode - -> RecipientEncryptRequest v - -> MessageEncryptionPolicy - -> [RecipientEncryptionTarget] - -> Either PKESKEncryptError SymmetricAlgorithm -selectSymmetricAlgorithm negotiationMode request messagePolicy targets = - case recipientEncryptRequestSymmetricOverride request of - Just override -> Right override - Nothing -> - case negotiationMode of - RecipientCapabilityNegotiationOff -> - Right (messageDefaultSymmetricAlgorithm messagePolicy) - RecipientCapabilityNegotiationOn -> - negotiateSymmetricAlgorithm messagePolicy targets - -selectAEADAlgorithm :: - RecipientCapabilityNegotiationMode - -> MessageEncryptionPolicy - -> [RecipientEncryptionTarget] - -> Maybe AEADAlgorithm - -> Either PKESKEncryptError AEADAlgorithm -selectAEADAlgorithm negotiationMode messagePolicy targets override = - case override of - Just explicit -> Right explicit - Nothing -> - case negotiationMode of - RecipientCapabilityNegotiationOff -> - Right (messageDefaultAEADAlgorithm messagePolicy) - RecipientCapabilityNegotiationOn -> - negotiateAEADAlgorithm messagePolicy targets - -negotiateSymmetricAlgorithm :: - MessageEncryptionPolicy - -> [RecipientEncryptionTarget] - -> Either PKESKEncryptError SymmetricAlgorithm -negotiateSymmetricAlgorithm messagePolicy targets = - chooseCommonAlgorithm - policyOrder - recipientChoices - (RecipientCapabilityNoCommonSymmetricAlgorithms (concat recipientChoices)) - where - policyOrder = - case messageSEIPDv2SymmetricAlgorithms messagePolicy of - [] -> [messageDefaultSymmetricAlgorithm messagePolicy] - syms -> syms - recipientChoices = map choicesForTarget targets - choicesForTarget target = - case recipientEncryptionTargetCapabilities target of - Just caps -> - let preferred = recipientCapabilityPreferredSymmetricAlgorithms caps - allowed = [alg | alg <- policyOrder, alg `elem` preferred] - in if null allowed - then policyOrder - else allowed - Nothing -> policyOrder - -negotiateAEADAlgorithm :: - MessageEncryptionPolicy - -> [RecipientEncryptionTarget] - -> Either PKESKEncryptError AEADAlgorithm -negotiateAEADAlgorithm messagePolicy targets = - chooseCommonAlgorithm - policyOrder - recipientChoices - (RecipientCapabilityNoCommonAEADAlgorithms (concat recipientChoices)) - where - policyOrder = foldl' addIfMissing [] (messageDefaultAEADAlgorithm messagePolicy : [OCB, EAX, GCM]) - recipientChoices = map choicesForTarget targets - choicesForTarget target = - case recipientEncryptionTargetCapabilities target of - Just caps -> - let preferred = recipientCapabilityPreferredAEADAlgorithms caps - allowed = [alg | alg <- policyOrder, alg `elem` preferred] - in if null allowed - then policyOrder - else allowed - Nothing -> policyOrder - addIfMissing acc x - | x `elem` acc = acc - | otherwise = acc ++ [x] - -chooseCommonAlgorithm :: - Eq a - => [a] - -> [[a]] - -> RecipientCapabilityError - -> Either PKESKEncryptError a -chooseCommonAlgorithm policyOrder recipientChoices err = - case recipientChoices of - [] -> Left (RecipientCapabilitySelectionFailure err) - (firstChoices:restChoices) -> - let common = foldl' intersectOrdered firstChoices restChoices - orderedCommon = [alg | alg <- policyOrder, alg `elem` common] - in case orderedCommon of - (selected:_) -> Right selected - [] -> Left (RecipientCapabilitySelectionFailure err) - where - intersectOrdered as bs = [a | a <- as, a `elem` bs] - -promoteRecipientStrategy :: - RecipientPKESKVersionStrategy - -> SomeRecipientPKESKVersionStrategyW -promoteRecipientStrategy RecipientPreferV6 = - SomeRecipientPKESKVersionStrategyW RecipientPreferV6W -promoteRecipientStrategy RecipientForceV3Interop = - SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW - -demoteRecipientStrategy :: - RecipientPKESKVersionStrategyW strategy - -> RecipientPKESKVersionStrategy -demoteRecipientStrategy RecipientPreferV6W = RecipientPreferV6 -demoteRecipientStrategy RecipientForceV3InteropW = RecipientForceV3Interop - -demoteSomeRecipientStrategy :: - SomeRecipientPKESKVersionStrategyW - -> RecipientPKESKVersionStrategy -demoteSomeRecipientStrategy (SomeRecipientPKESKVersionStrategyW strategyW) = - demoteRecipientStrategy strategyW - -promoteEncryptCompatibilityProfile :: - EncryptCompatibilityProfile - -> SomeEncryptCompatibilityProfileW -promoteEncryptCompatibilityProfile EncryptStrictDefault = - SomeEncryptCompatibilityProfileW EncryptStrictDefaultW -promoteEncryptCompatibilityProfile EncryptInteropLegacy = - SomeEncryptCompatibilityProfileW EncryptInteropLegacyW - --- | High-level encrypt-side helper for public-key recipient encryption. --- --- Returns a complete packet sequence: --- @[PKESK ..., SEIPD2 ...]@. - - - - - - - - - -buildEncryptedPacketSequence :: - SymmetricAlgorithm - -> AEADAlgorithm - -> Word8 - -> RecipientPayloadShape - -> Salt - -> SessionKey - -> [Pkt] - -> B.ByteString - -> Either String [Pkt] -buildEncryptedPacketSequence symalgo aead chunkSize payloadShape salt sessionKey pkesks payload = - first renderPKESKEncryptError - (buildEncryptedPacketSequenceWithShape symalgo aead chunkSize payloadShape salt sessionKey pkesks payload) - -buildEncryptedPacketSequenceWithShape :: - SymmetricAlgorithm - -> AEADAlgorithm - -> Word8 - -> RecipientPayloadShape - -> Salt - -> SessionKey - -> [Pkt] - -> B.ByteString - -> Either PKESKEncryptError [Pkt] -buildEncryptedPacketSequenceWithShape symalgo aead chunkSize payloadShape salt sessionKey pkesks payload = do - onePassSignatures <- first (PayloadBuildFailure . renderOPSBuildError) (buildOnePassSignaturePackets payloadShape) - let signatures = recipientPayloadSignatures payloadShape - literalBlock = - Block - (onePassSignatures ++ - [ LiteralDataPkt - (recipientPayloadDataType payloadShape) - (recipientPayloadFileName payloadShape) - (recipientPayloadTimestamp payloadShape) - (BL.fromStrict payload) - ] ++ - map SignaturePkt signatures) - ciphertext <- - first PayloadBuildFailure $ - encryptSEIPDv2Payload - symalgo - aead - chunkSize - salt - sessionKey - (BL.toStrict (runPut (put literalBlock))) - Right - (pkesks ++ - [SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict ciphertext))]) - --- | Encrypt a plaintext block with OpenPGP CFB + MDC to produce a SEIPDv1 ciphertext. -encryptSEIPDv1Payload :: - SymmetricAlgorithm - -> IV - -> SessionKey - -> B.ByteString -- ^ inner packet block plaintext - -> Either String B.ByteString -encryptSEIPDv1Payload symalgo iv (SessionKey keyBytes) plaintext = - let cleartextWithMDC = plaintext <> mdcTrailerForSEIPDv1 iv plaintext - in first - renderCipherError - (encryptOpenPGPCfbRaw OpenPGPCFBNoResyncW symalgo iv cleartextWithMDC keyBytes) - --- | Build a complete RFC 4880-conformant packet sequence using SEIPDv1 (CFB + MDC). -buildEncryptedPacketSequenceWithShapeSEIPDv1 :: - SymmetricAlgorithm - -> IV - -> RecipientPayloadShape - -> SessionKey - -> [Pkt] - -> B.ByteString - -> Either PKESKEncryptError [Pkt] -buildEncryptedPacketSequenceWithShapeSEIPDv1 symalgo iv payloadShape sessionKey pkesks payload = do - onePassSignatures <- first (PayloadBuildFailure . renderOPSBuildError) (buildOnePassSignaturePackets payloadShape) - let signatures = recipientPayloadSignatures payloadShape - literalBlock = - Block - (onePassSignatures ++ - [ LiteralDataPkt - (recipientPayloadDataType payloadShape) - (recipientPayloadFileName payloadShape) - (recipientPayloadTimestamp payloadShape) - (BL.fromStrict payload) - ] ++ - map SignaturePkt signatures) - ciphertext <- - first PayloadBuildFailure $ - encryptSEIPDv1Payload symalgo iv sessionKey (BL.toStrict (runPut (put literalBlock))) - Right - (pkesks ++ - [SymEncIntegrityProtectedDataPkt (SEIPD1 1 (BL.fromStrict ciphertext))]) - -buildOnePassSignaturePackets :: RecipientPayloadShape -> Either OPSBuildError [Pkt] -buildOnePassSignaturePackets payloadShape - | not (recipientPayloadUseOnePassSignatures payloadShape) = Right [] - | null signatures = Right [] - | otherwise = - fmap (map OnePassSignaturePkt) $ - sequence (zipWith buildOnePassSignature nestedFlags (reverse signatures)) - where - signatures = recipientPayloadSignatures payloadShape - nestedFlags = replicate (length signatures - 1) True ++ [False] - -data OnePassSignatureBuildCase where - OnePassSignatureBuildCaseV3 :: - SignaturePayloadV 'SigPayloadV3 -> OnePassSignatureBuildCase - OnePassSignatureBuildCaseV4 :: - SignaturePayloadV 'SigPayloadV4 -> OnePassSignatureBuildCase - OnePassSignatureBuildCaseV6 :: - SignaturePayloadV 'SigPayloadV6 -> OnePassSignatureBuildCase - OnePassSignatureBuildCaseOther :: - PacketVersion -> OnePassSignatureBuildCase - -onePassSignatureBuildCase :: SignaturePayload -> OnePassSignatureBuildCase -onePassSignatureBuildCase sig = - case toSomeSignaturePayload sig of - SomeSignaturePayload (payload@SigPayloadV3Data {}) -> - OnePassSignatureBuildCaseV3 payload - SomeSignaturePayload (payload@SigPayloadV4Data {}) -> - OnePassSignatureBuildCaseV4 payload - SomeSignaturePayload (payload@SigPayloadV6Data {}) -> - OnePassSignatureBuildCaseV6 payload - SomeSignaturePayload (SigPayloadOtherData version _) -> - OnePassSignatureBuildCaseOther version - -buildOnePassSignature :: NestedFlag -> SignaturePayload -> Either OPSBuildError OnePassSignaturePayload -buildOnePassSignature nestedFlag sig = - case onePassSignatureBuildCase sig of - OnePassSignatureBuildCaseV3 (SigPayloadV3Data sigType _ issuerKeyId pubkeyAlgo hashAlgo _ _) -> - Right - (OPSPayloadV3Packet - (OPSPayloadV3 3 sigType hashAlgo pubkeyAlgo issuerKeyId nestedFlag)) - OnePassSignatureBuildCaseV4 (SigPayloadV4Data sigType pubkeyAlgo hashAlgo hashedSubpackets unhashedSubpackets _ _) -> - case signatureIssuerKeyId hashedSubpackets unhashedSubpackets of - Just issuerKeyId -> - Right - (OPSPayloadV3Packet - (OPSPayloadV3 3 sigType hashAlgo pubkeyAlgo issuerKeyId nestedFlag)) - Nothing -> - Left OPSBuildMissingIssuerKeyId - OnePassSignatureBuildCaseV6 (SigPayloadV6Data sigType pubkeyAlgo hashAlgo salt hashedSubpackets unhashedSubpackets _ _) -> - case signatureIssuerFingerprint (BTypes.issuerFingerprintVersionToPacketVersion BTypes.IssuerFingerprintV6) hashedSubpackets unhashedSubpackets of - Just signerFingerprint - | BL.length signerFingerprint == 32 -> - Right - (OPSPayloadV6Packet - (OPSPayloadV6 sigType hashAlgo pubkeyAlgo salt signerFingerprint nestedFlag)) - | otherwise -> - Left (OPSBuildFingerprintWrongLength (BL.length signerFingerprint)) - Nothing -> - Left OPSBuildMissingIssuerFingerprint - OnePassSignatureBuildCaseOther version -> - Left (OPSBuildUnsupportedSigVersion version) - -signatureIssuerKeyId :: [SigSubPacket] -> [SigSubPacket] -> Maybe EightOctetKeyId -signatureIssuerKeyId hashedSubpackets unhashedSubpackets = - case findIssuerKeyId hashedSubpackets of - Just issuerKeyId -> Just issuerKeyId - Nothing -> - case findIssuerKeyId unhashedSubpackets of - Just issuerKeyId -> Just issuerKeyId - Nothing -> - case signatureIssuerFingerprint (BTypes.issuerFingerprintVersionToPacketVersion BTypes.IssuerFingerprintV4) hashedSubpackets unhashedSubpackets of - Just issuerFingerprintBytes -> - if BL.length issuerFingerprintBytes >= 8 - then - Just - (EightOctetKeyId - (BL.drop (BL.length issuerFingerprintBytes - 8) issuerFingerprintBytes)) - else Nothing - Nothing -> Nothing - -signatureIssuerFingerprint :: - PacketVersion -> [SigSubPacket] -> [SigSubPacket] -> Maybe BL.ByteString -signatureIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets = - unFingerprint <$> findIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets - -findIssuerKeyId :: [SigSubPacket] -> Maybe EightOctetKeyId -findIssuerKeyId subpackets = - case find isIssuerKeyIdSubpacket subpackets of - Just (SigSubPacket _ (Issuer issuerKeyId)) -> Just issuerKeyId - _ -> Nothing - -findIssuerFingerprint :: - PacketVersion -> [SigSubPacket] -> [SigSubPacket] -> Maybe Fingerprint -findIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets = - case findIssuerFingerprintIn expectedVersion hashedSubpackets of - Just issuerFingerprint -> Just issuerFingerprint - Nothing -> findIssuerFingerprintIn expectedVersion unhashedSubpackets - -findIssuerFingerprintIn :: PacketVersion -> [SigSubPacket] -> Maybe Fingerprint -findIssuerFingerprintIn expectedVersion subpackets = - case find (isIssuerFingerprintSubpacket expectedVersion) subpackets of - Just (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) -> Just issuerFingerprint - _ -> Nothing - -isIssuerKeyIdSubpacket :: SigSubPacket -> Bool -isIssuerKeyIdSubpacket (SigSubPacket _ (Issuer _)) = True -isIssuerKeyIdSubpacket _ = False - -isIssuerFingerprintSubpacket :: PacketVersion -> SigSubPacket -> Bool -isIssuerFingerprintSubpacket expectedVersion (SigSubPacket _ (IssuerFingerprint version _)) = - BTypes.issuerFingerprintVersionToPacketVersion version == expectedVersion -isIssuerFingerprintSubpacket _ _ = False - -buildRsaPKESKv6 :: - MonadRandom m - => SomePKPayload - -> PKESKSessionMaterial - -> m (Either PKESKEncryptError PKESKPayloadV6) -buildRsaPKESKv6 recipient material = - case _pubkey recipient of - RSAPubKey (RSA_PublicKey publicKey) -> do - encrypted <- RSA15.encrypt publicKey (pkeskEncodedSessionMaterial material) - pure $ - fmap - (\esk -> - let mpiEsk = runPut (put (MPI (os2ip esk))) - in PKESKPayloadV6 (recipientKeyIdentifier recipient) RSA mpiEsk) - (first (RecipientKeyWrapFailure RSA . show) encrypted) - _ -> - pure - (Left - (InvalidRecipientKeyMaterial - RSA - "recipient PKPayload does not contain an RSA public key")) - -buildRsaPKESKv3 :: - MonadRandom m - => SomePKPayload - -> PKESKV3SessionMaterial - -> m (Either PKESKEncryptError PKESKPayloadV3) -buildRsaPKESKv3 recipient material = - case _pubkey recipient of - RSAPubKey (RSA_PublicKey publicKey) -> - case eightOctetKeyID recipient of - Left err -> - pure - (Left - (InvalidRecipientKeyMaterial - (_pkalgo recipient) - ("failed to derive PKESKv3 recipient key ID: " ++ err))) - Right eoki -> do - encrypted <- RSA15.encrypt publicKey (unPKESKV3SessionMaterial material) - pure $ - fmap - (\esk -> - PKESKPayloadV3 - 3 - eoki - (_pkalgo recipient) - (MPI (os2ip esk) :| [])) - (first (RecipientKeyWrapFailure (_pkalgo recipient) . show) encrypted) - _ -> - pure - (Left - (InvalidRecipientKeyMaterial - (_pkalgo recipient) - "recipient PKPayload does not contain an RSA public key")) - -buildECDHPKESKv3 :: - MonadRandom m - => SomePKPayload - -> PKESKV3SessionMaterial - -> m (Either PKESKEncryptError PKESKPayloadV3) -buildECDHPKESKv3 recipient material = - case _pubkey recipient of - ECDHPubKey ecdhPub kdfHA kdfSA -> - case eightOctetKeyID recipient of - Left err -> - pure - (Left - (InvalidRecipientKeyMaterial - ECDH - ("failed to derive PKESKv3 recipient key ID: " ++ err))) - Right eoki -> - case ecdhPub of - ECDSAPubKey (ECDSA_PublicKey recipientPub) -> do - (ephemeralPub, ephemeralPriv) <- ECCGen.generate (ECDSA.public_curve recipientPub) - case point2MBS (ECDSA.public_q ephemeralPub) of - Nothing -> - pure - (Left - (InvalidRecipientKeyMaterial - ECDH - "failed to serialize ECDH ephemeral point")) - Just ephemeralBytes -> - pure $ - buildEcdhV3Payload - recipient - eoki - ECDH - ecdhPub - kdfHA - kdfSA - ephemeralBytes - (BA.convert - (ECCDH.getShared - (ECDSA.public_curve recipientPub) - (ECDSA.private_d ephemeralPriv) - (ECDSA.public_q recipientPub)) :: - B.ByteString) - material - EdDSAPubKey Ed25519 recipientPoint -> do - ephSecretRaw <- getRandomBytes 32 - pure $ - do recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint) - ephSecret <- - first (RecipientKeyWrapFailure ECDH . show) . - CE.eitherCryptoError $ - C25519.secretKey (leftPadTo 32 ephSecretRaw) - recipientPub <- - first (RecipientKeyWrapFailure ECDH . show) . - CE.eitherCryptoError $ - C25519.publicKey recipientPublicBytes - let ephPublicBytes = - B.cons 0x40 (BA.convert (C25519.toPublic ephSecret) :: B.ByteString) - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - buildEcdhV3Payload - recipient - eoki - ECDH - ecdhPub - kdfHA - kdfSA - ephPublicBytes - sharedSecret - material - _ -> - pure - (Left - (InvalidRecipientKeyMaterial - ECDH - "recipient ECDH public key is not RFC6637-compatible")) - _ -> - pure - (Left - (InvalidRecipientKeyMaterial - ECDH - "recipient PKPayload does not contain ECDH public key material")) - -buildECDHPKESKv6 :: - MonadRandom m - => SomePKPayload - -> PKESKSessionMaterial - -> m (Either PKESKEncryptError PKESKPayloadV6) -buildECDHPKESKv6 recipient material = - case _pubkey recipient of - ECDHPubKey ecdhPub kdfHA kdfSA -> - case ecdhPub of - ECDSAPubKey (ECDSA_PublicKey recipientPub) -> do - (ephemeralPub, ephemeralPriv) <- ECCGen.generate (ECDSA.public_curve recipientPub) - case point2MBS (ECDSA.public_q ephemeralPub) of - Nothing -> - pure - (Left - (InvalidRecipientKeyMaterial - ECDH - "failed to serialize ECDH ephemeral point")) - Just ephemeralBytes -> - pure $ - buildEcdhV6Esk - recipient - ECDH - ecdhPub - kdfHA - kdfSA - ephemeralBytes - (BA.convert - (ECCDH.getShared - (ECDSA.public_curve recipientPub) - (ECDSA.private_d ephemeralPriv) - (ECDSA.public_q recipientPub)) :: - B.ByteString) - material - EdDSAPubKey Ed25519 recipientPoint -> do - ephSecretRaw <- getRandomBytes 32 - pure $ - do recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint) - ephSecret <- - first (RecipientKeyWrapFailure ECDH . show) . - CE.eitherCryptoError $ - C25519.secretKey (leftPadTo 32 ephSecretRaw) - recipientPub <- - first (RecipientKeyWrapFailure ECDH . show) . - CE.eitherCryptoError $ - C25519.publicKey recipientPublicBytes - let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - buildEcdhV6Esk recipient ECDH ecdhPub kdfHA kdfSA ephPublicBytes sharedSecret material - EdDSAPubKey Ed448 recipientPoint -> do - ephSecretRaw <- getRandomBytes 56 - pure $ - do recipientPublicBytes <- normalizeX448Public (edPointBytes recipientPoint) - ephSecret <- - first (RecipientKeyWrapFailure ECDH . show) . - CE.eitherCryptoError $ - C448.secretKey (leftPadTo 56 ephSecretRaw) - recipientPub <- - first (RecipientKeyWrapFailure ECDH . show) . - CE.eitherCryptoError $ - C448.publicKey recipientPublicBytes - let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString - sharedSecret = BA.convert (C448.dh recipientPub ephSecret) :: B.ByteString - buildEcdhV6Esk recipient ECDH ecdhPub kdfHA kdfSA ephPublicBytes sharedSecret material - _ -> - pure - (Left - (InvalidRecipientKeyMaterial - ECDH - "recipient ECDH public key is not ECDSA/X25519/X448-compatible")) - _ -> - pure - (Left - (InvalidRecipientKeyMaterial - ECDH - "recipient PKPayload does not contain ECDH public key material")) - -buildX25519PKESKv6 :: - MonadRandom m - => SomePKPayload - -> PKESKV6RawSessionMaterial - -> m (Either PKESKEncryptError PKESKPayloadV6) -buildX25519PKESKv6 recipient material = do - ephSecretRaw <- getRandomBytes 32 - pure $ - do recipientPublic <- extractX25519RecipientPublic recipient - ephSecret <- - first (RecipientKeyWrapFailure X25519 . show) . - CE.eitherCryptoError $ - C25519.secretKey (leftPadTo 32 ephSecretRaw) - recipientPub <- - first (RecipientKeyWrapFailure X25519 . show) . - CE.eitherCryptoError $ - C25519.publicKey recipientPublic - let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - kek = deriveX25519Kek ephPublicBytes recipientPublic sharedSecret - wrapped <- - first (RecipientKeyWrapFailure X25519) . - aesKeyWrapRFC3394 AES128 kek $ - unPKESKV6RawSessionMaterial material - esk <- encodeV6X25519Esk ephPublicBytes wrapped - Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) X25519 (BL.fromStrict esk)) - -buildX448PKESKv6 :: - MonadRandom m - => SomePKPayload - -> PKESKV6RawSessionMaterial - -> m (Either PKESKEncryptError PKESKPayloadV6) -buildX448PKESKv6 recipient material = do - ephSecretRaw <- getRandomBytes 56 - pure $ - do recipientPublic <- extractX448RecipientPublic recipient - ephSecret <- - first (RecipientKeyWrapFailure X448 . show) . - CE.eitherCryptoError $ - C448.secretKey (leftPadTo 56 ephSecretRaw) - recipientPub <- - first (RecipientKeyWrapFailure X448 . show) . - CE.eitherCryptoError $ - C448.publicKey recipientPublic - let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString - sharedSecret = BA.convert (C448.dh recipientPub ephSecret) :: B.ByteString - kek = deriveX448Kek ephPublicBytes recipientPublic sharedSecret - wrapped <- - first (RecipientKeyWrapFailure X448) . - aesKeyWrapRFC3394 AES256 kek $ - unPKESKV6RawSessionMaterial material - esk <- encodeV6X448Esk ephPublicBytes wrapped - Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) X448 (BL.fromStrict esk)) - -buildEcdhV6Esk :: SomePKPayload - -> PubKeyAlgorithm - -> PKey - -> HashAlgorithm - -> SymmetricAlgorithm - -> B.ByteString - -> B.ByteString - -> PKESKSessionMaterial - -> Either PKESKEncryptError PKESKPayloadV6 -buildEcdhV6Esk recipient pka ecdhPub kdfHA kdfSA ephemeralBytes sharedSecret material = do - kdfParam <- - first (RecipientKdfFailure pka) $ - buildECDHKDFParam recipient pka ecdhPub kdfHA kdfSA - kek <- first (RecipientKdfFailure pka) $ deriveECDHKek kdfHA kdfSA sharedSecret kdfParam - wrapped <- - first (RecipientKeyWrapFailure pka) . - aesKeyWrapRFC3394 kdfSA kek $ - padToMultipleOf8 (pkeskEncodedSessionMaterial material) - esk <- encodeV6EcdhEsk ephemeralBytes wrapped - Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) pka (BL.fromStrict esk)) - -buildEcdhV3Payload :: SomePKPayload - -> EightOctetKeyId - -> PubKeyAlgorithm - -> PKey - -> HashAlgorithm - -> SymmetricAlgorithm - -> B.ByteString - -> B.ByteString - -> PKESKV3SessionMaterial - -> Either PKESKEncryptError PKESKPayloadV3 -buildEcdhV3Payload recipient eoki pka ecdhPub kdfHA kdfSA ephemeralBytes sharedSecret material = do - kdfParam <- - first (RecipientKdfFailure pka) $ - buildECDHKDFParam recipient pka ecdhPub kdfHA kdfSA - kek <- first (RecipientKdfFailure pka) $ deriveECDHKek kdfHA kdfSA sharedSecret kdfParam - wrapped <- - first (RecipientKeyWrapFailure pka) . - aesKeyWrapRFC3394 kdfSA kek $ - padToMultipleOf8 (unPKESKV3SessionMaterial material) - Right - (PKESKPayloadV3 - 3 - eoki - pka - (MPI (os2ip ephemeralBytes) :| [MPI (os2ip wrapped)])) - -recipientKeyIdentifier :: SomePKPayload -> BL.ByteString -recipientKeyIdentifier = unFingerprint . fingerprint - -encodeV6EcdhEsk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString -encodeV6EcdhEsk ephemeral wrapped = do - let ephLen = B.length ephemeral - if ephLen > 255 - then Left (RecipientKeyWrapFailure ECDH "ephemeral key encoding is too large") - else Right (B.singleton (fromIntegral ephLen) <> ephemeral <> wrapped) - -encodeV6X25519Esk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString -encodeV6X25519Esk ephemeral wrapped - | B.length ephemeral /= 32 = - Left (RecipientKeyWrapFailure X25519 "X25519 ephemeral key must be exactly 32 octets") - | B.length wrapped > 255 = - Left (RecipientKeyWrapFailure X25519 "wrapped session key encoding is too large") - | otherwise = - Right (ephemeral <> B.singleton (fromIntegral (B.length wrapped)) <> wrapped) - -encodeV6X448Esk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString -encodeV6X448Esk ephemeral wrapped - | B.length ephemeral /= 56 = - Left (RecipientKeyWrapFailure X448 "X448 ephemeral key must be exactly 56 octets") - | B.length wrapped > 255 = - Left (RecipientKeyWrapFailure X448 "wrapped session key encoding is too large") - | otherwise = - Right (ephemeral <> B.singleton (fromIntegral (B.length wrapped)) <> wrapped) - -extractX25519RecipientPublic :: SomePKPayload -> Either PKESKEncryptError B.ByteString -extractX25519RecipientPublic recipient = - case _pubkey recipient of - EdDSAPubKey Ed25519 point -> - normalizeX25519Public (edPointBytes point) - ECDHPubKey (EdDSAPubKey Ed25519 point) _ _ -> - normalizeX25519Public (edPointBytes point) - other -> - Left - (InvalidRecipientKeyMaterial - X25519 - ("expected X25519-compatible recipient key, got " ++ show other)) - -extractX448RecipientPublic :: SomePKPayload -> Either PKESKEncryptError B.ByteString -extractX448RecipientPublic recipient = - case _pubkey recipient of - EdDSAPubKey Ed448 point -> - normalizeX448Public (edPointBytes point) - ECDHPubKey (EdDSAPubKey Ed448 point) _ _ -> - normalizeX448Public (edPointBytes point) - other -> - Left - (InvalidRecipientKeyMaterial - X448 - ("expected X448-compatible recipient key, got " ++ show other)) - -normalizeX25519Public :: B.ByteString -> Either PKESKEncryptError B.ByteString -normalizeX25519Public = - first (InvalidRecipientKeyMaterial X25519) . - normalizeMontgomeryPublic - 32 - "invalid X25519 public key length/prefix: " - -normalizeX448Public :: B.ByteString -> Either PKESKEncryptError B.ByteString -normalizeX448Public = - first (InvalidRecipientKeyMaterial X448) . - normalizeMontgomeryPublic - 56 - "invalid X448 public key length/prefix: " - -edPointBytes :: EdPoint -> B.ByteString -edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x -edPointBytes (NativeEPoint (EPoint x)) = i2osp x - -deriveX25519Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -deriveX25519Kek ephemeralPublic recipientPublic sharedSecret = - let ikm = ephemeralPublic <> recipientPublic <> sharedSecret - prk = extract @CHAlg.SHA256 B.empty ikm - info = "OpenPGP X25519" :: B.ByteString - in expand @CHAlg.SHA256 prk info 16 - -deriveX448Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -deriveX448Kek ephemeralPublic recipientPublic sharedSecret = - let ikm = ephemeralPublic <> recipientPublic <> sharedSecret - prk = extract @CHAlg.SHA512 B.empty ikm - info = "OpenPGP X448" :: B.ByteString - in expand @CHAlg.SHA512 prk info 32 - -padToMultipleOf8 :: B.ByteString -> B.ByteString -padToMultipleOf8 bs - | padLen == 0 = bs - | otherwise = bs <> B.replicate padLen (fromIntegral padLen) - where - rem8 = B.length bs `mod` 8 - padLen = if rem8 == 0 then 0 else 8 - rem8 - -checksum16 :: B.ByteString -> Word16 -checksum16 = - fromIntegral . - B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0 - -checksum16Bytes :: B.ByteString -> B.ByteString -checksum16Bytes bs = - B.pack - [ fromIntegral ((chk `shiftR` 8) .&. 0xff) - , fromIntegral (chk .&. 0xff) - ] - where - chk = checksum16 bs - -aesKeyWrapRFC3394 :: - SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString -aesKeyWrapRFC3394 sa kek plain = - withAESCipher "ECDH PKESK currently supports AES KEK algorithms only" sa kek wrapWithCipher - where - wrapWithCipher :: CCT.BlockCipher cipher => cipher -> Either String B.ByteString - wrapWithCipher cipher = do - if B.length plain < 16 || B.length plain `mod` 8 /= 0 - then Left "ECDH key wrap input must be at least 16 octets and a multiple of 8" - else Right () - let rs = chunksOf8 plain - if length rs < 2 - then Left "ECDH key wrap input must contain at least two 64-bit blocks" - else Right () - (aFinal, rFinal) <- wrapRounds cipher (B.replicate 8 0xA6) rs - Right (aFinal <> B.concat rFinal) - wrapRounds :: CCT.BlockCipher cipher => cipher -> B.ByteString -> [B.ByteString] -> Either String (B.ByteString, [B.ByteString]) - wrapRounds cipher aInit rsInit = goJ 0 aInit rsInit - where - n = length rsInit - goJ j a rs - | j > 5 = Right (a, rs) - | otherwise = do - (a', rs') <- goI 1 a rs - goJ (j + 1) a' rs' - where - goI i curA curRs - | i > n = Right (curA, curRs) - | otherwise = do - let t = fromIntegral (n * j + i) :: Word64 - rI = curRs !! (i - 1) - block = CCT.ecbEncrypt cipher (curA <> rI) - (msb, lsb) = B.splitAt 8 block - aNext = xorBS msb (encodeWord64be t) - rsNext = (ix (i - 1) .~ lsb) curRs - goI (i + 1) aNext rsNext - -chunksOf8 :: B.ByteString -> [B.ByteString] -chunksOf8 bs - | B.null bs = [] - | otherwise = - let (h, t) = B.splitAt 8 bs - in h : chunksOf8 t - -xorBS :: B.ByteString -> B.ByteString -> B.ByteString -xorBS a b = B.pack (B.zipWith xor a b) - -encryptSEIPDv1WithSKESK :: - MonadRandom m - => SymmetricAlgorithm - -> S2K - -> Maybe IV - -> BL.ByteString - -> B.ByteString - -> m (Either String [Pkt]) -encryptSEIPDv1WithSKESK symalgo s2k ivOverride passphrase literalPayload = do - let eSessionKey = do - keyLen <- symKeySize symalgo - first renderS2KError (string2Key s2k keyLen passphrase) - case eSessionKey of - Left err -> pure (Left err) - Right sessionKeyMaterial -> - case - first - renderCipherError - (withSymmetricCipher symalgo sessionKeyMaterial (pure . blockSize)) of - Left err -> pure (Left err) - Right ivLength -> do - ivBytes <- - maybe - (getRandomBytes ivLength) - (pure . unIV) - ivOverride - let iv = IV ivBytes - let sessionKey = SessionKey sessionKeyMaterial - case encryptSEIPDv1Payload symalgo iv sessionKey literalPayload of - Left err -> pure (Left err) - Right encrypted -> - pure - (Right - [ SKESKPkt - (SKESKPayloadV4Packet - (SKESKPayloadV4 symalgo s2k Nothing)) - , SymEncIntegrityProtectedDataPkt - (SEIPD1 1 (BL.fromStrict encrypted)) - ]) - -encryptSEIPDv2WithSKESK :: - SymmetricAlgorithm - -> AEADAlgorithm - -> Word8 - -> Salt - -> S2K - -> BL.ByteString - -> B.ByteString - -> Either String [Pkt] -encryptSEIPDv2WithSKESK symalgo aead chunkSize salt s2k passphrase literalPayload = do - keyLen <- symKeySize symalgo - sessionKeyMaterial <- first renderS2KError (string2Key s2k keyLen passphrase) - (_, nonceSize) <- - aeadModeAndNonceSizeForSEIPDv2 - "unsupported AEAD algorithm for SKESK v6 encrypt" - aead - when (B.length (unSalt salt) < nonceSize) $ - Left "SEIPD v2 salt is too short to derive the SKESK v6 IV" - let skeskIV = B.take nonceSize (unSalt salt) - kek <- deriveSKESK6KEK symalgo aead sessionKeyMaterial - (wrappedSessionKey, skeskTag) <- - encryptSKESK6SessionKey symalgo aead kek skeskIV sessionKeyMaterial - let sessionKey = SessionKey sessionKeyMaterial - encrypted <- encryptSEIPDv2Payload symalgo aead chunkSize salt sessionKey literalPayload - return - [ SKESKPkt - (SKESKPayloadV6Packet - (SKESKPayloadV6 - symalgo - aead - s2k - (BL.fromStrict skeskIV) - (BL.fromStrict wrappedSessionKey) - (BL.fromStrict skeskTag))) - , SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict encrypted)) - ] - -encryptSEIPDv2WithSKESKBlock :: - SymmetricAlgorithm - -> AEADAlgorithm - -> Word8 - -> Salt - -> S2K - -> BL.ByteString - -> Block Pkt - -> Either String [Pkt] -encryptSEIPDv2WithSKESKBlock symalgo aead chunkSize salt s2k passphrase packetBlock = - encryptSEIPDv2WithSKESK - symalgo - aead - chunkSize - salt - s2k - passphrase - (BL.toStrict (runPut (put packetBlock))) - -encryptSEIPDv2LiteralDataWithSKESK :: - SymmetricAlgorithm - -> AEADAlgorithm - -> Word8 - -> Salt - -> S2K - -> BL.ByteString - -> B.ByteString - -> Either String [Pkt] -encryptSEIPDv2LiteralDataWithSKESK symalgo aead chunkSize salt s2k passphrase payload = - encryptSEIPDv2WithSKESKBlock - symalgo - aead - chunkSize - salt - s2k - passphrase - (Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload)]) - -encryptSEIPDv2Payload :: - SymmetricAlgorithm - -> AEADAlgorithm - -> Word8 - -> Salt - -> SessionKey - -> B.ByteString - -> Either String B.ByteString -encryptSEIPDv2Payload symalgo aead chunkSize salt (SessionKey sessionKey) plaintext = do - (mode, nonceSize) <- aeadModeAndNonceSize aead - keyLen <- symKeySize symalgo - let outputLen = keyLen + nonceSize - 8 - info = B.pack [0xd2, 2, fromFVal symalgo, fromFVal aead, chunkSize] - prk = extract @CHAlg.SHA256 (unSalt salt) sessionKey - okm = expand @CHAlg.SHA256 prk info outputLen :: B.ByteString - messageKey = B.take keyLen okm - noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm) - withAESCipher - "SEIPD v2 encrypt currently supports AES-128/192/256 only" - symalgo - messageKey - (encryptChunks mode info chunkSize noncePrefix plaintext) - -encryptChunks :: - CCT.BlockCipher cipher - => CCT.AEADMode - -> B.ByteString - -> Word8 - -> B.ByteString - -> B.ByteString - -> cipher - -> Either String B.ByteString -encryptChunks mode info chunkSize noncePrefix plaintext cipher = go 0 plaintext [] 0 - where - chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6) - go idx remaining acc totalPlain - | B.null remaining = do - (finalTag, finalCipher) <- - if mode == CCT.AEAD_OCB - then - encryptWithOCBRFC7253 - cipher - (noncePrefix <> encodeWord64be idx) - (info <> encodeWord64be (fromIntegral totalPlain)) - B.empty - else do - aead <- initAEAD idx - let (tag, out) = - CCT.aeadSimpleEncrypt - aead - (info <> encodeWord64be (fromIntegral totalPlain)) - B.empty - 16 - Right (tag, out) - if B.null finalCipher - then return (B.concat (reverse acc) <> authTagToBS finalTag) - else Left "expected empty ciphertext for final SEIPD v2 tag" - | otherwise = do - let (chunkPlain, rest) = B.splitAt chunkLen remaining - (tag, chunkCipher) <- - if mode == CCT.AEAD_OCB - then - encryptWithOCBRFC7253 - cipher - (noncePrefix <> encodeWord64be idx) - info - chunkPlain - else do - aead <- initAEAD idx - pure (CCT.aeadSimpleEncrypt aead info chunkPlain 16) - let chunkOut = chunkCipher <> authTagToBS tag - go - (idx + 1) - rest - (chunkOut : acc) - (totalPlain + B.length chunkPlain) - - initAEAD idx = - first show . CE.eitherCryptoError $ - CCT.aeadInit mode cipher (noncePrefix <> encodeWord64be idx) - -aeadModeAndNonceSize :: AEADAlgorithm -> Either String (CCT.AEADMode, Int) -aeadModeAndNonceSize = - aeadModeAndNonceSizeForSEIPDv2 - "unsupported AEAD algorithm for SEIPD v2 encrypt" - -symKeySize :: SymmetricAlgorithm -> Either String Int -symKeySize = - seipdv2SymmetricKeySize - "unsupported symmetric algorithm for SEIPD v2 encrypt" - -authTagToBS :: CCT.AuthTag -> B.ByteString -authTagToBS = BA.convert . CCT.unAuthTag - -encodeWord64be :: Word64 -> B.ByteString -encodeWord64be = BL.toStrict . runPut . putWord64be - --- | Compose a complete AEAD-encrypted message with optional literal data and signature. --- Returns a packet list (SKESK, SEIPD v2, optional signature) ready for serialization. --- --- Example: @composeMessageWithSEIPDv2 AES256 OCB 6 (Salt 32 bytes) --- (SimpleS2K SHA256) passphrase payload Nothing@ --- returns @[SKESK v6, SEIPD v2, ]@ --- --- If the signature is provided, it will be included in the encrypted payload. -composeMessageWithSEIPDv2 :: - SymmetricAlgorithm - -> AEADAlgorithm - -> Word8 - -> Salt - -> S2K - -> BL.ByteString - -> B.ByteString - -> Maybe [Pkt] - -> Either String [Pkt] -composeMessageWithSEIPDv2 symalgo aead chunkSize salt s2k passphrase payload mSigs = do - let packets = case mSigs of - Nothing -> [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload)] - Just sigs -> LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload) : sigs - blockPayload = Block packets - encryptSEIPDv2WithSKESKBlock symalgo aead chunkSize salt s2k passphrase blockPayload +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Codec.Encryption.OpenPGP.Encrypt + ( PKESKEncryptError (..) + , RecipientCapabilityNegotiationMode (..) + , RecipientCapabilityError (..) + , renderRecipientCapabilityError + , RecipientCapabilities (..) + , recipientCapabilitiesFromSubpacketPayloads + , recipientCapabilitySupportsEncryption + , RecipientTargetRejectionReason (..) + , RecipientEncryptionTargetRejected (..) + , RecipientEncryptionTargetsReport (..) + , recipientEncryptionTargetsReportFromTKAtTimestamp + , recipientEncryptionTargetsReportFromTK + , recipientEncryptionTargetFromTKAtTimestamp + , recipientEncryptionTargetFromTKAtTimestampWithPolicy + , recipientEncryptionTargetsFromTKAtTimestamp + , recipientEncryptionTargetFromTK + , recipientEncryptionTargetFromTKWithPolicy + , recipientEncryptionTargetsFromTK + , RecipientTargetSelectionPolicy (..) + , PassphraseSKESKVersionPolicy (..) + , PassphraseEncryptRequest (..) + , encryptPassphraseWithPolicy + , PKESKVersionPolicy (..) + , RecipientPKESKVersionStrategy (..) + , RecipientPKESKVersionStrategyW (..) + , SomeRecipientPKESKVersionStrategyW (..) + , RecipientPKESKVersionSelector + , RecipientPKESKVersionSelectorTyped + , EncryptCompatibilityProfile (..) + , EncryptCompatibilityProfileW (..) + , SomeEncryptCompatibilityProfileW (..) + , RecipientEncryptionTarget (..) + , recipientEncryptionTarget + , recipientEncryptionTargetWithStrategy + , recipientEncryptionTargetWithCapabilities + , recipientEncryptionTargetWithStrategyTyped + , recipientVersionStrategyForProfile + , recipientVersionStrategyForProfileTyped + , RecipientPayloadShape (..) + , defaultRecipientPayloadShape + , SEIPDVersion (..) + , RecipientEncryptResult (..) + , RecipientEncryptRequest (..) + , RecipientEncryptRequestOverrides (..) + , encryptForRecipients + , encryptForRecipientsLegacy + , encryptForRecipientsWithCapabilityNegotiation + , PKESKV3SessionMaterial + , PKESKV6RawSessionMaterial + , PKESKSessionMaterial + , pkeskSessionAlgorithm + , pkeskSessionKey + , mkPKESKSessionMaterial + , mkPKESKV3SessionMaterial + , mkPKESKV6RawSessionMaterial + , pkeskV3SessionMaterial + , pkeskV6RawSessionMaterial + , encodeOpenPGPSessionMaterial + , generateSessionKeyMaterial + , canonicalizePKESKRecipientId + , canonicalizePKESKPacketRecipientIds + , buildPKESKv3PayloadForRecipient + , buildPKESKv3PktForRecipient + , buildPKESKPayloadForRecipient + , buildPKESKPktForRecipient + , buildPKESKPktsForRecipientTargetsWithSelector + , buildPKESKPktsForRecipientTargetsWithSelectorTyped + , encryptSEIPDv2Payload + , encryptSEIPDv1Payload + , encryptSEIPDv2WithSKESK + , encryptSEIPDv2WithSKESKBlock + , encryptSEIPDv2LiteralDataWithSKESK + , composeMessageWithSEIPDv2 + ) where + +import Control.Applicative ((<|>)) +import Control.Lens (ix, (.~)) +import Control.Monad (when) +import qualified Crypto.Error as CE +import qualified Crypto.Hash.Algorithms as CHAlg +import Crypto.KDF.HKDF (expand, extract) +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Crypto.PubKey.Curve25519 as C25519 +import qualified Crypto.PubKey.Curve448 as C448 +import qualified Crypto.PubKey.ECC.DH as ECCDH +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Generate as ECCGen +import qualified Crypto.PubKey.RSA.PKCS15 as RSA15 +import Crypto.Random.Types (MonadRandom, getRandomBytes) +import Data.Bifunctor (first) +import Data.Binary (put) +import Data.Binary.Put (putWord64be, runPut) +import Data.Bits (shiftL, shiftR, xor, (.&.)) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Int (Int64) +import Data.List (find, foldl', maximumBy) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Ord (comparing) +import qualified Data.Set as Set +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Word (Word16, Word64, Word8) +import qualified "crypton" Crypto.Cipher.Types as CCT + +import Codec.Encryption.OpenPGP.BlockCipher + ( CipherError + , keySize + , renderCipherError + , withSymmetricCipher + ) +import Codec.Encryption.OpenPGP.CFB + ( OpenPGPCFBModeW (..) + , encryptOpenPGPCfbRaw + , mdcTrailerForSEIPDv1 + ) +import Codec.Encryption.OpenPGP.Expirations + ( effectiveKeyPreferencesAtTimestamp + , isPKTimeValidWithSelfSignatures + , keyStateAt + , keyStateValid + , signatureEffectiveAt + ) +import Codec.Encryption.OpenPGP.Fingerprint + ( eightOctetKeyID + , fingerprint + ) +import Codec.Encryption.OpenPGP.Internal (leftPadTo, point2MBS) +import Codec.Encryption.OpenPGP.Internal.CryptoAES + ( withAESCipher + ) +import Codec.Encryption.OpenPGP.Internal.CryptoECDH + ( buildECDHKDFParam + , deriveECDHKek + , normalizeMontgomeryPublic + ) +import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 + ( aeadModeAndNonceSizeForSEIPDv2 + , deriveSKESK6KEK + , encryptSKESK6SessionKey + , seipdv2SymmetricKeySize + ) +import Codec.Encryption.OpenPGP.Internal.HOBlockCipher + ( HOBlockCipher (..) + ) +import Codec.Encryption.OpenPGP.Internal.RFC7253OCB + ( encryptWithOCBRFC7253 + ) +import Codec.Encryption.OpenPGP.Ontology + ( isSubkeyBindingSig + , isSubkeyRevocation + ) +import Codec.Encryption.OpenPGP.Policy + ( MessageEncryptionPolicy + , OpenPGPRFC (..) + , PKESKVersionPolicy (..) + , defaultPKESKVersionPolicy + , messageDefaultAEADAlgorithm + , messageDefaultChunkSize + , messageDefaultSymmetricAlgorithm + , messageSEIPDv2SaltOctets + , messageSEIPDv2SymmetricAlgorithms + , policyForRFC + , policyMessageEncryption + ) +import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key) +import Codec.Encryption.OpenPGP.Serialize () +import Codec.Encryption.OpenPGP.SignatureQualities + ( sigCT + , signatureHashedSubpacketsKnown + ) +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes + +-- | Typed failures from one-pass signature packet construction. +data OPSBuildError + = OPSBuildMissingIssuerKeyId + | OPSBuildMissingIssuerFingerprint + | OPSBuildFingerprintWrongLength Int64 + | OPSBuildUnsupportedSigVersion PacketVersion + deriving (Eq, Show) + +renderOPSBuildError :: OPSBuildError -> String +renderOPSBuildError OPSBuildMissingIssuerKeyId = + "cannot build OPS3 packet from v4 signature without issuer metadata" +renderOPSBuildError OPSBuildMissingIssuerFingerprint = + "cannot build OPS6 packet from v6 signature without issuer fingerprint" +renderOPSBuildError (OPSBuildFingerprintWrongLength n) = + "cannot build OPS6 packet: issuer fingerprint must be 32 octets, got " + ++ show n +renderOPSBuildError (OPSBuildUnsupportedSigVersion v) = + "cannot build one-pass signature packet for unsupported signature version " + ++ show v + +-- | Typed failures surfaced by encrypt-side PKESK and SEIPD-v2 helpers. +data PKESKEncryptError + = UnsupportedSessionKeyAlgorithm SymmetricAlgorithm String + | InvalidSessionKeyLength SymmetricAlgorithm Int Int + | InvalidRecipientIdentifier String + | UnsupportedRecipientAlgorithm PubKeyAlgorithm + | InvalidRecipientKeyMaterial PubKeyAlgorithm String + | RecipientKdfFailure PubKeyAlgorithm String + | RecipientKeyWrapFailure PubKeyAlgorithm String + | RecipientCapabilitySelectionFailure RecipientCapabilityError + | PayloadBuildFailure String + | NoRecipientsProvided + deriving (Eq, Show) + +renderPKESKEncryptError :: PKESKEncryptError -> String +renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm algo reason) = + "unsupported session key algorithm " + ++ show algo + ++ ": " + ++ reason +renderPKESKEncryptError (InvalidSessionKeyLength algo expected actual) = + "invalid session key length for " + ++ show algo + ++ ": expected " + ++ show expected + ++ ", got " + ++ show actual +renderPKESKEncryptError (InvalidRecipientIdentifier reason) = + "invalid recipient identifier: " ++ reason +renderPKESKEncryptError (UnsupportedRecipientAlgorithm algo) = + "unsupported recipient public-key algorithm: " ++ show algo +renderPKESKEncryptError (InvalidRecipientKeyMaterial algo reason) = + "invalid recipient key material for " + ++ show algo + ++ ": " + ++ reason +renderPKESKEncryptError (RecipientKdfFailure algo reason) = + "KDF failure for recipient algorithm " + ++ show algo + ++ ": " + ++ reason +renderPKESKEncryptError (RecipientKeyWrapFailure algo reason) = + "key wrap failure for recipient algorithm " + ++ show algo + ++ ": " + ++ reason +renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) = + renderRecipientCapabilityError err +renderPKESKEncryptError (PayloadBuildFailure reason) = + "payload build failure: " ++ reason +renderPKESKEncryptError NoRecipientsProvided = + "no recipients provided" + +data RecipientCapabilityNegotiationMode + = RecipientCapabilityNegotiationOff + | RecipientCapabilityNegotiationOn + deriving (Eq, Show) + +data RecipientCapabilityError + = RecipientCapabilityMissingEncryptionFlags + SomePKPayload + (Set.Set KeyFlag) + | RecipientCapabilityNoEncryptableKeyMaterialInTK + | RecipientCapabilityMissingSEIPDv1Support [SomePKPayload] + | RecipientCapabilityMissingSEIPDv2Support [SomePKPayload] + | RecipientCapabilityNoCommonSymmetricAlgorithms + [SymmetricAlgorithm] + | RecipientCapabilityNoCommonAEADAlgorithms [AEADAlgorithm] + deriving (Eq, Show) + +renderRecipientCapabilityError + :: RecipientCapabilityError -> String +renderRecipientCapabilityError (RecipientCapabilityMissingEncryptionFlags recipient flags) = + "recipient " + ++ show (_keyVersion recipient, _pkalgo recipient) + ++ " does not advertise encryption-capable key flags; observed flags: " + ++ show (Set.toList flags) +renderRecipientCapabilityError RecipientCapabilityNoEncryptableKeyMaterialInTK = + "no encryption-capable primary key or subkey was found in transferable key material" +renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv1Support recipients) = + "recipient set does not advertise SEIPDv1 (MDC) support: " + ++ show (map (\r -> (_keyVersion r, _pkalgo r)) recipients) +renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv2Support recipients) = + "recipient set does not advertise SEIPDv2 support: " + ++ show (map (\r -> (_keyVersion r, _pkalgo r)) recipients) +renderRecipientCapabilityError (RecipientCapabilityNoCommonSymmetricAlgorithms syms) = + "no common recipient-supported symmetric algorithms: " + ++ show syms +renderRecipientCapabilityError (RecipientCapabilityNoCommonAEADAlgorithms aeads) = + "no common recipient-supported AEAD algorithms: " ++ show aeads + +data RecipientCapabilities + = RecipientCapabilities + { recipientCapabilityKeyVersion :: KeyVersion + , recipientCapabilityPublicKeyAlgorithm :: PubKeyAlgorithm + , recipientCapabilityKeyFlags :: Set.Set KeyFlag + , recipientCapabilityFeatures :: Set.Set FeatureFlag + , recipientCapabilityPreferredSymmetricAlgorithms + :: [SymmetricAlgorithm] + , recipientCapabilityPreferredAEADAlgorithms :: [AEADAlgorithm] + } + deriving (Eq, Show) + +data RecipientTargetRejectionReason + = RecipientTargetUnsupportedAlgorithm PubKeyAlgorithm + | RecipientTargetMissingEncryptionFlags + SomePKPayload + (Set.Set KeyFlag) + | RecipientTargetRevoked SomePKPayload + | RecipientTargetNotValidAtTimestamp + SomePKPayload + ThirtyTwoBitTimeStamp + deriving (Eq, Show) + +data RecipientEncryptionTargetRejected + = RecipientEncryptionTargetRejected + { recipientEncryptionTargetRejectedKey :: SomePKPayload + , recipientEncryptionTargetRejectedCapabilities + :: Maybe RecipientCapabilities + , recipientEncryptionTargetRejectedReason + :: RecipientTargetRejectionReason + } + deriving (Eq, Show) + +data RecipientEncryptionTargetsReport + = RecipientEncryptionTargetsReport + { recipientEncryptionTargetsAccepted :: [RecipientEncryptionTarget] + , recipientEncryptionTargetsRejected + :: [RecipientEncryptionTargetRejected] + } + deriving (Eq, Show) + +{- | Extract encrypt-relevant recipient capabilities from effective +self-signature subpackets. + +RFC 9580 preferred AEAD ciphersuites are currently carried through +'OtherSigSub' type 39 and decoded into AEAD preferences here. +-} +recipientCapabilitiesFromSubpacketPayloads + :: SomePKPayload + -> [SigSubPacketPayload] + -> RecipientCapabilities +recipientCapabilitiesFromSubpacketPayloads recipient payloads = + foldl' step (emptyRecipientCapabilities recipient) payloads + where + preferredAEADCiphersuitesSubpacketType :: Word8 + preferredAEADCiphersuitesSubpacketType = 39 + + step caps payload = + case payload of + KeyFlags flags -> + caps + { recipientCapabilityKeyFlags = + recipientCapabilityKeyFlags caps `Set.union` flags + } + Features features -> + caps + { recipientCapabilityFeatures = + recipientCapabilityFeatures caps `Set.union` features + } + PreferredSymmetricAlgorithms syms -> + caps + { recipientCapabilityPreferredSymmetricAlgorithms = + recipientCapabilityPreferredSymmetricAlgorithms caps ++ syms + } + PreferredAEADCiphersuites ciphersuites -> + caps + { recipientCapabilityPreferredAEADAlgorithms = + recipientCapabilityPreferredAEADAlgorithms caps + ++ preferredAEADAlgorithmsFromCiphersuitePairs ciphersuites + } + OtherSigSub subpacketType rawPayload + | subpacketType == preferredAEADCiphersuitesSubpacketType -> + caps + { recipientCapabilityPreferredAEADAlgorithms = + recipientCapabilityPreferredAEADAlgorithms caps + ++ preferredAEADAlgorithmsFromCiphersuites rawPayload + } + _ -> caps + + emptyRecipientCapabilities key = + RecipientCapabilities + { recipientCapabilityKeyVersion = _keyVersion key + , recipientCapabilityPublicKeyAlgorithm = _pkalgo key + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [] + , recipientCapabilityPreferredAEADAlgorithms = [] + } + + preferredAEADAlgorithmsFromCiphersuites + :: BL.ByteString -> [AEADAlgorithm] + preferredAEADAlgorithmsFromCiphersuites = + dedupePreservingOrder . parsePairs . BL.unpack + where + parsePairs (_symAlgo : aeadAlgo : rest) = + (toFVal aeadAlgo :: AEADAlgorithm) : parsePairs rest + parsePairs _ = [] + + dedupePreservingOrder = foldl' addIfMissing [] + addIfMissing acc x + | x `elem` acc = acc + | otherwise = acc ++ [x] + + preferredAEADAlgorithmsFromCiphersuitePairs + :: [(SymmetricAlgorithm, AEADAlgorithm)] -> [AEADAlgorithm] + preferredAEADAlgorithmsFromCiphersuitePairs = + dedupePreservingOrder . map snd + where + dedupePreservingOrder = foldl' addIfMissing [] + addIfMissing acc x + | x `elem` acc = acc + | otherwise = acc ++ [x] + +recipientCapabilitySupportsEncryption + :: RecipientCapabilities -> Bool +recipientCapabilitySupportsEncryption caps = + let flags = recipientCapabilityKeyFlags caps + in Set.null flags + || Set.member EncryptStorageKey flags + || Set.member EncryptCommunicationsKey flags + +recipientCapabilityAdvertisesSEIPDv1Support + :: RecipientCapabilities -> Bool +recipientCapabilityAdvertisesSEIPDv1Support caps = + let features = recipientCapabilityFeatures caps + in Set.null features || Set.member FeatureSEIPDv1 features + +recipientCapabilityAdvertisesSEIPDv2Support + :: RecipientCapabilities -> Bool +recipientCapabilityAdvertisesSEIPDv2Support caps = + recipientCapabilityAdvertisesSEIPDv1Support caps + && Set.member FeatureSEIPDv2 (recipientCapabilityFeatures caps) + +recipientEncryptionTargetFromTKAtTimestamp + :: ThirtyTwoBitTimeStamp + -> TKUnknown + -> Either RecipientCapabilityError RecipientEncryptionTarget +recipientEncryptionTargetFromTKAtTimestamp timestamp tk = + recipientEncryptionTargetFromTKAtTimestampWithPolicy + RecipientTargetSelectionFirstValid + timestamp + tk + +data RecipientTargetSelectionPolicy + = RecipientTargetSelectionFirstValid + | RecipientTargetSelectionPreferPrimary + | RecipientTargetSelectionPreferSubkey + | RecipientTargetSelectionPreferNewestCreationTime + deriving (Eq, Show) + +recipientEncryptionTargetFromTKAtTimestampWithPolicy + :: RecipientTargetSelectionPolicy + -> ThirtyTwoBitTimeStamp + -> TKUnknown + -> Either RecipientCapabilityError RecipientEncryptionTarget +recipientEncryptionTargetFromTKAtTimestampWithPolicy policy timestamp tk = + case chooseRecipientTarget policy tk acceptedTargets of + Just target -> Right target + Nothing -> Left RecipientCapabilityNoEncryptableKeyMaterialInTK + where + acceptedTargets = + recipientEncryptionTargetsAccepted + (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) + +recipientEncryptionTargetFromTK + :: TK 'PublicTK + -> Either RecipientCapabilityError RecipientEncryptionTarget +recipientEncryptionTargetFromTK tk = + recipientEncryptionTargetFromTKAtTimestampWithPolicy + RecipientTargetSelectionFirstValid + (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) + (tkToUnknown tk) + +recipientEncryptionTargetFromTKWithPolicy + :: RecipientTargetSelectionPolicy + -> TK 'PublicTK + -> Either RecipientCapabilityError RecipientEncryptionTarget +recipientEncryptionTargetFromTKWithPolicy policy tk = + recipientEncryptionTargetFromTKAtTimestampWithPolicy + policy + (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) + (tkToUnknown tk) + +recipientEncryptionTargetsFromTKAtTimestamp + :: ThirtyTwoBitTimeStamp + -> TKUnknown + -> [RecipientEncryptionTarget] +recipientEncryptionTargetsFromTKAtTimestamp timestamp tk = + recipientEncryptionTargetsAccepted + (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) + +recipientEncryptionTargetsReportFromTKAtTimestamp + :: ThirtyTwoBitTimeStamp + -> TKUnknown + -> RecipientEncryptionTargetsReport +recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk = + foldr + classifyCandidate + emptyReport + (subkeyCandidates ++ [primaryCandidate]) + where + emptyReport = RecipientEncryptionTargetsReport [] [] + primaryCandidate = fst (_tkuKey tk) + primaryPreferencePayloads = + fromMaybe [] (effectiveKeyPreferencesAtTimestamp timestamp tk) + subkeyCandidates = + mapMaybe + ( \(pkt, _) -> + case pkt of + PublicSubkeyPkt pkp -> Just pkp + SecretSubkeyPkt pkp _ -> Just pkp + _ -> Nothing + ) + (_tkuSubs tk) + classifyCandidate key report = + let caps = + recipientCapabilitiesFromSubpacketPayloads + key + ( primaryPreferencePayloads + ++ subkeyBindingCapabilityPayloads timestamp tk key + ) + keyStateRejection = recipientValidityRejectionReason timestamp tk key + in case keyStateRejection of + Just rejectionReason -> + report + { recipientEncryptionTargetsRejected = + RecipientEncryptionTargetRejected + { recipientEncryptionTargetRejectedKey = key + , recipientEncryptionTargetRejectedCapabilities = Just caps + , recipientEncryptionTargetRejectedReason = rejectionReason + } + : recipientEncryptionTargetsRejected report + } + Nothing -> + if not (supportsPKESKRecipientAlgorithm key) + then + report + { recipientEncryptionTargetsRejected = + RecipientEncryptionTargetRejected + { recipientEncryptionTargetRejectedKey = key + , recipientEncryptionTargetRejectedCapabilities = Just caps + , recipientEncryptionTargetRejectedReason = + RecipientTargetUnsupportedAlgorithm (_pkalgo key) + } + : recipientEncryptionTargetsRejected report + } + else + if recipientCapabilitySupportsEncryption caps + then + report + { recipientEncryptionTargetsAccepted = + recipientEncryptionTargetWithCapabilities key caps + : recipientEncryptionTargetsAccepted report + } + else + report + { recipientEncryptionTargetsRejected = + RecipientEncryptionTargetRejected + { recipientEncryptionTargetRejectedKey = key + , recipientEncryptionTargetRejectedCapabilities = Just caps + , recipientEncryptionTargetRejectedReason = + RecipientTargetMissingEncryptionFlags + key + (recipientCapabilityKeyFlags caps) + } + : recipientEncryptionTargetsRejected report + } + +recipientEncryptionTargetsFromTK + :: TK 'PublicTK -> [RecipientEncryptionTarget] +recipientEncryptionTargetsFromTK tk = + recipientEncryptionTargetsFromTKAtTimestamp + (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) + (tkToUnknown tk) + +recipientEncryptionTargetsReportFromTK + :: TK 'PublicTK -> RecipientEncryptionTargetsReport +recipientEncryptionTargetsReportFromTK tk = + recipientEncryptionTargetsReportFromTKAtTimestamp + (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) + (tkToUnknown tk) + +subkeyBindingCapabilityPayloads + :: ThirtyTwoBitTimeStamp + -> TKUnknown + -> SomePKPayload + -> [SigSubPacketPayload] +subkeyBindingCapabilityPayloads timestamp tk recipient = + maybe [] latestEffectiveBindingPayloads matchingSubkey + where + matchingSubkey = + find + ( \(pkt, _) -> + case pkt of + PublicSubkeyPkt pkp -> fingerprint pkp == fingerprint recipient + SecretSubkeyPkt pkp _ -> fingerprint pkp == fingerprint recipient + _ -> False + ) + (_tkuSubs tk) + latestEffectiveBindingPayloads (_, sigs) = + maybe + [] + signaturePayloadsFromSignature + (latestEffectiveSubkeyBindingSignature timestamp sigs) + +latestEffectiveSubkeyBindingSignature + :: ThirtyTwoBitTimeStamp + -> [SignaturePayload] + -> Maybe SignaturePayload +latestEffectiveSubkeyBindingSignature timestamp sigs = + case filter (isEffectiveSubkeyBindingSignature timestamp) sigs of + [] -> Nothing + candidates -> + Just + (maximumBy (comparing signatureCreationTimestamp) candidates) + +isEffectiveSubkeyBindingSignature + :: ThirtyTwoBitTimeStamp + -> SignaturePayload + -> Bool +isEffectiveSubkeyBindingSignature timestamp sig = + isSubkeyBindingSig sig + && maybe + False + ( \created -> + let tsValue = toInteger (unThirtyTwoBitTimeStamp timestamp) + createdValue = toInteger (unThirtyTwoBitTimeStamp created) + in createdValue <= tsValue + && maybe + True + ( \duration -> + if unThirtyTwoBitDuration duration == 0 + then True + else + tsValue + < createdValue + toInteger (unThirtyTwoBitDuration duration) + ) + (signatureExpirationDuration sig) + ) + (sigCT sig) + +signatureCreationTimestamp + :: SignaturePayload -> ThirtyTwoBitTimeStamp +signatureCreationTimestamp sig = + fromMaybe (ThirtyTwoBitTimeStamp 0) (sigCT sig) + +signatureExpirationDuration + :: SignaturePayload -> Maybe ThirtyTwoBitDuration +signatureExpirationDuration sig = + case signatureHashedSubpacketsKnown sig of + Just hashed -> + foldr + ( \subpacket acc -> + case subpacket of + SigSubPacket _ (SigExpirationTime duration) -> Just duration + _ -> acc + ) + Nothing + hashed + Nothing -> Nothing + +signaturePayloadsFromSignature + :: SignaturePayload -> [SigSubPacketPayload] +signaturePayloadsFromSignature sig = + case signatureHashedSubpacketsKnown sig of + Just hashed -> map (\(SigSubPacket _ payload) -> payload) hashed + Nothing -> [] + +recipientValidityRejectionReason + :: ThirtyTwoBitTimeStamp + -> TKUnknown + -> SomePKPayload + -> Maybe RecipientTargetRejectionReason +recipientValidityRejectionReason timestamp tk key + | fingerprint key == fingerprint (fst (_tkuKey tk)) = + if keyStateValid (keyStateAt (timestampToUTC timestamp) tk) + then Nothing + else Just (RecipientTargetNotValidAtTimestamp key timestamp) + | otherwise = + case findMatchingSubkeySignatures tk key of + Nothing -> Nothing + Just sigs + | subkeyRevokedAtTimestamp timestamp sigs -> + Just (RecipientTargetRevoked key) + | isPKTimeValidWithSelfSignatures + (timestampToUTC timestamp) + key + sigs -> + Nothing + | otherwise -> + Just (RecipientTargetNotValidAtTimestamp key timestamp) + +findMatchingSubkeySignatures + :: TKUnknown -> SomePKPayload -> Maybe [SignaturePayload] +findMatchingSubkeySignatures tk recipient = + snd + <$> find + ( \(pkt, _) -> + case pkt of + PublicSubkeyPkt pkp -> fingerprint pkp == fingerprint recipient + SecretSubkeyPkt pkp _ -> fingerprint pkp == fingerprint recipient + _ -> False + ) + (_tkuSubs tk) + +subkeyRevokedAtTimestamp + :: ThirtyTwoBitTimeStamp -> [SignaturePayload] -> Bool +subkeyRevokedAtTimestamp timestamp = + any + ( \sig -> + isSubkeyRevocation sig + && signatureEffectiveAt (timestampToUTC timestamp) sig + ) + +timestampToUTC :: ThirtyTwoBitTimeStamp -> UTCTime +timestampToUTC = + posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp + +supportsPKESKRecipientAlgorithm :: SomePKPayload -> Bool +supportsPKESKRecipientAlgorithm recipient = + case _pkalgo recipient of + RSA -> True + DeprecatedRSAEncryptOnly -> True + ECDH -> True + X25519 -> True + X448 -> True + _ -> False + +chooseRecipientTarget + :: RecipientTargetSelectionPolicy + -> TKUnknown + -> [RecipientEncryptionTarget] + -> Maybe RecipientEncryptionTarget +chooseRecipientTarget policy tk targets = + case policy of + RecipientTargetSelectionFirstValid -> listToMaybe targets + RecipientTargetSelectionPreferPrimary -> + listToMaybe (filter (isPrimaryTarget tk) targets) + <|> listToMaybe targets + RecipientTargetSelectionPreferSubkey -> + listToMaybe (filter (not . isPrimaryTarget tk) targets) + <|> listToMaybe targets + RecipientTargetSelectionPreferNewestCreationTime -> + case targets of + [] -> Nothing + (target : rest) -> + Just + ( foldl' + ( \best candidate -> + if _timestamp (recipientEncryptionTargetKey candidate) + > _timestamp (recipientEncryptionTargetKey best) + then candidate + else best + ) + target + rest + ) + where + isPrimaryTarget currentTK target = + fingerprint (recipientEncryptionTargetKey target) + == fingerprint (fst (_tkuKey currentTK)) + +-- | Session-key bundle for PKESK/SKESK packet construction. +newtype PKESKV3SessionMaterial + = PKESKV3SessionMaterial + { unPKESKV3SessionMaterial :: B.ByteString + } + deriving (Eq, Show) + +newtype PKESKV6RawSessionMaterial + = PKESKV6RawSessionMaterial + { unPKESKV6RawSessionMaterial :: B.ByteString + } + deriving (Eq, Show) + +data PKESKSessionMaterial + = PKESKSessionMaterial + { pkeskSessionAlgorithm :: SymmetricAlgorithm + , pkeskSessionKey :: SessionKey + , pkeskEncodedSessionMaterial :: B.ByteString + } + deriving (Eq, Show) + +mkPKESKSessionMaterial + :: SymmetricAlgorithm + -> SessionKey + -> Either PKESKEncryptError PKESKSessionMaterial +mkPKESKSessionMaterial symalgo sessionKey = do + v3Material <- mkPKESKV3SessionMaterial symalgo sessionKey + _v6Material <- mkPKESKV6RawSessionMaterial symalgo sessionKey + pure + PKESKSessionMaterial + { pkeskSessionAlgorithm = symalgo + , pkeskSessionKey = sessionKey + , pkeskEncodedSessionMaterial = unPKESKV3SessionMaterial v3Material + } + +mkPKESKV3SessionMaterial + :: SymmetricAlgorithm + -> SessionKey + -> Either PKESKEncryptError PKESKV3SessionMaterial +mkPKESKV3SessionMaterial symalgo sessionKey = do + keyBytes <- validatedSessionKeyBytes symalgo sessionKey + pure $ + PKESKV3SessionMaterial + ( B.singleton (fromFVal symalgo) + <> keyBytes + <> checksum16Bytes keyBytes + ) + +mkPKESKV6RawSessionMaterial + :: SymmetricAlgorithm + -> SessionKey + -> Either PKESKEncryptError PKESKV6RawSessionMaterial +mkPKESKV6RawSessionMaterial symalgo sessionKey = + PKESKV6RawSessionMaterial + <$> validatedSessionKeyBytes symalgo sessionKey + +pkeskV3SessionMaterial + :: PKESKSessionMaterial -> PKESKV3SessionMaterial +pkeskV3SessionMaterial = + PKESKV3SessionMaterial . pkeskEncodedSessionMaterial + +pkeskV6RawSessionMaterial + :: PKESKSessionMaterial -> PKESKV6RawSessionMaterial +pkeskV6RawSessionMaterial = + PKESKV6RawSessionMaterial . unSessionKey . pkeskSessionKey + +validatedSessionKeyBytes + :: SymmetricAlgorithm + -> SessionKey + -> Either PKESKEncryptError B.ByteString +validatedSessionKeyBytes symalgo (SessionKey sessionKey) = do + keyLen <- + first + (UnsupportedSessionKeyAlgorithm symalgo . renderCipherError) + (keySize symalgo) + let actualLen = B.length sessionKey + if actualLen /= keyLen + then Left (InvalidSessionKeyLength symalgo keyLen actualLen) + else Right sessionKey + +data RecipientPKESKVersionStrategy + = RecipientPreferV6 + | RecipientForceV3Interop + deriving (Eq, Show) + +data + RecipientPKESKVersionStrategyW + (strategy :: RecipientPKESKVersionStrategy) + where + RecipientPreferV6W + :: RecipientPKESKVersionStrategyW 'RecipientPreferV6 + RecipientForceV3InteropW + :: RecipientPKESKVersionStrategyW 'RecipientForceV3Interop + +data SomeRecipientPKESKVersionStrategyW where + SomeRecipientPKESKVersionStrategyW + :: RecipientPKESKVersionStrategyW strategy + -> SomeRecipientPKESKVersionStrategyW + +type RecipientPKESKVersionSelector = + SomePKPayload + -> Either PKESKEncryptError RecipientPKESKVersionStrategy + +type RecipientPKESKVersionSelectorTyped = + SomePKPayload + -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW + +data EncryptCompatibilityProfile + = EncryptStrictDefault + | EncryptInteropLegacy + deriving (Eq, Show) + +data + EncryptCompatibilityProfileW + (profile :: EncryptCompatibilityProfile) + where + EncryptStrictDefaultW + :: EncryptCompatibilityProfileW 'EncryptStrictDefault + EncryptInteropLegacyW + :: EncryptCompatibilityProfileW 'EncryptInteropLegacy + +data SomeEncryptCompatibilityProfileW where + SomeEncryptCompatibilityProfileW + :: EncryptCompatibilityProfileW profile + -> SomeEncryptCompatibilityProfileW + +data SEIPDVersion + = SEIPDv1 + | SEIPDv2 + deriving (Eq, Show) + +type family + PayloadVersionForProfile (profile :: EncryptCompatibilityProfile) + :: SEIPDVersion + where + PayloadVersionForProfile 'EncryptStrictDefault = 'SEIPDv2 + PayloadVersionForProfile 'EncryptInteropLegacy = 'SEIPDv1 + +type family + ProfileForPayloadVersion (version :: SEIPDVersion) + :: EncryptCompatibilityProfile + where + ProfileForPayloadVersion 'SEIPDv1 = 'EncryptInteropLegacy + ProfileForPayloadVersion 'SEIPDv2 = 'EncryptStrictDefault + +data RecipientEncryptionTarget + = RecipientEncryptionTarget + { recipientEncryptionTargetKey :: SomePKPayload + -- ^ Recipient key packet selected for PKESK wrapping. + , recipientEncryptionTargetStrategy + :: Maybe RecipientPKESKVersionStrategy + {- ^ Optional explicit PKESK version strategy hint. + When absent, profile defaults and auto-detection apply. + -} + , recipientEncryptionTargetCapabilities + :: Maybe RecipientCapabilities + {- ^ Optional recipient capability hints used by negotiation-enabled + encryption to choose common symmetric/AEAD algorithms. + -} + } + deriving (Eq, Show) + +recipientEncryptionTarget + :: SomePKPayload -> RecipientEncryptionTarget +recipientEncryptionTarget recipient = + RecipientEncryptionTarget recipient Nothing Nothing + +recipientEncryptionTargetWithStrategy + :: SomePKPayload + -> RecipientPKESKVersionStrategy + -> RecipientEncryptionTarget +recipientEncryptionTargetWithStrategy recipient strategy = + RecipientEncryptionTarget recipient (Just strategy) Nothing + +recipientEncryptionTargetWithCapabilities + :: SomePKPayload + -> RecipientCapabilities + -> RecipientEncryptionTarget +recipientEncryptionTargetWithCapabilities recipient capabilities = + RecipientEncryptionTarget recipient Nothing (Just capabilities) + +recipientEncryptionTargetWithStrategyTyped + :: SomePKPayload + -> RecipientPKESKVersionStrategyW strategy + -> RecipientEncryptionTarget +recipientEncryptionTargetWithStrategyTyped recipient strategyW = + recipientEncryptionTargetWithStrategy + recipient + (demoteRecipientStrategy strategyW) + +recipientVersionStrategyForProfile + :: EncryptCompatibilityProfile + -> RecipientEncryptionTarget + -> Either PKESKEncryptError RecipientPKESKVersionStrategy +recipientVersionStrategyForProfile profile target = + case promoteEncryptCompatibilityProfile profile of + SomeEncryptCompatibilityProfileW profileW -> + demoteSomeRecipientStrategy + <$> recipientVersionStrategyForProfileTyped profileW target + +recipientVersionStrategyForProfileTyped + :: EncryptCompatibilityProfileW profile + -> RecipientEncryptionTarget + -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW +recipientVersionStrategyForProfileTyped profile target = + Right $ + case recipientEncryptionTargetStrategy target of + Just strategy -> + promoteRecipientStrategy strategy + Nothing -> + case profile of + EncryptStrictDefaultW -> + autoDetectRecipientVersionStrategy + (recipientEncryptionTargetKey target) + EncryptInteropLegacyW -> + SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW + +profileForPayloadVersionW + :: RecipientEncryptRequestOverrides version + -> EncryptCompatibilityProfileW (ProfileForPayloadVersion version) +profileForPayloadVersionW overrides = + case overrides of + RecipientEncryptRequestSEIPDv2Overrides {} -> EncryptStrictDefaultW + RecipientEncryptRequestSEIPDv1Overrides {} -> EncryptInteropLegacyW + +autoDetectRecipientVersionStrategy + :: SomePKPayload + -> SomeRecipientPKESKVersionStrategyW +autoDetectRecipientVersionStrategy recipient + | _keyVersion recipient == V6 = + SomeRecipientPKESKVersionStrategyW RecipientPreferV6W + | _pkalgo recipient `elem` [X25519, X448] = + SomeRecipientPKESKVersionStrategyW RecipientPreferV6W + | otherwise = + SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW + +data RecipientPayloadShape + = RecipientPayloadShape + { recipientPayloadDataType :: LiteralDataType + , recipientPayloadFileName :: FileName + , recipientPayloadTimestamp :: ThirtyTwoBitTimeStamp + , recipientPayloadUseOnePassSignatures :: Bool + , recipientPayloadSignatures :: [SignaturePayload] + } + deriving (Eq, Show) + +data PassphraseSKESKVersionPolicy + = PassphraseSKESKPreferV6 + | PassphraseSKESKForceV4Interop + deriving (Eq, Show) + +data PassphraseEncryptRequest + = PassphraseEncryptRequest + { passphraseEncryptVersionPolicy :: PassphraseSKESKVersionPolicy + , passphraseEncryptSymmetricAlgorithm :: SymmetricAlgorithm + , passphraseEncryptS2K :: S2K + , passphraseEncryptPassphrase :: BL.ByteString + , passphraseEncryptPayload :: B.ByteString + , passphraseEncryptSEIPDv1IVOverride :: Maybe IV + , passphraseEncryptSEIPDv2AEADOverride :: Maybe AEADAlgorithm + , passphraseEncryptSEIPDv2ChunkSizeOverride :: Maybe Word8 + , passphraseEncryptSEIPDv2SaltOverride :: Maybe Salt + } + deriving (Eq, Show) + +encryptPassphraseWithPolicy + :: MonadRandom m + => PassphraseEncryptRequest + -> m (Either String [Pkt]) +encryptPassphraseWithPolicy request = + case passphraseEncryptVersionPolicy request of + PassphraseSKESKForceV4Interop -> + encryptSEIPDv1WithSKESK + (passphraseEncryptSymmetricAlgorithm request) + (passphraseEncryptS2K request) + (passphraseEncryptSEIPDv1IVOverride request) + (passphraseEncryptPassphrase request) + (passphraseEncryptPayload request) + PassphraseSKESKPreferV6 -> do + let messagePolicy = policyMessageEncryption (policyForRFC RFC9580) + aead = + fromMaybe + (messageDefaultAEADAlgorithm messagePolicy) + (passphraseEncryptSEIPDv2AEADOverride request) + chunkSize = + fromMaybe + (messageDefaultChunkSize messagePolicy) + (passphraseEncryptSEIPDv2ChunkSizeOverride request) + salt <- + maybe + (Salt <$> getRandomBytes (messageSEIPDv2SaltOctets messagePolicy)) + pure + (passphraseEncryptSEIPDv2SaltOverride request) + pure $ + encryptSEIPDv2WithSKESK + (passphraseEncryptSymmetricAlgorithm request) + aead + chunkSize + salt + (passphraseEncryptS2K request) + (passphraseEncryptPassphrase request) + (passphraseEncryptPayload request) + +defaultRecipientPayloadShape :: RecipientPayloadShape +defaultRecipientPayloadShape = + RecipientPayloadShape + { recipientPayloadDataType = BinaryData + , recipientPayloadFileName = BL.empty + , recipientPayloadTimestamp = 0 + , recipientPayloadUseOnePassSignatures = False + , recipientPayloadSignatures = [] + } + +data RecipientEncryptResult + = RecipientEncryptResult + { recipientEncryptPackets :: [Pkt] + , recipientEncryptSessionMaterial :: PKESKSessionMaterial + } + deriving (Eq, Show) + +data RecipientEncryptRequestOverrides (v :: SEIPDVersion) where + RecipientEncryptRequestSEIPDv1Overrides + :: { recipientEncryptRequestIVOverride :: Maybe IV + } + -> RecipientEncryptRequestOverrides 'SEIPDv1 + {- | For SEIPDv2 requests: + - when AEAD override is 'Nothing', encrypt-side capability negotiation + selects a common recipient-supported AEAD algorithm (if enabled). + - when AEAD override is 'Just', the explicit AEAD wins. + -} + RecipientEncryptRequestSEIPDv2Overrides + :: { recipientEncryptRequestAEADOverride :: Maybe AEADAlgorithm + , recipientEncryptRequestChunkSizeOverride :: Maybe Word8 + , recipientEncryptRequestSaltOverride :: Maybe Salt + } + -> RecipientEncryptRequestOverrides 'SEIPDv2 + +data RecipientEncryptRequest (v :: SEIPDVersion) + = RecipientEncryptRequest + { recipientEncryptRequestTargets :: [RecipientEncryptionTarget] + -- ^ Recipient encryption targets. At least one target is required. + , recipientEncryptRequestPayloadShape :: RecipientPayloadShape + , recipientEncryptRequestPayload :: B.ByteString + , recipientEncryptRequestSymmetricOverride + :: Maybe SymmetricAlgorithm + {- ^ Explicit symmetric algorithm override. When 'Nothing', the selected + mode (negotiated or legacy) determines algorithm selection. + -} + , recipientEncryptRequestOverrides + :: RecipientEncryptRequestOverrides v + } + +deriving instance Eq (RecipientEncryptRequestOverrides v) +deriving instance Show (RecipientEncryptRequestOverrides v) +deriving instance Eq (RecipientEncryptRequest v) +deriving instance Show (RecipientEncryptRequest v) + +{- | Encode the RFC 9580 PKESK/SKESK session-key material: + one-octet algorithm ID, raw session key, then 16-bit checksum. +-} +encodeOpenPGPSessionMaterial + :: SymmetricAlgorithm + -> SessionKey + -> Either PKESKEncryptError B.ByteString +encodeOpenPGPSessionMaterial symalgo sessionKey = + unPKESKV3SessionMaterial + <$> mkPKESKV3SessionMaterial symalgo sessionKey + +-- | Generate a fresh session key and return both raw and encoded forms. +generateSessionKeyMaterial + :: MonadRandom m + => SymmetricAlgorithm + -> m (Either PKESKEncryptError PKESKSessionMaterial) +generateSessionKeyMaterial symalgo = + case keySize symalgo of + Left err -> + pure + ( Left + (UnsupportedSessionKeyAlgorithm symalgo (renderCipherError err)) + ) + Right keyLen -> do + sessionKeyBytes <- getRandomBytes keyLen + let sessionKey = SessionKey sessionKeyBytes + pure (mkPKESKSessionMaterial symalgo sessionKey) + +canonicalizePKESKRecipientId + :: PKESKPayload -> Either PKESKEncryptError PKESKPayload +canonicalizePKESKRecipientId payload = + case payload of + PKESKPayloadV6Packet payloadV6 -> + PKESKPayloadV6Packet <$> canonicalizePKESKRecipientIdV6 payloadV6 + _ -> Right payload + +canonicalizePKESKRecipientIdV6 + :: PKESKPayloadV6 -> Either PKESKEncryptError PKESKPayloadV6 +canonicalizePKESKRecipientIdV6 (PKESKPayloadV6 rid pka esk) = + (\normalizedRid -> PKESKPayloadV6 normalizedRid pka esk) + <$> canonicalizeRecipientKeyIdentifier rid + +canonicalizeRecipientKeyIdentifier + :: BL.ByteString -> Either PKESKEncryptError BL.ByteString +canonicalizeRecipientKeyIdentifier rid + | BL.length rid == 20 || BL.length rid == 32 = Right rid + | BL.length rid == 21 && BL.head rid == 0x04 = + Right (BL.tail rid) + | BL.length rid == 33 && BL.head rid == 0x06 = + Right (BL.tail rid) + | otherwise = + Left + ( InvalidRecipientIdentifier + ( "unsupported PKESK recipient identifier length/prefix: " + ++ show (BL.length rid) + ) + ) + +canonicalizePKESKPacketRecipientIds + :: [Pkt] -> Either PKESKEncryptError [Pkt] +canonicalizePKESKPacketRecipientIds = + mapM + ( \pkt -> + case pkt of + PKESKPkt payload -> fmap PKESKPkt (canonicalizePKESKRecipientId payload) + _ -> Right pkt + ) + +-- | Build a v6 PKESK payload for one recipient key according to the selected version policy. +buildPKESKPayloadForRecipient + :: MonadRandom m + => PKESKVersionPolicy + -> SomePKPayload + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError PKESKPayload) +buildPKESKPayloadForRecipient policy recipient material = + case policy of + ForceV3Interop -> + buildPKESKv3PayloadForRecipient + recipient + (pkeskV3SessionMaterial material) + PreferV6 -> + case _pkalgo recipient of + RSA -> + fmap + (fmap PKESKPayloadV6Packet) + (buildRsaPKESKv6 recipient material) + ECDH -> + fmap + (fmap PKESKPayloadV6Packet) + (buildECDHPKESKv6 recipient material) + X25519 -> + fmap + (fmap PKESKPayloadV6Packet) + (buildX25519PKESKv6 recipient (pkeskV6RawSessionMaterial material)) + X448 -> + fmap + (fmap PKESKPayloadV6Packet) + (buildX448PKESKv6 recipient (pkeskV6RawSessionMaterial material)) + pka -> pure (Left (UnsupportedRecipientAlgorithm pka)) + +-- | Build a PKESK packet for one recipient key according to the selected version policy. +buildPKESKPktForRecipient + :: MonadRandom m + => PKESKVersionPolicy + -> SomePKPayload + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError Pkt) +buildPKESKPktForRecipient policy recipient material = + fmap + (fmap PKESKPkt) + (buildPKESKPayloadForRecipient policy recipient material) + +-- | Build a legacy PKESKv3 payload for v4/v3 RSA recipient interop. +buildPKESKv3PayloadForRecipient + :: MonadRandom m + => SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError PKESKPayload) +buildPKESKv3PayloadForRecipient recipient material = + fmap + (fmap PKESKPayloadV3Packet) + (buildPKESKv3PayloadForRecipientTyped recipient material) + +buildPKESKv3PayloadForRecipientTyped + :: MonadRandom m + => SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV3) +buildPKESKv3PayloadForRecipientTyped recipient material = + case _pkalgo recipient of + RSA -> buildRsaPKESKv3 recipient material + DeprecatedRSAEncryptOnly -> buildRsaPKESKv3 recipient material + ECDH -> buildECDHPKESKv3 recipient material + pka -> pure (Left (UnsupportedRecipientAlgorithm pka)) + +-- | Build a legacy PKESKv3 packet for v4/v3 RSA recipient interop. +buildPKESKv3PktForRecipient + :: MonadRandom m + => SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError Pkt) +buildPKESKv3PktForRecipient recipient material = + fmap + (fmap PKESKPkt) + (buildPKESKv3PayloadForRecipient recipient material) + +-- | Build PKESK packets for all recipients with a single shared session key. +buildPKESKPktsForRecipientTargetsWithSelector + :: MonadRandom m + => ( RecipientEncryptionTarget + -> Either PKESKEncryptError RecipientPKESKVersionStrategy + ) + -> [RecipientEncryptionTarget] + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError [Pkt]) +buildPKESKPktsForRecipientTargetsWithSelector selector targets material = + buildPKESKPktsForRecipientTargetsWithSelectorTyped + ( \target -> + promoteRecipientStrategy <$> selector target + ) + targets + material + +buildPKESKPktsForRecipientTargetsWithSelectorTyped + :: MonadRandom m + => ( RecipientEncryptionTarget + -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW + ) + -> [RecipientEncryptionTarget] + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError [Pkt]) +buildPKESKPktsForRecipientTargetsWithSelectorTyped selector targets material + | null targets = pure (Left NoRecipientsProvided) + | otherwise = + case preparePKESKVersionedMaterial material of + Left err -> pure (Left err) + Right (v3Material, v6RawMaterial) -> do + pkeskResults <- + mapM + ( \target -> + case selector target of + Left err -> pure (Left err) + Right (SomeRecipientPKESKVersionStrategyW RecipientPreferV6W) -> + buildPKESKPktForRecipientWithPreparedPayload + RecipientPreferV6W + (recipientEncryptionTargetKey target) + (RecipientPreferV6Payload material v6RawMaterial) + Right + (SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW) -> + buildPKESKPktForRecipientWithPreparedPayload + RecipientForceV3InteropW + (recipientEncryptionTargetKey target) + (RecipientForceV3Payload v3Material) + ) + targets + pure + (sequence pkeskResults >>= canonicalizePKESKPacketRecipientIds) + +preparePKESKVersionedMaterial + :: PKESKSessionMaterial + -> Either + PKESKEncryptError + (PKESKV3SessionMaterial, PKESKV6RawSessionMaterial) +preparePKESKVersionedMaterial material = do + v3Material <- + mkPKESKV3SessionMaterial + (pkeskSessionAlgorithm material) + (pkeskSessionKey material) + v6RawMaterial <- + mkPKESKV6RawSessionMaterial + (pkeskSessionAlgorithm material) + (pkeskSessionKey material) + pure (v3Material, v6RawMaterial) + +data + RecipientPKESKRequestPayload + (strategy :: RecipientPKESKVersionStrategy) + where + RecipientForceV3Payload + :: PKESKV3SessionMaterial + -> RecipientPKESKRequestPayload 'RecipientForceV3Interop + RecipientPreferV6Payload + :: PKESKSessionMaterial + -> PKESKV6RawSessionMaterial + -> RecipientPKESKRequestPayload 'RecipientPreferV6 + +buildPKESKPktForRecipientWithPreparedPayload + :: MonadRandom m + => RecipientPKESKVersionStrategyW strategy + -> SomePKPayload + -> RecipientPKESKRequestPayload strategy + -> m (Either PKESKEncryptError Pkt) +buildPKESKPktForRecipientWithPreparedPayload strategy recipient payload = + fmap fmapPKESKPkt payloadResult + where + fmapPKESKPkt = fmap PKESKPkt + payloadResult = + case (strategy, payload) of + (RecipientForceV3InteropW, RecipientForceV3Payload v3Material) -> + buildPKESKv3PayloadForRecipient recipient v3Material + ( RecipientPreferV6W + , RecipientPreferV6Payload material v6RawMaterial + ) -> + case _pkalgo recipient of + RSA -> + fmap + (fmap PKESKPayloadV6Packet) + (buildRsaPKESKv6 recipient material) + ECDH -> + fmap + (fmap PKESKPayloadV6Packet) + (buildECDHPKESKv6 recipient material) + X25519 -> + fmap + (fmap PKESKPayloadV6Packet) + (buildX25519PKESKv6 recipient v6RawMaterial) + X448 -> + fmap + (fmap PKESKPayloadV6Packet) + (buildX448PKESKv6 recipient v6RawMaterial) + pka -> + pure (Left (UnsupportedRecipientAlgorithm pka)) + +{- | Encrypt for recipient targets with capability negotiation enabled. + +By default this negotiates a common symmetric and (for SEIPDv2) AEAD +algorithm from recipient capabilities when available. Explicit request +overrides still take precedence. +-} +encryptForRecipients + :: MonadRandom m + => RecipientEncryptRequest v + -> m (Either PKESKEncryptError RecipientEncryptResult) +encryptForRecipients = + encryptForRecipientsWithCapabilityNegotiation + RecipientCapabilityNegotiationOn + +{- | Encrypt for recipient targets without recipient capability negotiation. + +This preserves legacy behavior by using policy defaults unless request +overrides are provided. +-} +encryptForRecipientsLegacy + :: MonadRandom m + => RecipientEncryptRequest v + -> m (Either PKESKEncryptError RecipientEncryptResult) +encryptForRecipientsLegacy = + encryptForRecipientsWithCapabilityNegotiation + RecipientCapabilityNegotiationOff + +{- | Encrypt for recipient targets with an explicit capability-negotiation mode. + +When negotiation is on, symmetric and AEAD selection use the common +intersection of recipient preferences constrained by the active policy. +When off, policy defaults are used. +-} +encryptForRecipientsWithCapabilityNegotiation + :: MonadRandom m + => RecipientCapabilityNegotiationMode + -> RecipientEncryptRequest v + -> m (Either PKESKEncryptError RecipientEncryptResult) +encryptForRecipientsWithCapabilityNegotiation negotiationMode request + | null targets = pure (Left NoRecipientsProvided) + | otherwise = + case selectSymmetricAlgorithm + negotiationMode + request + messagePolicy + targets of + Left err -> pure (Left err) + Right symalgo -> do + sessionMaterialResult <- generateSessionKeyMaterial symalgo + case sessionMaterialResult of + Left err -> pure (Left err) + Right sessionMaterial -> do + pkeskResult <- + buildPKESKPktsForRecipientTargetsWithSelectorTyped + (recipientVersionStrategyForProfileTyped profileW) + targets + sessionMaterial + case pkeskResult of + Left err -> pure (Left err) + Right pkeskPkts -> do + payloadResult <- case recipientEncryptRequestOverrides request of + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = aeadOverride + , recipientEncryptRequestChunkSizeOverride = chunkSizeOverride + , recipientEncryptRequestSaltOverride = saltOverride + } -> + case recipientsMissingSEIPDv2Support targets of + [] -> do + case selectAEADAlgorithm + negotiationMode + messagePolicy + targets + aeadOverride of + Left err -> pure (Left err) + Right aead -> do + salt <- maybe (Salt <$> getRandomBytes 32) pure saltOverride + let chunkSize = + maybe + (messageDefaultChunkSize messagePolicy) + id + chunkSizeOverride + pure $ + buildEncryptedPacketSequenceWithShape + symalgo + aead + chunkSize + (recipientEncryptRequestPayloadShape request) + salt + (pkeskSessionKey sessionMaterial) + pkeskPkts + (recipientEncryptRequestPayload request) + _missingSEIPDv2 -> + case recipientsMissingSEIPDv1Support targets of + [] -> + buildSEIPDv1PayloadWithIV + symalgo + sessionMaterial + pkeskPkts + Nothing + missingSEIPDv1 -> + pure + ( Left + ( RecipientCapabilitySelectionFailure + (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1) + ) + ) + RecipientEncryptRequestSEIPDv1Overrides + { recipientEncryptRequestIVOverride = ivOverride + } -> + case recipientsMissingSEIPDv1Support targets of + [] -> + buildSEIPDv1PayloadWithIV + symalgo + sessionMaterial + pkeskPkts + ivOverride + missingSEIPDv1 -> + pure + ( Left + ( RecipientCapabilitySelectionFailure + (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1) + ) + ) + pure $ + fmap + ( \pkts -> + RecipientEncryptResult + { recipientEncryptPackets = pkts + , recipientEncryptSessionMaterial = sessionMaterial + } + ) + payloadResult + where + targets = recipientEncryptRequestTargets request + profileW = + profileForPayloadVersionW + (recipientEncryptRequestOverrides request) + messagePolicy = + case profileW of + EncryptStrictDefaultW -> + policyMessageEncryption (policyForRFC RFC9580) + EncryptInteropLegacyW -> + policyMessageEncryption (policyForRFC RFC4880) + + buildSEIPDv1PayloadWithIV + :: MonadRandom m + => SymmetricAlgorithm + -> PKESKSessionMaterial + -> [Pkt] + -> Maybe IV + -> m (Either PKESKEncryptError [Pkt]) + buildSEIPDv1PayloadWithIV symalgo sessionMaterial pkeskPkts ivOverride = do + ivResult <- + case ivOverride of + Just iv -> pure (Right iv) + Nothing -> + let keyBytes = unSessionKey (pkeskSessionKey sessionMaterial) + in case withSymmetricCipher symalgo keyBytes (\c -> Right (blockSize c)) of + Left err -> pure (Left (PayloadBuildFailure (renderCipherError err))) + Right n -> fmap (Right . IV) (getRandomBytes n) + case ivResult of + Left err -> pure (Left err) + Right iv -> + pure $ + buildEncryptedPacketSequenceWithShapeSEIPDv1 + symalgo + iv + (recipientEncryptRequestPayloadShape request) + (pkeskSessionKey sessionMaterial) + pkeskPkts + (recipientEncryptRequestPayload request) + + recipientsMissingSEIPDv1Support + :: [RecipientEncryptionTarget] -> [SomePKPayload] + recipientsMissingSEIPDv1Support = + map recipientEncryptionTargetKey + . filter (not . targetAdvertisesSEIPDv1Support) + + recipientsMissingSEIPDv2Support + :: [RecipientEncryptionTarget] -> [SomePKPayload] + recipientsMissingSEIPDv2Support = + map recipientEncryptionTargetKey + . filter (not . targetAdvertisesSEIPDv2Support) + + targetAdvertisesSEIPDv1Support + :: RecipientEncryptionTarget -> Bool + targetAdvertisesSEIPDv1Support target = + case recipientEncryptionTargetCapabilities target of + Nothing -> True + Just caps -> recipientCapabilityAdvertisesSEIPDv1Support caps + + targetAdvertisesSEIPDv2Support + :: RecipientEncryptionTarget -> Bool + targetAdvertisesSEIPDv2Support target = + case recipientEncryptionTargetCapabilities target of + Nothing -> True + Just caps -> recipientCapabilityAdvertisesSEIPDv2Support caps + +selectSymmetricAlgorithm + :: RecipientCapabilityNegotiationMode + -> RecipientEncryptRequest v + -> MessageEncryptionPolicy + -> [RecipientEncryptionTarget] + -> Either PKESKEncryptError SymmetricAlgorithm +selectSymmetricAlgorithm negotiationMode request messagePolicy targets = + case recipientEncryptRequestSymmetricOverride request of + Just override -> Right override + Nothing -> + case negotiationMode of + RecipientCapabilityNegotiationOff -> + Right (messageDefaultSymmetricAlgorithm messagePolicy) + RecipientCapabilityNegotiationOn -> + negotiateSymmetricAlgorithm messagePolicy targets + +selectAEADAlgorithm + :: RecipientCapabilityNegotiationMode + -> MessageEncryptionPolicy + -> [RecipientEncryptionTarget] + -> Maybe AEADAlgorithm + -> Either PKESKEncryptError AEADAlgorithm +selectAEADAlgorithm negotiationMode messagePolicy targets override = + case override of + Just explicit -> Right explicit + Nothing -> + case negotiationMode of + RecipientCapabilityNegotiationOff -> + Right (messageDefaultAEADAlgorithm messagePolicy) + RecipientCapabilityNegotiationOn -> + negotiateAEADAlgorithm messagePolicy targets + +negotiateSymmetricAlgorithm + :: MessageEncryptionPolicy + -> [RecipientEncryptionTarget] + -> Either PKESKEncryptError SymmetricAlgorithm +negotiateSymmetricAlgorithm messagePolicy targets = + chooseCommonAlgorithm + policyOrder + recipientChoices + ( RecipientCapabilityNoCommonSymmetricAlgorithms + (concat recipientChoices) + ) + where + policyOrder = + case messageSEIPDv2SymmetricAlgorithms messagePolicy of + [] -> [messageDefaultSymmetricAlgorithm messagePolicy] + syms -> syms + recipientChoices = map choicesForTarget targets + choicesForTarget target = + case recipientEncryptionTargetCapabilities target of + Just caps -> + let preferred = recipientCapabilityPreferredSymmetricAlgorithms caps + allowed = [alg | alg <- policyOrder, alg `elem` preferred] + in if null allowed + then policyOrder + else allowed + Nothing -> policyOrder + +negotiateAEADAlgorithm + :: MessageEncryptionPolicy + -> [RecipientEncryptionTarget] + -> Either PKESKEncryptError AEADAlgorithm +negotiateAEADAlgorithm messagePolicy targets = + chooseCommonAlgorithm + policyOrder + recipientChoices + ( RecipientCapabilityNoCommonAEADAlgorithms + (concat recipientChoices) + ) + where + policyOrder = + foldl' + addIfMissing + [] + (messageDefaultAEADAlgorithm messagePolicy : [OCB, EAX, GCM]) + recipientChoices = map choicesForTarget targets + choicesForTarget target = + case recipientEncryptionTargetCapabilities target of + Just caps -> + let preferred = recipientCapabilityPreferredAEADAlgorithms caps + allowed = [alg | alg <- policyOrder, alg `elem` preferred] + in if null allowed + then policyOrder + else allowed + Nothing -> policyOrder + addIfMissing acc x + | x `elem` acc = acc + | otherwise = acc ++ [x] + +chooseCommonAlgorithm + :: Eq a + => [a] + -> [[a]] + -> RecipientCapabilityError + -> Either PKESKEncryptError a +chooseCommonAlgorithm policyOrder recipientChoices err = + case recipientChoices of + [] -> Left (RecipientCapabilitySelectionFailure err) + (firstChoices : restChoices) -> + let common = foldl' intersectOrdered firstChoices restChoices + orderedCommon = [alg | alg <- policyOrder, alg `elem` common] + in case orderedCommon of + (selected : _) -> Right selected + [] -> Left (RecipientCapabilitySelectionFailure err) + where + intersectOrdered as bs = [a | a <- as, a `elem` bs] + +promoteRecipientStrategy + :: RecipientPKESKVersionStrategy + -> SomeRecipientPKESKVersionStrategyW +promoteRecipientStrategy RecipientPreferV6 = + SomeRecipientPKESKVersionStrategyW RecipientPreferV6W +promoteRecipientStrategy RecipientForceV3Interop = + SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW + +demoteRecipientStrategy + :: RecipientPKESKVersionStrategyW strategy + -> RecipientPKESKVersionStrategy +demoteRecipientStrategy RecipientPreferV6W = RecipientPreferV6 +demoteRecipientStrategy RecipientForceV3InteropW = RecipientForceV3Interop + +demoteSomeRecipientStrategy + :: SomeRecipientPKESKVersionStrategyW + -> RecipientPKESKVersionStrategy +demoteSomeRecipientStrategy (SomeRecipientPKESKVersionStrategyW strategyW) = + demoteRecipientStrategy strategyW + +promoteEncryptCompatibilityProfile + :: EncryptCompatibilityProfile + -> SomeEncryptCompatibilityProfileW +promoteEncryptCompatibilityProfile EncryptStrictDefault = + SomeEncryptCompatibilityProfileW EncryptStrictDefaultW +promoteEncryptCompatibilityProfile EncryptInteropLegacy = + SomeEncryptCompatibilityProfileW EncryptInteropLegacyW + +{- | High-level encrypt-side helper for public-key recipient encryption. + +Returns a complete packet sequence: +@[PKESK ..., SEIPD2 ...]@. +-} +buildEncryptedPacketSequence + :: SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> RecipientPayloadShape + -> Salt + -> SessionKey + -> [Pkt] + -> B.ByteString + -> Either String [Pkt] +buildEncryptedPacketSequence symalgo aead chunkSize payloadShape salt sessionKey pkesks payload = + first + renderPKESKEncryptError + ( buildEncryptedPacketSequenceWithShape + symalgo + aead + chunkSize + payloadShape + salt + sessionKey + pkesks + payload + ) + +buildEncryptedPacketSequenceWithShape + :: SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> RecipientPayloadShape + -> Salt + -> SessionKey + -> [Pkt] + -> B.ByteString + -> Either PKESKEncryptError [Pkt] +buildEncryptedPacketSequenceWithShape symalgo aead chunkSize payloadShape salt sessionKey pkesks payload = do + onePassSignatures <- + first + (PayloadBuildFailure . renderOPSBuildError) + (buildOnePassSignaturePackets payloadShape) + let signatures = recipientPayloadSignatures payloadShape + literalBlock = + Block + ( onePassSignatures + ++ [ LiteralDataPkt + (recipientPayloadDataType payloadShape) + (recipientPayloadFileName payloadShape) + (recipientPayloadTimestamp payloadShape) + (BL.fromStrict payload) + ] + ++ map SignaturePkt signatures + ) + ciphertext <- + first PayloadBuildFailure $ + encryptSEIPDv2Payload + symalgo + aead + chunkSize + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) + Right + ( pkesks + ++ [ SymEncIntegrityProtectedDataPkt + (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict ciphertext)) + ] + ) + +-- | Encrypt a plaintext block with OpenPGP CFB + MDC to produce a SEIPDv1 ciphertext. +encryptSEIPDv1Payload + :: SymmetricAlgorithm + -> IV + -> SessionKey + -> B.ByteString + -- ^ inner packet block plaintext + -> Either String B.ByteString +encryptSEIPDv1Payload symalgo iv (SessionKey keyBytes) plaintext = + let cleartextWithMDC = plaintext <> mdcTrailerForSEIPDv1 iv plaintext + in first + renderCipherError + ( encryptOpenPGPCfbRaw + OpenPGPCFBNoResyncW + symalgo + iv + cleartextWithMDC + keyBytes + ) + +-- | Build a complete RFC 4880-conformant packet sequence using SEIPDv1 (CFB + MDC). +buildEncryptedPacketSequenceWithShapeSEIPDv1 + :: SymmetricAlgorithm + -> IV + -> RecipientPayloadShape + -> SessionKey + -> [Pkt] + -> B.ByteString + -> Either PKESKEncryptError [Pkt] +buildEncryptedPacketSequenceWithShapeSEIPDv1 symalgo iv payloadShape sessionKey pkesks payload = do + onePassSignatures <- + first + (PayloadBuildFailure . renderOPSBuildError) + (buildOnePassSignaturePackets payloadShape) + let signatures = recipientPayloadSignatures payloadShape + literalBlock = + Block + ( onePassSignatures + ++ [ LiteralDataPkt + (recipientPayloadDataType payloadShape) + (recipientPayloadFileName payloadShape) + (recipientPayloadTimestamp payloadShape) + (BL.fromStrict payload) + ] + ++ map SignaturePkt signatures + ) + ciphertext <- + first PayloadBuildFailure $ + encryptSEIPDv1Payload + symalgo + iv + sessionKey + (BL.toStrict (runPut (put literalBlock))) + Right + ( pkesks + ++ [ SymEncIntegrityProtectedDataPkt + (SEIPD1 1 (BL.fromStrict ciphertext)) + ] + ) + +buildOnePassSignaturePackets + :: RecipientPayloadShape -> Either OPSBuildError [Pkt] +buildOnePassSignaturePackets payloadShape + | not (recipientPayloadUseOnePassSignatures payloadShape) = + Right [] + | null signatures = Right [] + | otherwise = + fmap (map OnePassSignaturePkt) $ + sequence + (zipWith buildOnePassSignature nestedFlags (reverse signatures)) + where + signatures = recipientPayloadSignatures payloadShape + nestedFlags = replicate (length signatures - 1) True ++ [False] + +data OnePassSignatureBuildCase where + OnePassSignatureBuildCaseV3 + :: SignaturePayloadV 'SigPayloadV3 -> OnePassSignatureBuildCase + OnePassSignatureBuildCaseV4 + :: SignaturePayloadV 'SigPayloadV4 -> OnePassSignatureBuildCase + OnePassSignatureBuildCaseV6 + :: SignaturePayloadV 'SigPayloadV6 -> OnePassSignatureBuildCase + OnePassSignatureBuildCaseOther + :: PacketVersion -> OnePassSignatureBuildCase + +onePassSignatureBuildCase + :: SignaturePayload -> OnePassSignatureBuildCase +onePassSignatureBuildCase sig = + case toSomeSignaturePayload sig of + SomeSignaturePayload (payload@SigPayloadV3Data {}) -> + OnePassSignatureBuildCaseV3 payload + SomeSignaturePayload (payload@SigPayloadV4Data {}) -> + OnePassSignatureBuildCaseV4 payload + SomeSignaturePayload (payload@SigPayloadV6Data {}) -> + OnePassSignatureBuildCaseV6 payload + SomeSignaturePayload (SigPayloadOtherData version _) -> + OnePassSignatureBuildCaseOther version + +buildOnePassSignature + :: NestedFlag + -> SignaturePayload + -> Either OPSBuildError OnePassSignaturePayload +buildOnePassSignature nestedFlag sig = + case onePassSignatureBuildCase sig of + OnePassSignatureBuildCaseV3 + (SigPayloadV3Data sigType _ issuerKeyId pubkeyAlgo hashAlgo _ _) -> + Right + ( OPSPayloadV3Packet + (OPSPayloadV3 3 sigType hashAlgo pubkeyAlgo issuerKeyId nestedFlag) + ) + OnePassSignatureBuildCaseV4 + ( SigPayloadV4Data + sigType + pubkeyAlgo + hashAlgo + hashedSubpackets + unhashedSubpackets + _ + _ + ) -> + case signatureIssuerKeyId hashedSubpackets unhashedSubpackets of + Just issuerKeyId -> + Right + ( OPSPayloadV3Packet + (OPSPayloadV3 3 sigType hashAlgo pubkeyAlgo issuerKeyId nestedFlag) + ) + Nothing -> + Left OPSBuildMissingIssuerKeyId + OnePassSignatureBuildCaseV6 + ( SigPayloadV6Data + sigType + pubkeyAlgo + hashAlgo + salt + hashedSubpackets + unhashedSubpackets + _ + _ + ) -> + case signatureIssuerFingerprint + ( BTypes.issuerFingerprintVersionToPacketVersion + BTypes.IssuerFingerprintV6 + ) + hashedSubpackets + unhashedSubpackets of + Just signerFingerprint + | BL.length signerFingerprint == 32 -> + Right + ( OPSPayloadV6Packet + ( OPSPayloadV6 + sigType + hashAlgo + pubkeyAlgo + salt + signerFingerprint + nestedFlag + ) + ) + | otherwise -> + Left + (OPSBuildFingerprintWrongLength (BL.length signerFingerprint)) + Nothing -> + Left OPSBuildMissingIssuerFingerprint + OnePassSignatureBuildCaseOther version -> + Left (OPSBuildUnsupportedSigVersion version) + +signatureIssuerKeyId + :: [SigSubPacket] -> [SigSubPacket] -> Maybe EightOctetKeyId +signatureIssuerKeyId hashedSubpackets unhashedSubpackets = + case findIssuerKeyId hashedSubpackets of + Just issuerKeyId -> Just issuerKeyId + Nothing -> + case findIssuerKeyId unhashedSubpackets of + Just issuerKeyId -> Just issuerKeyId + Nothing -> + case signatureIssuerFingerprint + ( BTypes.issuerFingerprintVersionToPacketVersion + BTypes.IssuerFingerprintV4 + ) + hashedSubpackets + unhashedSubpackets of + Just issuerFingerprintBytes -> + if BL.length issuerFingerprintBytes >= 8 + then + Just + ( EightOctetKeyId + ( BL.drop + (BL.length issuerFingerprintBytes - 8) + issuerFingerprintBytes + ) + ) + else Nothing + Nothing -> Nothing + +signatureIssuerFingerprint + :: PacketVersion + -> [SigSubPacket] + -> [SigSubPacket] + -> Maybe BL.ByteString +signatureIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets = + unFingerprint + <$> findIssuerFingerprint + expectedVersion + hashedSubpackets + unhashedSubpackets + +findIssuerKeyId :: [SigSubPacket] -> Maybe EightOctetKeyId +findIssuerKeyId subpackets = + case find isIssuerKeyIdSubpacket subpackets of + Just (SigSubPacket _ (Issuer issuerKeyId)) -> Just issuerKeyId + _ -> Nothing + +findIssuerFingerprint + :: PacketVersion + -> [SigSubPacket] + -> [SigSubPacket] + -> Maybe Fingerprint +findIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets = + case findIssuerFingerprintIn expectedVersion hashedSubpackets of + Just issuerFingerprint -> Just issuerFingerprint + Nothing -> findIssuerFingerprintIn expectedVersion unhashedSubpackets + +findIssuerFingerprintIn + :: PacketVersion -> [SigSubPacket] -> Maybe Fingerprint +findIssuerFingerprintIn expectedVersion subpackets = + case find (isIssuerFingerprintSubpacket expectedVersion) subpackets of + Just (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) -> Just issuerFingerprint + _ -> Nothing + +isIssuerKeyIdSubpacket :: SigSubPacket -> Bool +isIssuerKeyIdSubpacket (SigSubPacket _ (Issuer _)) = True +isIssuerKeyIdSubpacket _ = False + +isIssuerFingerprintSubpacket + :: PacketVersion -> SigSubPacket -> Bool +isIssuerFingerprintSubpacket expectedVersion (SigSubPacket _ (IssuerFingerprint version _)) = + BTypes.issuerFingerprintVersionToPacketVersion version + == expectedVersion +isIssuerFingerprintSubpacket _ _ = False + +buildRsaPKESKv6 + :: MonadRandom m + => SomePKPayload + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV6) +buildRsaPKESKv6 recipient material = + case _pubkey recipient of + RSAPubKey (RSA_PublicKey publicKey) -> do + encrypted <- + RSA15.encrypt publicKey (pkeskEncodedSessionMaterial material) + pure $ + fmap + ( \esk -> + let mpiEsk = runPut (put (MPI (os2ip esk))) + in PKESKPayloadV6 (recipientKeyIdentifier recipient) RSA mpiEsk + ) + (first (RecipientKeyWrapFailure RSA . show) encrypted) + _ -> + pure + ( Left + ( InvalidRecipientKeyMaterial + RSA + "recipient PKPayload does not contain an RSA public key" + ) + ) + +buildRsaPKESKv3 + :: MonadRandom m + => SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV3) +buildRsaPKESKv3 recipient material = + case _pubkey recipient of + RSAPubKey (RSA_PublicKey publicKey) -> + case eightOctetKeyID recipient of + Left err -> + pure + ( Left + ( InvalidRecipientKeyMaterial + (_pkalgo recipient) + ("failed to derive PKESKv3 recipient key ID: " ++ err) + ) + ) + Right eoki -> do + encrypted <- + RSA15.encrypt publicKey (unPKESKV3SessionMaterial material) + pure $ + fmap + ( \esk -> + PKESKPayloadV3 + 3 + eoki + (_pkalgo recipient) + (MPI (os2ip esk) :| []) + ) + ( first + (RecipientKeyWrapFailure (_pkalgo recipient) . show) + encrypted + ) + _ -> + pure + ( Left + ( InvalidRecipientKeyMaterial + (_pkalgo recipient) + "recipient PKPayload does not contain an RSA public key" + ) + ) + +buildECDHPKESKv3 + :: MonadRandom m + => SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV3) +buildECDHPKESKv3 recipient material = + case _pubkey recipient of + ECDHPubKey ecdhPub kdfHA kdfSA -> + case eightOctetKeyID recipient of + Left err -> + pure + ( Left + ( InvalidRecipientKeyMaterial + ECDH + ("failed to derive PKESKv3 recipient key ID: " ++ err) + ) + ) + Right eoki -> + case ecdhPub of + ECDSAPubKey (ECDSA_PublicKey recipientPub) -> do + (ephemeralPub, ephemeralPriv) <- + ECCGen.generate (ECDSA.public_curve recipientPub) + case point2MBS (ECDSA.public_q ephemeralPub) of + Nothing -> + pure + ( Left + ( InvalidRecipientKeyMaterial + ECDH + "failed to serialize ECDH ephemeral point" + ) + ) + Just ephemeralBytes -> + pure $ + buildEcdhV3Payload + recipient + eoki + ECDH + ecdhPub + kdfHA + kdfSA + ephemeralBytes + ( BA.convert + ( ECCDH.getShared + (ECDSA.public_curve recipientPub) + (ECDSA.private_d ephemeralPriv) + (ECDSA.public_q recipientPub) + ) + :: B.ByteString + ) + material + EdDSAPubKey EdSigningCurve25519 recipientPoint -> do + ephSecretRaw <- getRandomBytes 32 + pure $ + do + recipientPublicBytes <- + normalizeX25519Public (edPointBytes recipientPoint) + ephSecret <- + first (RecipientKeyWrapFailure ECDH . show) + . CE.eitherCryptoError + $ C25519.secretKey (leftPadTo 32 ephSecretRaw) + recipientPub <- + first (RecipientKeyWrapFailure ECDH . show) + . CE.eitherCryptoError + $ C25519.publicKey recipientPublicBytes + let ephPublicBytes = + B.cons + 0x40 + (BA.convert (C25519.toPublic ephSecret) :: B.ByteString) + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + buildEcdhV3Payload + recipient + eoki + ECDH + ecdhPub + kdfHA + kdfSA + ephPublicBytes + sharedSecret + material + _ -> + pure + ( Left + ( InvalidRecipientKeyMaterial + ECDH + "recipient ECDH public key is not RFC6637-compatible" + ) + ) + _ -> + pure + ( Left + ( InvalidRecipientKeyMaterial + ECDH + "recipient PKPayload does not contain ECDH public key material" + ) + ) + +buildECDHPKESKv6 + :: MonadRandom m + => SomePKPayload + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV6) +buildECDHPKESKv6 recipient material = + case _pubkey recipient of + ECDHPubKey ecdhPub kdfHA kdfSA -> + case ecdhPub of + ECDSAPubKey (ECDSA_PublicKey recipientPub) -> do + (ephemeralPub, ephemeralPriv) <- + ECCGen.generate (ECDSA.public_curve recipientPub) + case point2MBS (ECDSA.public_q ephemeralPub) of + Nothing -> + pure + ( Left + ( InvalidRecipientKeyMaterial + ECDH + "failed to serialize ECDH ephemeral point" + ) + ) + Just ephemeralBytes -> + pure $ + buildEcdhV6Esk + recipient + ECDH + ecdhPub + kdfHA + kdfSA + ephemeralBytes + ( BA.convert + ( ECCDH.getShared + (ECDSA.public_curve recipientPub) + (ECDSA.private_d ephemeralPriv) + (ECDSA.public_q recipientPub) + ) + :: B.ByteString + ) + material + EdDSAPubKey EdSigningCurve25519 recipientPoint -> do + ephSecretRaw <- getRandomBytes 32 + pure $ + do + recipientPublicBytes <- + normalizeX25519Public (edPointBytes recipientPoint) + ephSecret <- + first (RecipientKeyWrapFailure ECDH . show) + . CE.eitherCryptoError + $ C25519.secretKey (leftPadTo 32 ephSecretRaw) + recipientPub <- + first (RecipientKeyWrapFailure ECDH . show) + . CE.eitherCryptoError + $ C25519.publicKey recipientPublicBytes + let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + buildEcdhV6Esk + recipient + ECDH + ecdhPub + kdfHA + kdfSA + ephPublicBytes + sharedSecret + material + EdDSAPubKey EdSigningCurve448 recipientPoint -> do + ephSecretRaw <- getRandomBytes 56 + pure $ + do + recipientPublicBytes <- + normalizeX448Public (edPointBytes recipientPoint) + ephSecret <- + first (RecipientKeyWrapFailure ECDH . show) + . CE.eitherCryptoError + $ C448.secretKey (leftPadTo 56 ephSecretRaw) + recipientPub <- + first (RecipientKeyWrapFailure ECDH . show) + . CE.eitherCryptoError + $ C448.publicKey recipientPublicBytes + let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString + sharedSecret = BA.convert (C448.dh recipientPub ephSecret) :: B.ByteString + buildEcdhV6Esk + recipient + ECDH + ecdhPub + kdfHA + kdfSA + ephPublicBytes + sharedSecret + material + _ -> + pure + ( Left + ( InvalidRecipientKeyMaterial + ECDH + "recipient ECDH public key is not ECDSA/X25519/X448-compatible" + ) + ) + _ -> + pure + ( Left + ( InvalidRecipientKeyMaterial + ECDH + "recipient PKPayload does not contain ECDH public key material" + ) + ) + +buildX25519PKESKv6 + :: MonadRandom m + => SomePKPayload + -> PKESKV6RawSessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV6) +buildX25519PKESKv6 recipient material = do + ephSecretRaw <- getRandomBytes 32 + pure $ + do + recipientPublic <- extractX25519RecipientPublic recipient + ephSecret <- + first (RecipientKeyWrapFailure X25519 . show) + . CE.eitherCryptoError + $ C25519.secretKey (leftPadTo 32 ephSecretRaw) + recipientPub <- + first (RecipientKeyWrapFailure X25519 . show) + . CE.eitherCryptoError + $ C25519.publicKey recipientPublic + let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX25519Kek ephPublicBytes recipientPublic sharedSecret + wrapped <- + first (RecipientKeyWrapFailure X25519) + . aesKeyWrapRFC3394 AES128 kek + $ unPKESKV6RawSessionMaterial material + esk <- encodeV6X25519Esk ephPublicBytes wrapped + Right + ( PKESKPayloadV6 + (recipientKeyIdentifier recipient) + X25519 + (BL.fromStrict esk) + ) + +buildX448PKESKv6 + :: MonadRandom m + => SomePKPayload + -> PKESKV6RawSessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV6) +buildX448PKESKv6 recipient material = do + ephSecretRaw <- getRandomBytes 56 + pure $ + do + recipientPublic <- extractX448RecipientPublic recipient + ephSecret <- + first (RecipientKeyWrapFailure X448 . show) + . CE.eitherCryptoError + $ C448.secretKey (leftPadTo 56 ephSecretRaw) + recipientPub <- + first (RecipientKeyWrapFailure X448 . show) + . CE.eitherCryptoError + $ C448.publicKey recipientPublic + let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString + sharedSecret = BA.convert (C448.dh recipientPub ephSecret) :: B.ByteString + kek = deriveX448Kek ephPublicBytes recipientPublic sharedSecret + wrapped <- + first (RecipientKeyWrapFailure X448) + . aesKeyWrapRFC3394 AES256 kek + $ unPKESKV6RawSessionMaterial material + esk <- encodeV6X448Esk ephPublicBytes wrapped + Right + ( PKESKPayloadV6 + (recipientKeyIdentifier recipient) + X448 + (BL.fromStrict esk) + ) + +buildEcdhV6Esk + :: SomePKPayload + -> PubKeyAlgorithm + -> PKey + -> HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> PKESKSessionMaterial + -> Either PKESKEncryptError PKESKPayloadV6 +buildEcdhV6Esk recipient pka ecdhPub kdfHA kdfSA ephemeralBytes sharedSecret material = do + kdfParam <- + first (RecipientKdfFailure pka) $ + buildECDHKDFParam recipient pka ecdhPub kdfHA kdfSA + kek <- + first (RecipientKdfFailure pka) $ + deriveECDHKek kdfHA kdfSA sharedSecret kdfParam + wrapped <- + first (RecipientKeyWrapFailure pka) + . aesKeyWrapRFC3394 kdfSA kek + $ padToMultipleOf8 (pkeskEncodedSessionMaterial material) + esk <- encodeV6EcdhEsk ephemeralBytes wrapped + Right + ( PKESKPayloadV6 + (recipientKeyIdentifier recipient) + pka + (BL.fromStrict esk) + ) + +buildEcdhV3Payload + :: SomePKPayload + -> EightOctetKeyId + -> PubKeyAlgorithm + -> PKey + -> HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> PKESKV3SessionMaterial + -> Either PKESKEncryptError PKESKPayloadV3 +buildEcdhV3Payload recipient eoki pka ecdhPub kdfHA kdfSA ephemeralBytes sharedSecret material = do + kdfParam <- + first (RecipientKdfFailure pka) $ + buildECDHKDFParam recipient pka ecdhPub kdfHA kdfSA + kek <- + first (RecipientKdfFailure pka) $ + deriveECDHKek kdfHA kdfSA sharedSecret kdfParam + wrapped <- + first (RecipientKeyWrapFailure pka) + . aesKeyWrapRFC3394 kdfSA kek + $ padToMultipleOf8 (unPKESKV3SessionMaterial material) + Right + ( PKESKPayloadV3 + 3 + eoki + pka + (MPI (os2ip ephemeralBytes) :| [MPI (os2ip wrapped)]) + ) + +recipientKeyIdentifier :: SomePKPayload -> BL.ByteString +recipientKeyIdentifier = unFingerprint . fingerprint + +encodeV6EcdhEsk + :: B.ByteString + -> B.ByteString + -> Either PKESKEncryptError B.ByteString +encodeV6EcdhEsk ephemeral wrapped = do + let ephLen = B.length ephemeral + if ephLen > 255 + then + Left + ( RecipientKeyWrapFailure + ECDH + "ephemeral key encoding is too large" + ) + else + Right (B.singleton (fromIntegral ephLen) <> ephemeral <> wrapped) + +encodeV6X25519Esk + :: B.ByteString + -> B.ByteString + -> Either PKESKEncryptError B.ByteString +encodeV6X25519Esk ephemeral wrapped + | B.length ephemeral /= 32 = + Left + ( RecipientKeyWrapFailure + X25519 + "X25519 ephemeral key must be exactly 32 octets" + ) + | B.length wrapped > 255 = + Left + ( RecipientKeyWrapFailure + X25519 + "wrapped session key encoding is too large" + ) + | otherwise = + Right + ( ephemeral + <> B.singleton (fromIntegral (B.length wrapped)) + <> wrapped + ) + +encodeV6X448Esk + :: B.ByteString + -> B.ByteString + -> Either PKESKEncryptError B.ByteString +encodeV6X448Esk ephemeral wrapped + | B.length ephemeral /= 56 = + Left + ( RecipientKeyWrapFailure + X448 + "X448 ephemeral key must be exactly 56 octets" + ) + | B.length wrapped > 255 = + Left + ( RecipientKeyWrapFailure + X448 + "wrapped session key encoding is too large" + ) + | otherwise = + Right + ( ephemeral + <> B.singleton (fromIntegral (B.length wrapped)) + <> wrapped + ) + +extractX25519RecipientPublic + :: SomePKPayload -> Either PKESKEncryptError B.ByteString +extractX25519RecipientPublic recipient = + case _pubkey recipient of + EdDSAPubKey EdSigningCurve25519 point -> + normalizeX25519Public (edPointBytes point) + ECDHPubKey (EdDSAPubKey EdSigningCurve25519 point) _ _ -> + normalizeX25519Public (edPointBytes point) + other -> + Left + ( InvalidRecipientKeyMaterial + X25519 + ("expected X25519-compatible recipient key, got " ++ show other) + ) + +extractX448RecipientPublic + :: SomePKPayload -> Either PKESKEncryptError B.ByteString +extractX448RecipientPublic recipient = + case _pubkey recipient of + EdDSAPubKey EdSigningCurve448 point -> + normalizeX448Public (edPointBytes point) + ECDHPubKey (EdDSAPubKey EdSigningCurve448 point) _ _ -> + normalizeX448Public (edPointBytes point) + other -> + Left + ( InvalidRecipientKeyMaterial + X448 + ("expected X448-compatible recipient key, got " ++ show other) + ) + +normalizeX25519Public + :: B.ByteString -> Either PKESKEncryptError B.ByteString +normalizeX25519Public = + first (InvalidRecipientKeyMaterial X25519) + . normalizeMontgomeryPublic + 32 + "invalid X25519 public key length/prefix: " + +normalizeX448Public + :: B.ByteString -> Either PKESKEncryptError B.ByteString +normalizeX448Public = + first (InvalidRecipientKeyMaterial X448) + . normalizeMontgomeryPublic + 56 + "invalid X448 public key length/prefix: " + +edPointBytes :: EdPoint -> B.ByteString +edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x +edPointBytes (NativeEPoint (EPoint x)) = i2osp x + +deriveX25519Kek + :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +deriveX25519Kek ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHAlg.SHA256 B.empty ikm + info = "OpenPGP X25519" :: B.ByteString + in expand @CHAlg.SHA256 prk info 16 + +deriveX448Kek + :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +deriveX448Kek ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHAlg.SHA512 B.empty ikm + info = "OpenPGP X448" :: B.ByteString + in expand @CHAlg.SHA512 prk info 32 + +padToMultipleOf8 :: B.ByteString -> B.ByteString +padToMultipleOf8 bs + | padLen == 0 = bs + | otherwise = bs <> B.replicate padLen (fromIntegral padLen) + where + rem8 = B.length bs `mod` 8 + padLen = if rem8 == 0 then 0 else 8 - rem8 + +checksum16 :: B.ByteString -> Word16 +checksum16 = + fromIntegral + . B.foldl' + (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) + 0 + +checksum16Bytes :: B.ByteString -> B.ByteString +checksum16Bytes bs = + B.pack + [ fromIntegral ((chk `shiftR` 8) .&. 0xff) + , fromIntegral (chk .&. 0xff) + ] + where + chk = checksum16 bs + +aesKeyWrapRFC3394 + :: SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> Either String B.ByteString +aesKeyWrapRFC3394 sa kek plain = + withAESCipher + "ECDH PKESK currently supports AES KEK algorithms only" + sa + kek + wrapWithCipher + where + wrapWithCipher + :: CCT.BlockCipher cipher => cipher -> Either String B.ByteString + wrapWithCipher cipher = do + if B.length plain < 16 || B.length plain `mod` 8 /= 0 + then + Left + "ECDH key wrap input must be at least 16 octets and a multiple of 8" + else Right () + let rs = chunksOf8 plain + if length rs < 2 + then + Left + "ECDH key wrap input must contain at least two 64-bit blocks" + else Right () + (aFinal, rFinal) <- wrapRounds cipher (B.replicate 8 0xA6) rs + Right (aFinal <> B.concat rFinal) + wrapRounds + :: CCT.BlockCipher cipher + => cipher + -> B.ByteString + -> [B.ByteString] + -> Either String (B.ByteString, [B.ByteString]) + wrapRounds cipher aInit rsInit = goJ 0 aInit rsInit + where + n = length rsInit + goJ j a rs + | j > 5 = Right (a, rs) + | otherwise = do + (a', rs') <- goI 1 a rs + goJ (j + 1) a' rs' + where + goI i curA curRs + | i > n = Right (curA, curRs) + | otherwise = do + let t = fromIntegral (n * j + i) :: Word64 + rI = curRs !! (i - 1) + block = CCT.ecbEncrypt cipher (curA <> rI) + (msb, lsb) = B.splitAt 8 block + aNext = xorBS msb (encodeWord64be t) + rsNext = (ix (i - 1) .~ lsb) curRs + goI (i + 1) aNext rsNext + +chunksOf8 :: B.ByteString -> [B.ByteString] +chunksOf8 bs + | B.null bs = [] + | otherwise = + let (h, t) = B.splitAt 8 bs + in h : chunksOf8 t + +xorBS :: B.ByteString -> B.ByteString -> B.ByteString +xorBS a b = B.pack (B.zipWith xor a b) + +encryptSEIPDv1WithSKESK + :: MonadRandom m + => SymmetricAlgorithm + -> S2K + -> Maybe IV + -> BL.ByteString + -> B.ByteString + -> m (Either String [Pkt]) +encryptSEIPDv1WithSKESK symalgo s2k ivOverride passphrase literalPayload = do + let eSessionKey = do + keyLen <- symKeySize symalgo + first renderS2KError (string2Key s2k keyLen passphrase) + case eSessionKey of + Left err -> pure (Left err) + Right sessionKeyMaterial -> + case first + renderCipherError + (withSymmetricCipher symalgo sessionKeyMaterial (pure . blockSize)) of + Left err -> pure (Left err) + Right ivLength -> do + ivBytes <- + maybe + (getRandomBytes ivLength) + (pure . unIV) + ivOverride + let iv = IV ivBytes + let sessionKey = SessionKey sessionKeyMaterial + case encryptSEIPDv1Payload symalgo iv sessionKey literalPayload of + Left err -> pure (Left err) + Right encrypted -> + pure + ( Right + [ SKESKPkt + ( SKESKPayloadV4Packet + (SKESKPayloadV4 symalgo s2k Nothing) + ) + , SymEncIntegrityProtectedDataPkt + (SEIPD1 1 (BL.fromStrict encrypted)) + ] + ) + +encryptSEIPDv2WithSKESK + :: SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> S2K + -> BL.ByteString + -> B.ByteString + -> Either String [Pkt] +encryptSEIPDv2WithSKESK symalgo aead chunkSize salt s2k passphrase literalPayload = do + keyLen <- symKeySize symalgo + sessionKeyMaterial <- + first renderS2KError (string2Key s2k keyLen passphrase) + (_, nonceSize) <- + aeadModeAndNonceSizeForSEIPDv2 + "unsupported AEAD algorithm for SKESK v6 encrypt" + aead + when (B.length (unSalt salt) < nonceSize) $ + Left "SEIPD v2 salt is too short to derive the SKESK v6 IV" + let skeskIV = B.take nonceSize (unSalt salt) + kek <- deriveSKESK6KEK symalgo aead sessionKeyMaterial + (wrappedSessionKey, skeskTag) <- + encryptSKESK6SessionKey + symalgo + aead + kek + skeskIV + sessionKeyMaterial + let sessionKey = SessionKey sessionKeyMaterial + encrypted <- + encryptSEIPDv2Payload + symalgo + aead + chunkSize + salt + sessionKey + literalPayload + return + [ SKESKPkt + ( SKESKPayloadV6Packet + ( SKESKPayloadV6 + symalgo + aead + s2k + (BL.fromStrict skeskIV) + (BL.fromStrict wrappedSessionKey) + (BL.fromStrict skeskTag) + ) + ) + , SymEncIntegrityProtectedDataPkt + (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict encrypted)) + ] + +encryptSEIPDv2WithSKESKBlock + :: SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> S2K + -> BL.ByteString + -> Block Pkt + -> Either String [Pkt] +encryptSEIPDv2WithSKESKBlock symalgo aead chunkSize salt s2k passphrase packetBlock = + encryptSEIPDv2WithSKESK + symalgo + aead + chunkSize + salt + s2k + passphrase + (BL.toStrict (runPut (put packetBlock))) + +encryptSEIPDv2LiteralDataWithSKESK + :: SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> S2K + -> BL.ByteString + -> B.ByteString + -> Either String [Pkt] +encryptSEIPDv2LiteralDataWithSKESK symalgo aead chunkSize salt s2k passphrase payload = + encryptSEIPDv2WithSKESKBlock + symalgo + aead + chunkSize + salt + s2k + passphrase + ( Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + (BL.fromStrict payload) + ] + ) + +encryptSEIPDv2Payload + :: SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> SessionKey + -> B.ByteString + -> Either String B.ByteString +encryptSEIPDv2Payload symalgo aead chunkSize salt (SessionKey sessionKey) plaintext = do + (mode, nonceSize) <- aeadModeAndNonceSize aead + keyLen <- symKeySize symalgo + let outputLen = keyLen + nonceSize - 8 + info = B.pack [0xd2, 2, fromFVal symalgo, fromFVal aead, chunkSize] + prk = extract @CHAlg.SHA256 (unSalt salt) sessionKey + okm = expand @CHAlg.SHA256 prk info outputLen :: B.ByteString + messageKey = B.take keyLen okm + noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm) + withAESCipher + "SEIPD v2 encrypt currently supports AES-128/192/256 only" + symalgo + messageKey + (encryptChunks mode info chunkSize noncePrefix plaintext) + +encryptChunks + :: CCT.BlockCipher cipher + => CCT.AEADMode + -> B.ByteString + -> Word8 + -> B.ByteString + -> B.ByteString + -> cipher + -> Either String B.ByteString +encryptChunks mode info chunkSize noncePrefix plaintext cipher = go 0 plaintext [] 0 + where + chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6) + go idx remaining acc totalPlain + | B.null remaining = do + (finalTag, finalCipher) <- + if mode == CCT.AEAD_OCB + then + encryptWithOCBRFC7253 + cipher + (noncePrefix <> encodeWord64be idx) + (info <> encodeWord64be (fromIntegral totalPlain)) + B.empty + else do + aead <- initAEAD idx + let (tag, out) = + CCT.aeadSimpleEncrypt + aead + (info <> encodeWord64be (fromIntegral totalPlain)) + B.empty + 16 + Right (tag, out) + if B.null finalCipher + then return (B.concat (reverse acc) <> authTagToBS finalTag) + else Left "expected empty ciphertext for final SEIPD v2 tag" + | otherwise = do + let (chunkPlain, rest) = B.splitAt chunkLen remaining + (tag, chunkCipher) <- + if mode == CCT.AEAD_OCB + then + encryptWithOCBRFC7253 + cipher + (noncePrefix <> encodeWord64be idx) + info + chunkPlain + else do + aead <- initAEAD idx + pure (CCT.aeadSimpleEncrypt aead info chunkPlain 16) + let chunkOut = chunkCipher <> authTagToBS tag + go + (idx + 1) + rest + (chunkOut : acc) + (totalPlain + B.length chunkPlain) + + initAEAD idx = + first show . CE.eitherCryptoError $ + CCT.aeadInit mode cipher (noncePrefix <> encodeWord64be idx) + +aeadModeAndNonceSize + :: AEADAlgorithm -> Either String (CCT.AEADMode, Int) +aeadModeAndNonceSize = + aeadModeAndNonceSizeForSEIPDv2 + "unsupported AEAD algorithm for SEIPD v2 encrypt" + +symKeySize :: SymmetricAlgorithm -> Either String Int +symKeySize = + seipdv2SymmetricKeySize + "unsupported symmetric algorithm for SEIPD v2 encrypt" + +authTagToBS :: CCT.AuthTag -> B.ByteString +authTagToBS = BA.convert . CCT.unAuthTag + +encodeWord64be :: Word64 -> B.ByteString +encodeWord64be = BL.toStrict . runPut . putWord64be + +{- | Compose a complete AEAD-encrypted message with optional literal data and signature. +Returns a packet list (SKESK, SEIPD v2, optional signature) ready for serialization. + +Example: @composeMessageWithSEIPDv2 AES256 OCB 6 (Salt 32 bytes) + (SimpleS2K SHA256) passphrase payload Nothing@ +returns @[SKESK v6, SEIPD v2, ]@ + +If the signature is provided, it will be included in the encrypted payload. +-} +composeMessageWithSEIPDv2 + :: SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> S2K + -> BL.ByteString + -> B.ByteString + -> Maybe [Pkt] + -> Either String [Pkt] +composeMessageWithSEIPDv2 symalgo aead chunkSize salt s2k passphrase payload mSigs = do + let packets = case mSigs of + Nothing -> + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + (BL.fromStrict payload) + ] + Just sigs -> + LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + (BL.fromStrict payload) + : sigs + blockPayload = Block packets + encryptSEIPDv2WithSKESKBlock + symalgo + aead + chunkSize + salt + s2k + passphrase + blockPayload diff --git a/Codec/Encryption/OpenPGP/Internal.hs b/Codec/Encryption/OpenPGP/Internal.hs --- a/Codec/Encryption/OpenPGP/Internal.hs +++ b/Codec/Encryption/OpenPGP/Internal.hs @@ -2,35 +2,33 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Codec.Encryption.OpenPGP.Internal - ( countBits - , PktStreamContext(..) - , issuer - , issuerFP - , emptyPSC - , leftPadTo - , pubkeyToMPIs - , multiplicativeInverse - , curveoidBSToCurve - , curveToCurveoidBS - , point2MBS - , curveoidBSToEdSigningCurve - , edSigningCurveToCurveoidBS - , curve2Curve - , curveFromCurve - ) where + ( countBits + , PktStreamContext (..) + , issuer + , issuerFP + , emptyPSC + , leftPadTo + , pubkeyToMPIs + , multiplicativeInverse + , curveoidBSToCurve + , curveToCurveoidBS + , point2MBS + , curveoidBSToEdSigningCurve + , edSigningCurveToCurveoidBS + , curve2Curve + , curveFromCurve + ) where import Crypto.Number.Serialize (i2osp, os2ip) import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Types as ECCT import qualified Crypto.PubKey.RSA as RSA - import Data.Bits (testBit) import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) @@ -38,24 +36,28 @@ import Data.List (find) import Data.Word (Word16, Word8) -import Codec.Encryption.OpenPGP.Ontology (isIssuerSSP, isSigCreationTime) +import Codec.Encryption.OpenPGP.Ontology + ( isIssuerSSP + , isSigCreationTime + ) import Codec.Encryption.OpenPGP.Types countBits :: ByteString -> Word16 countBits bs - | BL.null bs = 0 - | otherwise = - fromIntegral (BL.length bs * 8) - fromIntegral (go (BL.head bs) 7) + | BL.null bs = 0 + | otherwise = + fromIntegral (BL.length bs * 8) + - fromIntegral (go (BL.head bs) 7) where go :: Word8 -> Int -> Word8 go _ 0 = 7 go n b = - if testBit n b - then 7 - fromIntegral b - else go n (b - 1) + if testBit n b + then 7 - fromIntegral b + else go n (b - 1) -data PktStreamContext = - PktStreamContext +data PktStreamContext + = PktStreamContext { lastLD :: Pkt , lastUIDorUAt :: Pkt , lastSig :: Pkt @@ -65,47 +67,50 @@ emptyPSC :: PktStreamContext emptyPSC = - PktStreamContext - (OtherPacketPkt 0 "lastLD placeholder") - (OtherPacketPkt 0 "lastUIDorUAt placeholder") - (OtherPacketPkt 0 "lastSig placeholder") - (OtherPacketPkt 0 "lastPrimaryKey placeholder") - (OtherPacketPkt 0 "lastSubkey placeholder") + PktStreamContext + (OtherPacketPkt 0 "lastLD placeholder") + (OtherPacketPkt 0 "lastUIDorUAt placeholder") + (OtherPacketPkt 0 "lastSig placeholder") + (OtherPacketPkt 0 "lastPrimaryKey placeholder") + (OtherPacketPkt 0 "lastSubkey placeholder") leftPadTo :: Int -> B.ByteString -> B.ByteString leftPadTo targetLen bs - | B.length bs >= targetLen = bs - | otherwise = B.replicate (targetLen - B.length bs) 0 <> bs + | B.length bs >= targetLen = bs + | otherwise = B.replicate (targetLen - B.length bs) 0 <> bs issuer :: Pkt -> Maybe EightOctetKeyId issuer pkt = - case fromPktIssuerExtractionCase pkt of - Just extractionCase -> - find isIssuerSSP (unhashedSubpackets extractionCase) >>= issuerFromSubpacket - Nothing -> Nothing + case fromPktIssuerExtractionCase pkt of + Just extractionCase -> + find isIssuerSSP (unhashedSubpackets extractionCase) + >>= issuerFromSubpacket + Nothing -> Nothing issuerFP :: Pkt -> Maybe Fingerprint issuerFP pkt = - case fromPktIssuerExtractionCase pkt of - Just extractionCase -> - find - (isIssuerFingerprintFor (issuerFingerprintVersion extractionCase)) - (hashedSubpackets extractionCase) >>= - issuerFingerprintFromSubpacket - Nothing -> Nothing + case fromPktIssuerExtractionCase pkt of + Just extractionCase -> + find + (isIssuerFingerprintFor (issuerFingerprintVersion extractionCase)) + (hashedSubpackets extractionCase) + >>= issuerFingerprintFromSubpacket + Nothing -> Nothing data IssuerExtractionCase where - IssuerExtractionCaseV4 :: SignaturePayloadV 'SigPayloadV4 -> IssuerExtractionCase - IssuerExtractionCaseV6 :: SignaturePayloadV 'SigPayloadV6 -> IssuerExtractionCase + IssuerExtractionCaseV4 + :: SignaturePayloadV 'SigPayloadV4 -> IssuerExtractionCase + IssuerExtractionCaseV6 + :: SignaturePayloadV 'SigPayloadV6 -> IssuerExtractionCase fromPktIssuerExtractionCase :: Pkt -> Maybe IssuerExtractionCase fromPktIssuerExtractionCase pkt = - case fromPktEitherSomeSignatureV pkt of - Right (SomeSignatureV (SignatureV4Packet payload)) -> - Just (IssuerExtractionCaseV4 payload) - Right (SomeSignatureV (SignatureV6Packet payload)) -> - Just (IssuerExtractionCaseV6 payload) - _ -> Nothing + case fromPktEitherSomeSignatureV pkt of + Right (SomeSignatureV (SignatureV4Packet payload)) -> + Just (IssuerExtractionCaseV4 payload) + Right (SomeSignatureV (SignatureV6Packet payload)) -> + Just (IssuerExtractionCaseV6 payload) + _ -> Nothing hashedSubpackets :: IssuerExtractionCase -> [SigSubPacket] hashedSubpackets (IssuerExtractionCaseV4 (SigPayloadV4Data _ _ _ hsubs _ _ _)) = hsubs @@ -115,16 +120,19 @@ unhashedSubpackets (IssuerExtractionCaseV4 (SigPayloadV4Data _ _ _ _ usubs _ _)) = usubs unhashedSubpackets (IssuerExtractionCaseV6 (SigPayloadV6Data _ _ _ _ _ usubs _ _)) = usubs -issuerFingerprintVersion :: IssuerExtractionCase -> IssuerFingerprintVersion +issuerFingerprintVersion + :: IssuerExtractionCase -> IssuerFingerprintVersion issuerFingerprintVersion IssuerExtractionCaseV4 {} = IssuerFingerprintV4 issuerFingerprintVersion IssuerExtractionCaseV6 {} = IssuerFingerprintV6 -isIssuerFingerprintFor :: IssuerFingerprintVersion -> SigSubPacket -> Bool +isIssuerFingerprintFor + :: IssuerFingerprintVersion -> SigSubPacket -> Bool isIssuerFingerprintFor version (SigSubPacket _ (IssuerFingerprint packetVersion _)) = - packetVersion == version + packetVersion == version isIssuerFingerprintFor _ _ = False -issuerFingerprintFromSubpacket :: SigSubPacket -> Maybe Fingerprint +issuerFingerprintFromSubpacket + :: SigSubPacket -> Maybe Fingerprint issuerFingerprintFromSubpacket (SigSubPacket _ (IssuerFingerprint _ i)) = Just i issuerFingerprintFromSubpacket _ = Nothing @@ -134,28 +142,33 @@ pubkeyToMPIs :: PKey -> [MPI] pubkeyToMPIs (RSAPubKey (RSA_PublicKey k)) = - [MPI (RSA.public_n k), MPI (RSA.public_e k)] + [MPI (RSA.public_n k), MPI (RSA.public_e k)] pubkeyToMPIs (DSAPubKey (DSA_PublicKey k)) = - [ pkParams DSA.params_p - , pkParams DSA.params_q - , pkParams DSA.params_g - , MPI . DSA.public_y $ k - ] + [ pkParams DSA.params_p + , pkParams DSA.params_q + , pkParams DSA.params_g + , MPI . DSA.public_y $ k + ] where pkParams f = MPI . f . DSA.public_params $ k pubkeyToMPIs (ElGamalPubKey p g y) = [MPI p, MPI g, MPI y] -pubkeyToMPIs (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey _ q))) _ _) = - [MPI (os2ip (pointToBSOrError q))] +pubkeyToMPIs + ( ECDHPubKey + (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey _ q))) + _ + _ + ) = + [MPI (os2ip (pointToBSOrError q))] pubkeyToMPIs (ECDHPubKey (EdDSAPubKey _ ep) _ _) = [MPI (edPointInteger ep)] pubkeyToMPIs (ECDSAPubKey ((ECDSA_PublicKey (ECDSA.PublicKey _ q)))) = - [MPI (os2ip (pointToBSOrError q))] + [MPI (os2ip (pointToBSOrError q))] pubkeyToMPIs (EdDSAPubKey _ ep) = [MPI (edPointInteger ep)] edPointInteger :: EdPoint -> Integer edPointInteger (PrefixedNativeEPoint (EPoint x)) = x edPointInteger (NativeEPoint (EPoint x)) = x -multiplicativeInverse :: Integral a => a -> a -> a +multiplicativeInverse :: (Integral a) => a -> a -> a multiplicativeInverse _ 1 = 1 multiplicativeInverse q p = (n * q + 1) `div` p where @@ -163,31 +176,37 @@ curveoidBSToCurve :: B.ByteString -> Either String ECCCurve curveoidBSToCurve oidbs - | B.pack [0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07] == oidbs = - Right $ NISTP256 -- ECCT.getCurveByName ECCT.SEC_p256r1 - | B.pack [0x2B, 0x81, 0x04, 0x00, 0x22] == oidbs = Right $ NISTP384 -- ECCT.getCurveByName ECCT.SEC_p384r1 - | B.pack [0x2B, 0x81, 0x04, 0x00, 0x23] == oidbs = Right $ NISTP521 -- ECCT.getCurveByName ECCT.SEC_p521r1 - | B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0x97, 0x55, 0x01, 0x05, 0x01] == oidbs = - Right Curve25519 - | B.pack [0x2B, 0x65, 0x6F] == oidbs = - Right Curve448 - | otherwise = Left $ concat ["unknown curve (...", show (B.unpack oidbs), ")"] + | B.pack [0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07] == oidbs = + Right $ NISTP256 -- ECCT.getCurveByName ECCT.SEC_p256r1 + | B.pack [0x2B, 0x81, 0x04, 0x00, 0x22] == oidbs = + Right $ NISTP384 -- ECCT.getCurveByName ECCT.SEC_p384r1 + | B.pack [0x2B, 0x81, 0x04, 0x00, 0x23] == oidbs = + Right $ NISTP521 -- ECCT.getCurveByName ECCT.SEC_p521r1 + | B.pack + [0x2B, 0x06, 0x01, 0x04, 0x01, 0x97, 0x55, 0x01, 0x05, 0x01] + == oidbs = + Right Curve25519 + | B.pack [0x2B, 0x65, 0x6F] == oidbs = + Right Curve448 + | otherwise = + Left $ concat ["unknown curve (...", show (B.unpack oidbs), ")"] curveToCurveoidBS :: ECCCurve -> Either String B.ByteString curveToCurveoidBS NISTP256 = - Right $ B.pack [0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07] + Right $ B.pack [0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07] curveToCurveoidBS NISTP384 = Right $ B.pack [0x2B, 0x81, 0x04, 0x00, 0x22] curveToCurveoidBS NISTP521 = Right $ B.pack [0x2B, 0x81, 0x04, 0x00, 0x23] curveToCurveoidBS Curve25519 = - Right $ B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0x97, 0x55, 0x01, 0x05, 0x01] + Right $ + B.pack + [0x2B, 0x06, 0x01, 0x04, 0x01, 0x97, 0x55, 0x01, 0x05, 0x01] curveToCurveoidBS Curve448 = Right $ B.pack [0x2B, 0x65, 0x6F] -curveToCurveoidBS _ = Left "unknown curve" point2MBS :: ECCT.PublicPoint -> Maybe B.ByteString point2MBS (ECCT.Point x y) - | B.null xb || B.null yb = Nothing - | B.length xb /= B.length yb = Nothing - | otherwise = Just (B.concat [B.singleton 0x04, xb, yb]) + | B.null xb || B.null yb = Nothing + | B.length xb /= B.length yb = Nothing + | otherwise = Just (B.concat [B.singleton 0x04, xb, yb]) where xb = i2osp x yb = i2osp y @@ -195,29 +214,37 @@ pointToBSOrError :: ECCT.PublicPoint -> B.ByteString pointToBSOrError point = - case point of - ECCT.PointO -> error "OpenPGP forbids serializing the point at infinity" - _ -> - case point2MBS point of - Just bs -> bs - Nothing -> - error - "OpenPGP EC point serialization requires equal non-empty coordinate widths" + case point of + ECCT.PointO -> error "OpenPGP forbids serializing the point at infinity" + _ -> + case point2MBS point of + Just bs -> bs + Nothing -> + error + "OpenPGP EC point serialization requires equal non-empty coordinate widths" -curveoidBSToEdSigningCurve :: B.ByteString -> Either String EdSigningCurve +curveoidBSToEdSigningCurve + :: B.ByteString -> Either String EdSigningCurve curveoidBSToEdSigningCurve oidbs - | B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] == oidbs = - Right Ed25519 - | B.pack [0x2B, 0x65, 0x71] == oidbs = - Right Ed448 - | otherwise = - Left $ - concat ["unknown Edwards signing curve (...", show (B.unpack oidbs), ")"] + | B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] + == oidbs = + Right EdSigningCurve25519 + | B.pack [0x2B, 0x65, 0x71] == oidbs = + Right EdSigningCurve448 + | otherwise = + Left $ + concat + [ "unknown Edwards signing curve (..." + , show (B.unpack oidbs) + , ")" + ] -edSigningCurveToCurveoidBS :: EdSigningCurve -> Either String B.ByteString -edSigningCurveToCurveoidBS Ed25519 = - Right $ B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] -edSigningCurveToCurveoidBS Ed448 = Right $ B.pack [0x2B, 0x65, 0x71] +edSigningCurveToCurveoidBS + :: EdSigningCurve -> Either String B.ByteString +edSigningCurveToCurveoidBS EdSigningCurve25519 = + Right $ + B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] +edSigningCurveToCurveoidBS EdSigningCurve448 = Right $ B.pack [0x2B, 0x65, 0x71] curve2Curve :: ECCCurve -> ECCT.Curve curve2Curve NISTP256 = ECCT.getCurveByName ECCT.SEC_p256r1 @@ -226,6 +253,6 @@ curveFromCurve :: ECCT.Curve -> ECCCurve curveFromCurve c - | c == ECCT.getCurveByName ECCT.SEC_p256r1 = NISTP256 - | c == ECCT.getCurveByName ECCT.SEC_p384r1 = NISTP384 - | c == ECCT.getCurveByName ECCT.SEC_p521r1 = NISTP521 + | c == ECCT.getCurveByName ECCT.SEC_p256r1 = NISTP256 + | c == ECCT.getCurveByName ECCT.SEC_p384r1 = NISTP384 + | c == ECCT.getCurveByName ECCT.SEC_p521r1 = NISTP521 diff --git a/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs b/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs --- a/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs +++ b/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs @@ -2,70 +2,84 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - {-# LANGUAGE OverloadedStrings #-} module Codec.Encryption.OpenPGP.Internal.CryptoECDH - ( normalizeMontgomeryPublic - , buildECDHKDFParam - , deriveECDHKek - ) where + ( normalizeMontgomeryPublic + , buildECDHKDFParam + , deriveECDHKek + ) where -import Codec.Encryption.OpenPGP.BlockCipher (keySize, renderCipherError) -import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) -import Codec.Encryption.OpenPGP.Internal (curveFromCurve, curveToCurveoidBS, leftPadTo) -import Codec.Encryption.OpenPGP.Policy (ecdhKdfHashDigest) -import Codec.Encryption.OpenPGP.Types import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import Data.Bifunctor (first) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -normalizeMontgomeryPublic :: - Int - -> String - -> B.ByteString - -> Either String B.ByteString +import Codec.Encryption.OpenPGP.BlockCipher + ( keySize + , renderCipherError + ) +import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) +import Codec.Encryption.OpenPGP.Internal + ( curveFromCurve + , curveToCurveoidBS + , leftPadTo + ) +import Codec.Encryption.OpenPGP.Policy (ecdhKdfHashDigest) +import Codec.Encryption.OpenPGP.Types + +normalizeMontgomeryPublic + :: Int + -> String + -> B.ByteString + -> Either String B.ByteString normalizeMontgomeryPublic targetLen label bs - | B.length bs == targetLen = Right bs - | B.length bs < targetLen = Right (leftPadTo targetLen bs) - | B.length bs == targetLen + 1 && B.head bs == 0x40 = Right (B.tail bs) - | otherwise = Left (label ++ show (B.length bs)) + | B.length bs == targetLen = Right bs + | B.length bs < targetLen = Right (leftPadTo targetLen bs) + | B.length bs == targetLen + 1 && B.head bs == 0x40 = + Right (B.tail bs) + | otherwise = Left (label ++ show (B.length bs)) -buildECDHKDFParam :: - SomePKPayload - -> PubKeyAlgorithm - -> PKey - -> HashAlgorithm - -> SymmetricAlgorithm - -> Either String B.ByteString +buildECDHKDFParam + :: SomePKPayload + -> PubKeyAlgorithm + -> PKey + -> HashAlgorithm + -> SymmetricAlgorithm + -> Either String B.ByteString buildECDHKDFParam recipientPKP pka recipientECDHPub kdfHA kdfSA = - (<> - B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA] <> - "Anonymous Sender " <> - BL.toStrict (unFingerprint (fingerprint recipientPKP))) <$> - encodedCurveOid + ( <> + B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA] + <> "Anonymous Sender " + <> BL.toStrict (unFingerprint (fingerprint recipientPKP)) + ) + <$> encodedCurveOid where - encodedCurveOid = ((\oid -> B.singleton (fromIntegral (B.length oid)) <> oid) <$>) curveOid + encodedCurveOid = + ((\oid -> B.singleton (fromIntegral (B.length oid)) <> oid) <$>) + curveOid curveOid = - case recipientECDHPub of - ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> - curveToCurveoidBS (curveFromCurve curve) - EdDSAPubKey Ed25519 _ -> - curveToCurveoidBS Curve25519 - EdDSAPubKey Ed448 _ -> - curveToCurveoidBS Curve448 - _ -> Left "ECDH KDF param requires ECDH recipient key" + case recipientECDHPub of + ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> + curveToCurveoidBS (curveFromCurve curve) + EdDSAPubKey EdSigningCurve25519 _ -> + curveToCurveoidBS Curve25519 + EdDSAPubKey EdSigningCurve448 _ -> + curveToCurveoidBS Curve448 + _ -> Left "ECDH KDF param requires ECDH recipient key" -deriveECDHKek :: - HashAlgorithm - -> SymmetricAlgorithm - -> B.ByteString - -> B.ByteString - -> Either String B.ByteString +deriveECDHKek + :: HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> Either String B.ByteString deriveECDHKek kdfHA kdfSA sharedSecret kdfParam = do - digest <- ecdhKdfHashDigest kdfHA (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) - kekLen <- first renderCipherError (keySize kdfSA) - if B.length digest < kekLen - then Left "ECDH KDF digest is shorter than required KEK length" - else Right (B.take kekLen digest) + digest <- + ecdhKdfHashDigest + kdfHA + (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) + kekLen <- first renderCipherError (keySize kdfSA) + if B.length digest < kekLen + then Left "ECDH KDF digest is shorter than required KEK length" + else Right (B.take kekLen digest) diff --git a/Codec/Encryption/OpenPGP/KeyInfo.hs b/Codec/Encryption/OpenPGP/KeyInfo.hs --- a/Codec/Encryption/OpenPGP/KeyInfo.hs +++ b/Codec/Encryption/OpenPGP/KeyInfo.hs @@ -4,9 +4,9 @@ -- (See the LICENSE file). module Codec.Encryption.OpenPGP.KeyInfo - ( pubkeySize - , pkalgoAbbrev - ) where + ( pubkeySize + , pkalgoAbbrev + ) where import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA @@ -21,27 +21,33 @@ pubkeySize :: PKey -> Either String Int pubkeySize (RSAPubKey (RSA_PublicKey x)) = Right (RSA.public_size x * 8) pubkeySize (DSAPubKey (DSA_PublicKey x)) = - Right (bitcount . DSA.params_p . DSA.public_params $ x) + Right (bitcount . DSA.params_p . DSA.public_params $ x) pubkeySize (ElGamalPubKey p _ _) = Right (bitcount p) pubkeySize (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) = - Right (fromIntegral (ECCT.curveSizeBits curve)) -pubkeySize (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) _ _) = - Right (fromIntegral (ECCT.curveSizeBits curve)) -pubkeySize (ECDHPubKey (EdDSAPubKey Ed25519 _) _ _) = Right 256 -pubkeySize (ECDHPubKey (EdDSAPubKey Ed448 _) _ _) = Right 448 -pubkeySize (EdDSAPubKey Ed25519 _) = Right 256 -pubkeySize (EdDSAPubKey Ed448 _) = Right 448 + Right (fromIntegral (ECCT.curveSizeBits curve)) +pubkeySize + ( ECDHPubKey + (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) + _ + _ + ) = + Right (fromIntegral (ECCT.curveSizeBits curve)) +pubkeySize (ECDHPubKey (EdDSAPubKey EdSigningCurve25519 _) _ _) = Right 256 +pubkeySize (ECDHPubKey (EdDSAPubKey EdSigningCurve448 _) _ _) = Right 448 +pubkeySize (EdDSAPubKey EdSigningCurve25519 _) = Right 256 +pubkeySize (EdDSAPubKey EdSigningCurve448 _) = Right 448 pubkeySize x = Left $ "Unable to calculate size of " ++ show x bitcount :: Integer -> Int bitcount = - (* 8) . - length . - unfoldr - (\x -> - if x == 0 - then Nothing - else Just (True, x `shiftR` 8)) + (* 8) + . length + . unfoldr + ( \x -> + if x == 0 + then Nothing + else Just (True, x `shiftR` 8) + ) pkalgoAbbrev :: PubKeyAlgorithm -> String pkalgoAbbrev RSA = "rsa" diff --git a/Codec/Encryption/OpenPGP/KeyringParser.hs b/Codec/Encryption/OpenPGP/KeyringParser.hs --- a/Codec/Encryption/OpenPGP/KeyringParser.hs +++ b/Codec/Encryption/OpenPGP/KeyringParser.hs @@ -2,169 +2,182 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} module Codec.Encryption.OpenPGP.KeyringParser - ( - -- * Parsers - parseAChunk - , parseAChunkEither - , finalizeParsing - , finalizeParsingEither - , KeyringChunkParseError(..) - , anyTK - , anyTKWithWireRep - , UidOrUat(..) - , splitUs - , publicTK - , publicTKWithWireRep - , secretTK - , secretTKWithWireRep - , brokenTK - , brokenTKWithWireRep - , pkPayload - , pkPayloadWithWireRep - , signature - , signatureWithWireRep - , signedUID - , signedUIDWithWireRep - , signedUAt - , signedUAtWithWireRep - , signedOrRevokedPubSubkey - , signedOrRevokedPubSubkeyWithWireRep - , brokenPubSubkey - , brokenPubSubkeyWithWireRep - , rawOrSignedOrRevokedSecSubkey - , rawOrSignedOrRevokedSecSubkeyWithWireRep - , brokenSecSubkey - , brokenSecSubkeyWithWireRep - , skPayload - , skPayloadWithWireRep - , broken - , brokenWithWireRep - -- * Utilities - , parseUnknownTKs - , parseTKsEither - , parseTKs - , parsePublicTKs - , parseSecretTKs - , parseTKsWithWireRep - ) where + ( -- * Parsers + parseAChunk + , parseAChunkEither + , finalizeParsing + , finalizeParsingEither + , KeyringChunkParseError (..) + , anyTK + , anyTKWithWireRep + , UidOrUat (..) + , splitUs + , publicTK + , publicTKWithWireRep + , secretTK + , secretTKWithWireRep + , brokenTK + , brokenTKWithWireRep + , pkPayload + , pkPayloadWithWireRep + , signature + , signatureWithWireRep + , signedUID + , signedUIDWithWireRep + , signedUAt + , signedUAtWithWireRep + , signedOrRevokedPubSubkey + , signedOrRevokedPubSubkeyWithWireRep + , brokenPubSubkey + , brokenPubSubkeyWithWireRep + , rawOrSignedOrRevokedSecSubkey + , rawOrSignedOrRevokedSecSubkeyWithWireRep + , brokenSecSubkey + , brokenSecSubkeyWithWireRep + , skPayload + , skPayloadWithWireRep + , broken + , brokenWithWireRep -import Control.Applicative ((<|>), many) + -- * Utilities + , parseUnknownTKs + , parseTKsEither + , parseTKs + , parsePublicTKs + , parseSecretTKs + , parseTKsWithWireRep + ) where + +import Control.Applicative (many, (<|>)) import Data.Either (rights) -import Data.List (foldl') -import Data.Maybe (catMaybes, mapMaybe) import qualified Data.List.NonEmpty as NE - +import Data.Maybe (catMaybes, mapMaybe) import Data.Text (Text) +import Text.ParserCombinators.Incremental.LeftBiasedLocal + ( Parser + , concatMany + , failure + , feed + , feedEof + , inspect + , satisfy + ) import Codec.Encryption.OpenPGP.Ontology (isTrustPkt) import Codec.Encryption.OpenPGP.Policy - ( isAllowedPrimaryKeySigType - , isAllowedSubkeySigType - , isAllowedUIDSigType - ) + ( isAllowedPrimaryKeySigType + , isAllowedSubkeySigType + , isAllowedUIDSigType + ) import Codec.Encryption.OpenPGP.SignatureQualities (sigType) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () -import Text.ParserCombinators.Incremental.LeftBiasedLocal - ( Parser - , concatMany - , failure - , feed - , feedEof - , inspect - , satisfy - ) data KeyringChunkParseError - = ChunkFailureBeforeInput String - | ChunkUnexpectedFinalizationFailure - | ChunkParserFailure String - deriving (Eq, Show) + = ChunkFailureBeforeInput String + | ChunkUnexpectedFinalizationFailure + | ChunkParserFailure String + deriving (Eq, Show) renderChunkParseError :: KeyringChunkParseError -> String renderChunkParseError (ChunkFailureBeforeInput msg) = msg renderChunkParseError ChunkUnexpectedFinalizationFailure = - "Unexpected finalization failure" + "Unexpected finalization failure" renderChunkParseError (ChunkParserFailure msg) = msg -collapseCompleted :: - Monoid s - => [(r, s)] - -> ([r], s) +collapseCompleted + :: Monoid s + => [(r, s)] + -> ([r], s) collapseCompleted rs = - let (resultsRev, remainder) = - foldl' - (\(accResults, accRemainder) (result, rest) -> - (result : accResults, accRemainder <> rest)) - ([], mempty) - rs - in (reverse resultsRev, remainder) + let (resultsRev, remainder) = + foldl' + ( \(accResults, accRemainder) (result, rest) -> + (result : accResults, accRemainder <> rest) + ) + ([], mempty) + rs + in (reverse resultsRev, remainder) -parseAChunk :: - (Monoid s, Show s) - => Parser s r - -> s - -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) - -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) +parseAChunk + :: (Monoid s, Show s) + => Parser s r + -> s + -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) + -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) parseAChunk op a st = - either (error . renderChunkParseError) id (parseAChunkEither op a st) + either + (error . renderChunkParseError) + id + (parseAChunkEither op a st) -parseAChunkEither :: - (Monoid s, Show s) - => Parser s r - -> s - -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) - -> Either - KeyringChunkParseError - (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) +parseAChunkEither + :: (Monoid s, Show s) + => Parser s r + -> s + -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) + -> Either + KeyringChunkParseError + (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) parseAChunkEither _ a ([], Nothing) = - Left (ChunkFailureBeforeInput ("Failure before " ++ show a)) + Left (ChunkFailureBeforeInput ("Failure before " ++ show a)) parseAChunkEither op a (cr, Nothing) = - let (completed, remainder) = collapseCompleted cr - in - (\x -> (x, completed)) <$> - either (Left . ChunkParserFailure) Right (inspect (feed (remainder <> a) op)) + let (completed, remainder) = collapseCompleted cr + in (\x -> (x, completed)) + <$> either + (Left . ChunkParserFailure) + Right + (inspect (feed (remainder <> a) op)) parseAChunkEither _ a (_, Just (_, p)) = - (\x -> (x, [])) <$> either (Left . ChunkParserFailure) Right (inspect (feed a p)) + (\x -> (x, [])) + <$> either (Left . ChunkParserFailure) Right (inspect (feed a p)) -finalizeParsing :: - Monoid s - => ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) - -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) +finalizeParsing + :: Monoid s + => ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) + -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) finalizeParsing st = - either (error . renderChunkParseError) id (finalizeParsingEither st) + either + (error . renderChunkParseError) + id + (finalizeParsingEither st) -finalizeParsingEither :: - Monoid s - => ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) - -> Either - KeyringChunkParseError - (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) +finalizeParsingEither + :: Monoid s + => ([(r, s)], Maybe (Maybe (r -> r), Parser s r)) + -> Either + KeyringChunkParseError + (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r]) finalizeParsingEither ([], Nothing) = Left ChunkUnexpectedFinalizationFailure finalizeParsingEither (cr, Nothing) = - let (completed, _) = collapseCompleted cr - in Right (([], Nothing), completed) + let (completed, _) = collapseCompleted cr + in Right (([], Nothing), completed) finalizeParsingEither (_, Just (_, p)) = - either (Left . ChunkParserFailure) finalizeParsingEither (inspect (feedEof p)) + either + (Left . ChunkParserFailure) + finalizeParsingEither + (inspect (feedEof p)) anyTK :: Bool -> Parser [Pkt] (Maybe TKUnknown) anyTK True = publicTK True <|> secretTK True -anyTK False = publicTK False <|> secretTK False <|> brokenTK 6 <|> brokenTK 5 +anyTK False = + publicTK False <|> secretTK False <|> brokenTK 6 <|> brokenTK 5 data UidOrUat - = I Text - | A [UserAttrSubPacket] - deriving (Show) + = I Text + | A [UserAttrSubPacket] + deriving (Show) -splitUs :: - [(UidOrUat, [SignaturePayload])] - -> ([(Text, [SignaturePayload])], [([UserAttrSubPacket], [SignaturePayload])]) +splitUs + :: [(UidOrUat, [SignaturePayload])] + -> ( [(Text, [SignaturePayload])] + , [([UserAttrSubPacket], [SignaturePayload])] + ) splitUs us = (is, as) where is = map unI (filter isI us) @@ -180,85 +193,99 @@ publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TKUnknown) publicTK intolerant = do - pkp <- pkPayload - pkpsigs <- - concatMany - (signatureWithPredicate intolerant isAllowedPrimaryKeySigType) - (uids, uats) <- - fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) - subs <- concatMany (pubsub intolerant) - return $ Just (TKUnknown pkp pkpsigs uids uats subs) + pkp <- pkPayload + pkpsigs <- + concatMany + (signatureWithPredicate intolerant isAllowedPrimaryKeySigType) + (uids, uats) <- + fmap + splitUs + (many (signedUID intolerant <|> signedUAt intolerant)) + subs <- concatMany (pubsub intolerant) + return $ Just (TKUnknown pkp pkpsigs uids uats subs) where pubsub True = signedOrRevokedPubSubkey True pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey - secretTK intolerant = do - skp <- skPayload - skpsigs <- - concatMany - (signatureWithPredicate intolerant isAllowedPrimaryKeySigType) - (uids, uats) <- - fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) - subs <- concatMany (secsub intolerant) - return $ Just (TKUnknown skp skpsigs uids uats subs) + skp <- skPayload + skpsigs <- + concatMany + (signatureWithPredicate intolerant isAllowedPrimaryKeySigType) + (uids, uats) <- + fmap + splitUs + (many (signedUID intolerant <|> signedUAt intolerant)) + subs <- concatMany (secsub intolerant) + return $ Just (TKUnknown skp skpsigs uids uats subs) where secsub True = rawOrSignedOrRevokedSecSubkey True secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey brokenTK :: Int -> Parser [Pkt] (Maybe TKUnknown) brokenTK 6 = do - _ <- broken 6 - _ <- many (signature False [KeyRevocationSig, SignatureDirectlyOnAKey]) - _ <- many (signedUID False <|> signedUAt False) - _ <- concatMany (signedOrRevokedPubSubkey False <|> brokenPubSubkey) - return Nothing + _ <- broken 6 + _ <- + many + (signature False [KeyRevocationSig, SignatureDirectlyOnAKey]) + _ <- many (signedUID False <|> signedUAt False) + _ <- + concatMany (signedOrRevokedPubSubkey False <|> brokenPubSubkey) + return Nothing brokenTK 5 = do - _ <- broken 5 - _ <- many (signature False [KeyRevocationSig, SignatureDirectlyOnAKey]) - _ <- many (signedUID False <|> signedUAt False) - _ <- concatMany (rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey) - return Nothing + _ <- broken 5 + _ <- + many + (signature False [KeyRevocationSig, SignatureDirectlyOnAKey]) + _ <- many (signedUID False <|> signedUAt False) + _ <- + concatMany + (rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey) + return Nothing brokenTK _ = fail "Unexpected broken packet type" pkPayload :: Parser [Pkt] (SomePKPayload, Maybe SKAddendum) pkPayload = do - pkpkts <- satisfy isPKP - case pkpkts of - [pkt] -> - case pktToPublicKeyPkt pkt of - Just keyPkt | keyPktRole keyPkt == KeyPktPrimary -> - return (keyPktTKKey keyPkt) + pkpkts <- satisfy isPKP + case pkpkts of + [pkt] -> + case pktToPublicKeyPkt pkt of + Just keyPkt + | keyPktRole keyPkt == KeyPktPrimary -> + return (keyPktTKKey keyPkt) + _ -> failure _ -> failure - _ -> failure where isPKP [pkt] = - case pktToPublicKeyPkt pkt of - Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary - Nothing -> False + case pktToPublicKeyPkt pkt of + Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary + Nothing -> False isPKP _ = False signature :: Bool -> [SigType] -> Parser [Pkt] [SignaturePayload] signature intolerant rts = signatureWithPredicate intolerant (\st -> st `elem` rts) --- | RFC9580-aware signature parser that validates context using a predicate --- The predicate operates on SigType to determine if the signature is allowed --- in this context (e.g., isAllowedPrimaryKeySigType for primary keys). -signatureWithPredicate :: Bool -> (SigType -> Bool) -> Parser [Pkt] [SignaturePayload] +{- | RFC9580-aware signature parser that validates context using a predicate +The predicate operates on SigType to determine if the signature is allowed +in this context (e.g., isAllowedPrimaryKeySigType for primary keys). +-} +signatureWithPredicate + :: Bool -> (SigType -> Bool) -> Parser [Pkt] [SignaturePayload] signatureWithPredicate intolerant predicate = - if intolerant - then signature' - else signature' <|> brokensig' + if intolerant + then signature' + else signature' <|> brokensig' where signature' = do - spks <- satisfy (isSP intolerant) - case spks of - [SignaturePkt sp] -> - return $! - (if intolerant - then id - else filter isSP') - [sp] - _ -> failure + spks <- satisfy (isSP intolerant) + case spks of + [SignaturePkt sp] -> + return $! + ( if intolerant + then id + else filter isSP' + ) + [sp] + _ -> failure brokensig' = const [] <$> broken 2 isSP True [SignaturePkt sp] = isSP' sp isSP False [SignaturePkt _] = True @@ -267,102 +294,106 @@ signedUID :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload]) signedUID intolerant = do - upkts <- satisfy isUID - case upkts of - [UserIdPkt u] -> do - sigs <- - concatMany - (signatureWithPredicate intolerant isAllowedUIDSigType) - return (I u, sigs) - _ -> failure + upkts <- satisfy isUID + case upkts of + [UserIdPkt u] -> do + sigs <- + concatMany + (signatureWithPredicate intolerant isAllowedUIDSigType) + return (I u, sigs) + _ -> failure where isUID [UserIdPkt _] = True isUID _ = False signedUAt :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload]) signedUAt intolerant = do - uapkts <- satisfy isUAt - case uapkts of - [UserAttributePkt us] -> do - sigs <- - concatMany - (signatureWithPredicate intolerant isAllowedUIDSigType) - return (A us, sigs) - _ -> failure + uapkts <- satisfy isUAt + case uapkts of + [UserAttributePkt us] -> do + sigs <- + concatMany + (signatureWithPredicate intolerant isAllowedUIDSigType) + return (A us, sigs) + _ -> failure where isUAt [UserAttributePkt _] = True isUAt _ = False -signedOrRevokedPubSubkey :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])] +signedOrRevokedPubSubkey + :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])] signedOrRevokedPubSubkey intolerant = do - pskpkts <- satisfy isPSKP - case pskpkts of - [p] -> do - sigs <- - concatMany - (signatureWithPredicate intolerant isAllowedSubkeySigType) - return [(p, sigs)] - _ -> failure + pskpkts <- satisfy isPSKP + case pskpkts of + [p] -> do + sigs <- + concatMany + (signatureWithPredicate intolerant isAllowedSubkeySigType) + return [(p, sigs)] + _ -> failure where isPSKP [pkt] = - case pktToPublicKeyPkt pkt of - Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey - Nothing -> False + case pktToPublicKeyPkt pkt of + Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey + Nothing -> False isPSKP _ = False brokenPubSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])] brokenPubSubkey = do - _ <- broken 14 - _ <- concatMany (signatureWithPredicate False isAllowedSubkeySigType) - return [] + _ <- broken 14 + _ <- + concatMany (signatureWithPredicate False isAllowedSubkeySigType) + return [] -rawOrSignedOrRevokedSecSubkey :: - Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])] +rawOrSignedOrRevokedSecSubkey + :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])] rawOrSignedOrRevokedSecSubkey intolerant = do - sskpkts <- satisfy isSSKP - case sskpkts of - [p] -> do - sigs <- - concatMany - (signatureWithPredicate intolerant isAllowedSubkeySigType) - return [(p, sigs)] - _ -> failure + sskpkts <- satisfy isSSKP + case sskpkts of + [p] -> do + sigs <- + concatMany + (signatureWithPredicate intolerant isAllowedSubkeySigType) + return [(p, sigs)] + _ -> failure where isSSKP [pkt] = - case pktToSecretKeyPkt pkt of - Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey - Nothing -> False + case pktToSecretKeyPkt pkt of + Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey + Nothing -> False isSSKP _ = False brokenSecSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])] brokenSecSubkey = do - _ <- broken 7 - _ <- concatMany (signatureWithPredicate False isAllowedSubkeySigType) - return [] + _ <- broken 7 + _ <- + concatMany (signatureWithPredicate False isAllowedSubkeySigType) + return [] skPayload :: Parser [Pkt] (SomePKPayload, Maybe SKAddendum) skPayload = do - spkts <- satisfy isSKP - case spkts of - [pkt] -> - case pktToSecretKeyPkt pkt of - Just keyPkt | keyPktRole keyPkt == KeyPktPrimary -> - return (keyPktTKKey keyPkt) + spkts <- satisfy isSKP + case spkts of + [pkt] -> + case pktToSecretKeyPkt pkt of + Just keyPkt + | keyPktRole keyPkt == KeyPktPrimary -> + return (keyPktTKKey keyPkt) + _ -> failure _ -> failure - _ -> failure where isSKP [pkt] = - case pktToSecretKeyPkt pkt of - Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary - Nothing -> False + case pktToSecretKeyPkt pkt of + Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary + Nothing -> False isSKP _ = False broken :: Int -> Parser [Pkt] Pkt broken t = do - bpkts <- satisfy isBroken - case bpkts of - [bp] -> return bp - _ -> failure + bpkts <- satisfy isBroken + case bpkts of + [bp] -> return bp + _ -> failure where isBroken [BrokenPacketPkt _ a _] = t == fromIntegral a isBroken _ = False @@ -370,309 +401,370 @@ -- | parse TKs from packets parseUnknownTKs :: Bool -> [Pkt] -> [TKUnknown] parseUnknownTKs intolerant ps = - catMaybes $ - runIncrementalParser - (anyTK intolerant) - (map (: []) (filter notTrustPacket ps)) + catMaybes $ + runIncrementalParser + (anyTK intolerant) + (map (: []) (filter notTrustPacket ps)) where notTrustPacket = not . isTrustPkt -parseTKsEither :: Bool -> [Pkt] -> [Either TKConversionError SomeTK] +parseTKsEither + :: Bool -> [Pkt] -> [Either TKConversionError SomeTK] parseTKsEither intolerant = - map fromUnknownToTKEither . parseUnknownTKs intolerant + map fromUnknownToTKEither . parseUnknownTKs intolerant parseTKs :: Bool -> [Pkt] -> [SomeTK] parseTKs intolerant packets = rights (parseTKsEither intolerant packets) parsePublicTKs :: Bool -> [Pkt] -> [TK 'PublicTK] parsePublicTKs intolerant packets = - mapMaybe someTKToPublicTK (parseTKs intolerant packets) + mapMaybe someTKToPublicTK (parseTKs intolerant packets) parseSecretTKs :: Bool -> [Pkt] -> [TK 'SecretTK] parseSecretTKs intolerant packets = - mapMaybe someTKToSecretTK (parseTKs intolerant packets) + mapMaybe someTKToSecretTK (parseTKs intolerant packets) -anyTKWithWireRep :: Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep) +anyTKWithWireRep + :: Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep) anyTKWithWireRep True = publicTKWithWireRep True <|> secretTKWithWireRep True anyTKWithWireRep False = - publicTKWithWireRep False <|> secretTKWithWireRep False <|> - brokenTKWithWireRep 6 <|> brokenTKWithWireRep 5 + publicTKWithWireRep False + <|> secretTKWithWireRep False + <|> brokenTKWithWireRep 6 + <|> brokenTKWithWireRep 5 -publicTKWithWireRep, secretTKWithWireRep :: - Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep) +publicTKWithWireRep + , secretTKWithWireRep + :: Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep) publicTKWithWireRep intolerant = do - (pkp, pkps) <- pkPayloadWithWireRep - (pkpsigs, pkpsigrefs) <- - concatMany - (signatureWithWireRepPredicate intolerant isAllowedPrimaryKeySigType) - uidResults <- many (signedUIDWithWireRep intolerant <|> signedUAtWithWireRep intolerant) - subResults <- concatMany (pubsub intolerant) - let semanticUs = fmap fst uidResults - (uids, uats) = splitUs semanticUs - uidrefs = concatMap snd uidResults - subs = fmap fst subResults - subrefs = concatMap snd subResults - tk = TKUnknown pkp pkpsigs uids uats subs - refs = pkps ++ pkpsigrefs ++ uidrefs ++ subrefs - return $ Just (mkTKWithWireRep tk refs) + (pkp, pkps) <- pkPayloadWithWireRep + (pkpsigs, pkpsigrefs) <- + concatMany + ( signatureWithWireRepPredicate + intolerant + isAllowedPrimaryKeySigType + ) + uidResults <- + many + ( signedUIDWithWireRep intolerant + <|> signedUAtWithWireRep intolerant + ) + subResults <- concatMany (pubsub intolerant) + let semanticUs = fmap fst uidResults + (uids, uats) = splitUs semanticUs + uidrefs = concatMap snd uidResults + subs = fmap fst subResults + subrefs = concatMap snd subResults + tk = TKUnknown pkp pkpsigs uids uats subs + refs = pkps ++ pkpsigrefs ++ uidrefs ++ subrefs + return $ Just (mkTKWithWireRep tk refs) where pubsub True = signedOrRevokedPubSubkeyWithWireRep True pubsub False = - signedOrRevokedPubSubkeyWithWireRep False <|> brokenPubSubkeyWithWireRep - + signedOrRevokedPubSubkeyWithWireRep False + <|> brokenPubSubkeyWithWireRep secretTKWithWireRep intolerant = do - (skp, skps) <- skPayloadWithWireRep - (skpsigs, skpsigrefs) <- - concatMany - (signatureWithWireRepPredicate intolerant isAllowedPrimaryKeySigType) - uidResults <- many (signedUIDWithWireRep intolerant <|> signedUAtWithWireRep intolerant) - subResults <- concatMany (secsub intolerant) - let semanticUs = fmap fst uidResults - (uids, uats) = splitUs semanticUs - uidrefs = concatMap snd uidResults - subs = fmap fst subResults - subrefs = concatMap snd subResults - tk = TKUnknown skp skpsigs uids uats subs - refs = skps ++ skpsigrefs ++ uidrefs ++ subrefs - return $ Just (mkTKWithWireRep tk refs) + (skp, skps) <- skPayloadWithWireRep + (skpsigs, skpsigrefs) <- + concatMany + ( signatureWithWireRepPredicate + intolerant + isAllowedPrimaryKeySigType + ) + uidResults <- + many + ( signedUIDWithWireRep intolerant + <|> signedUAtWithWireRep intolerant + ) + subResults <- concatMany (secsub intolerant) + let semanticUs = fmap fst uidResults + (uids, uats) = splitUs semanticUs + uidrefs = concatMap snd uidResults + subs = fmap fst subResults + subrefs = concatMap snd subResults + tk = TKUnknown skp skpsigs uids uats subs + refs = skps ++ skpsigrefs ++ uidrefs ++ subrefs + return $ Just (mkTKWithWireRep tk refs) where secsub True = rawOrSignedOrRevokedSecSubkeyWithWireRep True secsub False = - rawOrSignedOrRevokedSecSubkeyWithWireRep False <|> brokenSecSubkeyWithWireRep + rawOrSignedOrRevokedSecSubkeyWithWireRep False + <|> brokenSecSubkeyWithWireRep -brokenTKWithWireRep :: Int -> Parser [PktWithWireRep] (Maybe TKWithWireRep) +brokenTKWithWireRep + :: Int -> Parser [PktWithWireRep] (Maybe TKWithWireRep) brokenTKWithWireRep 6 = do - _ <- brokenWithWireRep 6 - _ <- many (signatureWithWireRepPredicate False isAllowedPrimaryKeySigType) - _ <- many (signedUIDWithWireRep False <|> signedUAtWithWireRep False) - _ <- - concatMany - (signedOrRevokedPubSubkeyWithWireRep False <|> brokenPubSubkeyWithWireRep) - return Nothing + _ <- brokenWithWireRep 6 + _ <- + many + (signatureWithWireRepPredicate False isAllowedPrimaryKeySigType) + _ <- + many (signedUIDWithWireRep False <|> signedUAtWithWireRep False) + _ <- + concatMany + ( signedOrRevokedPubSubkeyWithWireRep False + <|> brokenPubSubkeyWithWireRep + ) + return Nothing brokenTKWithWireRep 5 = do - _ <- brokenWithWireRep 5 - _ <- many (signatureWithWireRepPredicate False isAllowedPrimaryKeySigType) - _ <- many (signedUIDWithWireRep False <|> signedUAtWithWireRep False) - _ <- - concatMany - (rawOrSignedOrRevokedSecSubkeyWithWireRep False <|> brokenSecSubkeyWithWireRep) - return Nothing + _ <- brokenWithWireRep 5 + _ <- + many + (signatureWithWireRepPredicate False isAllowedPrimaryKeySigType) + _ <- + many (signedUIDWithWireRep False <|> signedUAtWithWireRep False) + _ <- + concatMany + ( rawOrSignedOrRevokedSecSubkeyWithWireRep False + <|> brokenSecSubkeyWithWireRep + ) + return Nothing brokenTKWithWireRep _ = fail "Unexpected broken packet type" -pkPayloadWithWireRep :: - Parser [PktWithWireRep] ((SomePKPayload, Maybe SKAddendum), [PktWithWireRep]) +pkPayloadWithWireRep + :: Parser + [PktWithWireRep] + ((SomePKPayload, Maybe SKAddendum), [PktWithWireRep]) pkPayloadWithWireRep = do - pkpkts <- satisfy isPKPWS - case pkpkts of - [pktWithSource] -> - case pktToPublicKeyPkt (_pktValue pktWithSource) of - Just keyPkt | keyPktRole keyPkt == KeyPktPrimary -> - return (keyPktTKKey keyPkt, [pktWithSource]) + pkpkts <- satisfy isPKPWS + case pkpkts of + [pktWithSource] -> + case pktToPublicKeyPkt (_pktValue pktWithSource) of + Just keyPkt + | keyPktRole keyPkt == KeyPktPrimary -> + return (keyPktTKKey keyPkt, [pktWithSource]) + _ -> failure _ -> failure - _ -> failure where isPKPWS [pktWithSource] = - case pktToPublicKeyPkt (_pktValue pktWithSource) of - Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary - _ -> False + case pktToPublicKeyPkt (_pktValue pktWithSource) of + Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary + _ -> False isPKPWS _ = False -signatureWithWireRep :: - Bool - -> [SigType] - -> Parser [PktWithWireRep] ([SignaturePayload], [PktWithWireRep]) +signatureWithWireRep + :: Bool + -> [SigType] + -> Parser [PktWithWireRep] ([SignaturePayload], [PktWithWireRep]) signatureWithWireRep intolerant rts = - signatureWithWireRepPredicate intolerant (\st -> st `elem` rts) + signatureWithWireRepPredicate intolerant (\st -> st `elem` rts) -- | RFC9580-aware signature parser with wire representation support -signatureWithWireRepPredicate :: - Bool - -> (SigType -> Bool) - -> Parser [PktWithWireRep] ([SignaturePayload], [PktWithWireRep]) +signatureWithWireRepPredicate + :: Bool + -> (SigType -> Bool) + -> Parser [PktWithWireRep] ([SignaturePayload], [PktWithWireRep]) signatureWithWireRepPredicate intolerant predicate = - if intolerant - then signature' - else signature' <|> brokensig' + if intolerant + then signature' + else signature' <|> brokensig' where signature' = do - spks <- satisfy (isSPWS intolerant) - case spks of - [pktWithSource] -> - case _pktValue pktWithSource of - SignaturePkt sp -> - let sigs = - (if intolerant - then id - else filter isSP') - [sp] - in return (sigs, if null sigs then [] else [pktWithSource]) + spks <- satisfy (isSPWS intolerant) + case spks of + [pktWithSource] -> + case _pktValue pktWithSource of + SignaturePkt sp -> + let sigs = + ( if intolerant + then id + else filter isSP' + ) + [sp] + in return (sigs, if null sigs then [] else [pktWithSource]) + _ -> failure _ -> failure - _ -> failure brokensig' = const ([], []) <$> brokenWithWireRep 2 isSPWS True [pktWithSource] = - case _pktValue pktWithSource of - SignaturePkt sp -> isSP' sp - _ -> False + case _pktValue pktWithSource of + SignaturePkt sp -> isSP' sp + _ -> False isSPWS False [pktWithSource] = - case _pktValue pktWithSource of - SignaturePkt _ -> True - _ -> False + case _pktValue pktWithSource of + SignaturePkt _ -> True + _ -> False isSPWS _ _ = False isSP' sigPayload = maybe False predicate (sigType sigPayload) -signedUIDWithWireRep :: - Bool - -> Parser [PktWithWireRep] ((UidOrUat, [SignaturePayload]), [PktWithWireRep]) +signedUIDWithWireRep + :: Bool + -> Parser + [PktWithWireRep] + ((UidOrUat, [SignaturePayload]), [PktWithWireRep]) signedUIDWithWireRep intolerant = do - upkts <- satisfy isUIDWS - case upkts of - [pktWithSource] -> - case _pktValue pktWithSource of - UserIdPkt u -> do - (sigs, sigrefs) <- - concatMany - (signatureWithWireRepPredicate intolerant isAllowedUIDSigType) - return ((I u, sigs), pktWithSource : sigrefs) + upkts <- satisfy isUIDWS + case upkts of + [pktWithSource] -> + case _pktValue pktWithSource of + UserIdPkt u -> do + (sigs, sigrefs) <- + concatMany + (signatureWithWireRepPredicate intolerant isAllowedUIDSigType) + return ((I u, sigs), pktWithSource : sigrefs) + _ -> failure _ -> failure - _ -> failure where isUIDWS [pktWithSource] = - case _pktValue pktWithSource of - UserIdPkt _ -> True - _ -> False + case _pktValue pktWithSource of + UserIdPkt _ -> True + _ -> False isUIDWS _ = False -signedUAtWithWireRep :: - Bool - -> Parser [PktWithWireRep] ((UidOrUat, [SignaturePayload]), [PktWithWireRep]) +signedUAtWithWireRep + :: Bool + -> Parser + [PktWithWireRep] + ((UidOrUat, [SignaturePayload]), [PktWithWireRep]) signedUAtWithWireRep intolerant = do - uapkts <- satisfy isUAtWS - case uapkts of - [pktWithSource] -> - case _pktValue pktWithSource of - UserAttributePkt us -> do - (sigs, sigrefs) <- - concatMany - (signatureWithWireRepPredicate intolerant isAllowedUIDSigType) - return ((A us, sigs), pktWithSource : sigrefs) + uapkts <- satisfy isUAtWS + case uapkts of + [pktWithSource] -> + case _pktValue pktWithSource of + UserAttributePkt us -> do + (sigs, sigrefs) <- + concatMany + (signatureWithWireRepPredicate intolerant isAllowedUIDSigType) + return ((A us, sigs), pktWithSource : sigrefs) + _ -> failure _ -> failure - _ -> failure where isUAtWS [pktWithSource] = - case _pktValue pktWithSource of - UserAttributePkt _ -> True - _ -> False + case _pktValue pktWithSource of + UserAttributePkt _ -> True + _ -> False isUAtWS _ = False -signedOrRevokedPubSubkeyWithWireRep :: - Bool -> Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])] +signedOrRevokedPubSubkeyWithWireRep + :: Bool + -> Parser + [PktWithWireRep] + [((Pkt, [SignaturePayload]), [PktWithWireRep])] signedOrRevokedPubSubkeyWithWireRep intolerant = do - pskpkts <- satisfy isPSKPWS - case pskpkts of - [pktWithSource] -> do - (sigs, sigrefs) <- - concatMany - (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType) - return [((_pktValue pktWithSource, sigs), pktWithSource : sigrefs)] - _ -> failure + pskpkts <- satisfy isPSKPWS + case pskpkts of + [pktWithSource] -> do + (sigs, sigrefs) <- + concatMany + (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType) + return + [((_pktValue pktWithSource, sigs), pktWithSource : sigrefs)] + _ -> failure where isPSKPWS [pktWithSource] = - case pktToPublicKeyPkt (_pktValue pktWithSource) of - Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey - _ -> False + case pktToPublicKeyPkt (_pktValue pktWithSource) of + Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey + _ -> False isPSKPWS _ = False -brokenPubSubkeyWithWireRep :: - Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])] +brokenPubSubkeyWithWireRep + :: Parser + [PktWithWireRep] + [((Pkt, [SignaturePayload]), [PktWithWireRep])] brokenPubSubkeyWithWireRep = do - _ <- brokenWithWireRep 14 - _ <- concatMany (signatureWithWireRepPredicate False isAllowedSubkeySigType) - return [] + _ <- brokenWithWireRep 14 + _ <- + concatMany + (signatureWithWireRepPredicate False isAllowedSubkeySigType) + return [] -rawOrSignedOrRevokedSecSubkeyWithWireRep :: - Bool -> Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])] +rawOrSignedOrRevokedSecSubkeyWithWireRep + :: Bool + -> Parser + [PktWithWireRep] + [((Pkt, [SignaturePayload]), [PktWithWireRep])] rawOrSignedOrRevokedSecSubkeyWithWireRep intolerant = do - sskpkts <- satisfy isSSKPWS - case sskpkts of - [pktWithSource] -> do - (sigs, sigrefs) <- - concatMany - (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType) - return [((_pktValue pktWithSource, sigs), pktWithSource : sigrefs)] - _ -> failure + sskpkts <- satisfy isSSKPWS + case sskpkts of + [pktWithSource] -> do + (sigs, sigrefs) <- + concatMany + (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType) + return + [((_pktValue pktWithSource, sigs), pktWithSource : sigrefs)] + _ -> failure where isSSKPWS [pktWithSource] = - case pktToSecretKeyPkt (_pktValue pktWithSource) of - Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey - _ -> False + case pktToSecretKeyPkt (_pktValue pktWithSource) of + Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey + _ -> False isSSKPWS _ = False -brokenSecSubkeyWithWireRep :: - Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])] +brokenSecSubkeyWithWireRep + :: Parser + [PktWithWireRep] + [((Pkt, [SignaturePayload]), [PktWithWireRep])] brokenSecSubkeyWithWireRep = do - _ <- brokenWithWireRep 7 - _ <- concatMany (signatureWithWireRepPredicate False isAllowedSubkeySigType) - return [] + _ <- brokenWithWireRep 7 + _ <- + concatMany + (signatureWithWireRepPredicate False isAllowedSubkeySigType) + return [] -skPayloadWithWireRep :: - Parser [PktWithWireRep] ((SomePKPayload, Maybe SKAddendum), [PktWithWireRep]) +skPayloadWithWireRep + :: Parser + [PktWithWireRep] + ((SomePKPayload, Maybe SKAddendum), [PktWithWireRep]) skPayloadWithWireRep = do - spkts <- satisfy isSKPWS - case spkts of - [pktWithSource] -> - case pktToSecretKeyPkt (_pktValue pktWithSource) of - Just keyPkt | keyPktRole keyPkt == KeyPktPrimary -> - return (keyPktTKKey keyPkt, [pktWithSource]) + spkts <- satisfy isSKPWS + case spkts of + [pktWithSource] -> + case pktToSecretKeyPkt (_pktValue pktWithSource) of + Just keyPkt + | keyPktRole keyPkt == KeyPktPrimary -> + return (keyPktTKKey keyPkt, [pktWithSource]) + _ -> failure _ -> failure - _ -> failure where isSKPWS [pktWithSource] = - case pktToSecretKeyPkt (_pktValue pktWithSource) of - Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary - _ -> False + case pktToSecretKeyPkt (_pktValue pktWithSource) of + Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary + _ -> False isSKPWS _ = False -brokenWithWireRep :: Int -> Parser [PktWithWireRep] PktWithWireRep +brokenWithWireRep + :: Int -> Parser [PktWithWireRep] PktWithWireRep brokenWithWireRep t = do - bpkts <- satisfy isBrokenWS - case bpkts of - [bp] -> return bp - _ -> failure + bpkts <- satisfy isBrokenWS + case bpkts of + [bp] -> return bp + _ -> failure where isBrokenWS [pktWithSource] = - case _pktValue pktWithSource of - BrokenPacketPkt _ a _ -> t == fromIntegral a - _ -> False + case _pktValue pktWithSource of + BrokenPacketPkt _ a _ -> t == fromIntegral a + _ -> False isBrokenWS _ = False -parseTKsWithWireRep :: Bool -> [PktWithWireRep] -> [TKWithWireRep] +parseTKsWithWireRep + :: Bool -> [PktWithWireRep] -> [TKWithWireRep] parseTKsWithWireRep intolerant ps = - catMaybes $ - runIncrementalParser - (anyTKWithWireRep intolerant) - (map (: []) (filter notTrustPacketWithWireRep ps)) + catMaybes $ + runIncrementalParser + (anyTKWithWireRep intolerant) + (map (: []) (filter notTrustPacketWithWireRep ps)) where notTrustPacketWithWireRep = not . isTrustPkt . _pktValue -runIncrementalParser :: - (Monoid s, Show s) - => Parser s r - -> [s] - -> [r] +runIncrementalParser + :: (Monoid s, Show s) + => Parser s r + -> [s] + -> [r] runIncrementalParser parser chunks = go ([], Just (Nothing, parser)) chunks where go st [] = snd (finalizeParsing st) - go st (chunk:rest) = - let (st', out) = parseAChunk parser chunk st - in out <> go st' rest + go st (chunk : rest) = + let (st', out) = parseAChunk parser chunk st + in out <> go st' rest mkTKWithWireRep :: TKUnknown -> [PktWithWireRep] -> TKWithWireRep mkTKWithWireRep tk refs = - case refs of - [] -> error "mkTKWithWireRep requires at least one packet reference" - (pktWithSource:_) -> - TKWithWireRep - (NE.singleton (wireRepOfPkt pktWithSource)) - (spanByteRanges (map _pktRange refs)) - refs - tk + case refs of + [] -> + error "mkTKWithWireRep requires at least one packet reference" + (pktWithSource : _) -> + TKWithWireRep + (NE.singleton (wireRepOfPkt pktWithSource)) + (spanByteRanges (map _pktRange refs)) + refs + tk diff --git a/Codec/Encryption/OpenPGP/Message.hs b/Codec/Encryption/OpenPGP/Message.hs --- a/Codec/Encryption/OpenPGP/Message.hs +++ b/Codec/Encryption/OpenPGP/Message.hs @@ -2,896 +2,1082 @@ -- 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) +{-# 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 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 Crypto.Random.Types (MonadRandom, getRandomBytes) +import Data.Bifunctor (first) +import Data.Binary (put) +import Data.Binary.Put (runPut) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Kind (Type) +import Data.Word (Word8) + +import Codec.Encryption.OpenPGP.BlockCipher + ( CipherError + , keySize + , renderCipherError + , 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.CryptoSEIPDv2 + ( decryptSKESK6SessionKey + , deriveSKESK6KEK + ) +import Codec.Encryption.OpenPGP.Internal.HOBlockCipher + ( HOBlockCipher (..) + ) +import Codec.Encryption.OpenPGP.Policy + ( HashAlgorithmW (..) + , OpenPGPPolicy + , OpenPGPRFCW (..) + , defaultPolicy + , deprecatedHashAlgorithms + , messageDefaultAEADAlgorithm + , messageDefaultChunkSize + , messageSEIPDv2SaltOctets + , policyGenerationDeprecations + , policyMessageEncryption + , supportsSEIPDv2Symmetric + ) +import Codec.Encryption.OpenPGP.S2K + ( S2KError (..) + , renderS2KError + , skesk2SessionKey + , string2Key + ) +import Codec.Encryption.OpenPGP.Serialize (parsePkts) +import Codec.Encryption.OpenPGP.Signatures + ( SignError (..) + , VerificationError + , signDataWithEd25519Builder + , signDataWithEd25519V6Builder + , signDataWithEd448Builder + , signDataWithEd448V6Builder + , signDataWithRSABuilder + , signDataWithRSAV6Builder + ) +import Codec.Encryption.OpenPGP.Subpackets + ( addHashedSubs + , addUnhashedSubs + , listToHashedSubs + , listToUnhashedSubs + , sigBuilderInitTyped + , sigBuilderInitV6Typed + ) +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 + +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 diff --git a/Codec/Encryption/OpenPGP/Policy.hs b/Codec/Encryption/OpenPGP/Policy.hs --- a/Codec/Encryption/OpenPGP/Policy.hs +++ b/Codec/Encryption/OpenPGP/Policy.hs @@ -2,7 +2,6 @@ -- Copyright © 2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} @@ -10,74 +9,87 @@ {-# LANGUAGE TypeFamilies #-} module Codec.Encryption.OpenPGP.Policy - ( OpenPGPRFC(..) - , OpenPGPRFCW(..) - , SomeOpenPGPRFCW(..) - , promoteOpenPGPRFC - , demoteOpenPGPRFCW - , HashAlgorithmW(..) - , SomeHashAlgorithmW(..) - , promoteHashAlgorithm - , demoteHashAlgorithmW - , HashAlgoStatus(..) - , HashAlgoStatusFor - , HashAlgoAllowedFor - , HashAlgoVerifiableFor - , PKESKVersionPolicy(..) - , MessageEncryptionPolicy(..) - , SecretKeyProtectionPolicy(..) - , GenerationDeprecationPolicy(..) - , VerificationDefaults(..) - , DecryptPolicy(..) - , OpenPGPPolicy(..) - , policyForRFC - , defaultPolicy - , defaultPKESKVersionPolicy - , defaultVerificationDefaults - , defaultDecryptPolicy - , lenientDecryptPolicy - , supportsSEIPDv2Symmetric - , secretKeyProtectionPolicyForKeyVersion - , signatureV6SaltSizeForHashAlgorithm - , ecdhKdfHashDigest - , validateTable30PolicyForRecipient - , legacySecretKeyProtectionErrorMessage - -- * Signature context validation (RFC9580/RFC4880) - , isAllowedPrimaryKeySig - , isAllowedSubkeySig - , isAllowedUIDSig - -- * Signature type validation helpers (for parser use) - , isAllowedPrimaryKeySigType - , isAllowedSubkeySigType - , isAllowedUIDSigType - ) where + ( OpenPGPRFC (..) + , OpenPGPRFCW (..) + , SomeOpenPGPRFCW (..) + , promoteOpenPGPRFC + , demoteOpenPGPRFCW + , HashAlgorithmW (..) + , SomeHashAlgorithmW (..) + , promoteHashAlgorithm + , demoteHashAlgorithmW + , HashAlgoStatus (..) + , HashAlgoStatusFor + , HashAlgoAllowedFor + , HashAlgoVerifiableFor + , PKESKVersionPolicy (..) + , MessageEncryptionPolicy (..) + , SecretKeyProtectionPolicy (..) + , GenerationDeprecationPolicy (..) + , VerificationDefaults (..) + , DecryptPolicy (..) + , OpenPGPPolicy (..) + , policyForRFC + , defaultPolicy + , defaultPKESKVersionPolicy + , defaultVerificationDefaults + , defaultDecryptPolicy + , lenientDecryptPolicy + , supportsSEIPDv2Symmetric + , secretKeyProtectionPolicyForKeyVersion + , signatureV6SaltSizeForHashAlgorithm + , ecdhKdfHashDigest + , validateTable30PolicyForRecipient + , legacySecretKeyProtectionErrorMessage -import Codec.Encryption.OpenPGP.Types -import Codec.Encryption.OpenPGP.SignatureQualities (sigType) + -- * Signature verification policy + , VerificationPolicy (..) + , VerificationPolicyAction (..) + , defaultVerificationPolicy + , strictVerificationPolicy + , lenientVerificationPolicy + , isVerificationError + , isVerificationWarning + , applyVerificationPolicy + + -- * Signature context validation (RFC9580/RFC4880) + , isAllowedPrimaryKeySig + , isAllowedSubkeySig + , isAllowedUIDSig + + -- * Signature type validation helpers (for parser use) + , isAllowedPrimaryKeySigType + , isAllowedSubkeySigType + , isAllowedUIDSigType + ) where + import qualified Crypto.Hash as CH import qualified Crypto.Hash.Algorithms as CHAlg import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Types as ECCT import qualified Data.ByteArray as BA import qualified Data.ByteString as B -import Data.List (elem) import Data.Kind (Constraint) +import Data.List (elem) import Data.Word (Word8) -import GHC.TypeLits (ErrorMessage(..), TypeError) +import GHC.TypeLits (ErrorMessage (..), TypeError) +import Codec.Encryption.OpenPGP.SignatureQualities (sigType) +import Codec.Encryption.OpenPGP.Types + data OpenPGPRFC - = RFC2440 - | RFC4880 - | RFC9580 - deriving (Eq, Show) + = RFC2440 + | RFC4880 + | RFC9580 + deriving (Eq, Show) data OpenPGPRFCW (rfc :: OpenPGPRFC) where - RFC2440W :: OpenPGPRFCW 'RFC2440 - RFC4880W :: OpenPGPRFCW 'RFC4880 - RFC9580W :: OpenPGPRFCW 'RFC9580 + RFC2440W :: OpenPGPRFCW 'RFC2440 + RFC4880W :: OpenPGPRFCW 'RFC4880 + RFC9580W :: OpenPGPRFCW 'RFC9580 data SomeOpenPGPRFCW where - SomeOpenPGPRFCW :: OpenPGPRFCW rfc -> SomeOpenPGPRFCW + SomeOpenPGPRFCW :: OpenPGPRFCW rfc -> SomeOpenPGPRFCW demoteOpenPGPRFCW :: OpenPGPRFCW rfc -> OpenPGPRFC demoteOpenPGPRFCW RFC2440W = RFC2440 @@ -90,18 +102,18 @@ promoteOpenPGPRFC RFC9580 = SomeOpenPGPRFCW RFC9580W data HashAlgorithmW (h :: HashAlgorithm) where - DeprecatedMD5W :: HashAlgorithmW 'DeprecatedMD5 - SHA1W :: HashAlgorithmW 'SHA1 - RIPEMD160W :: HashAlgorithmW 'RIPEMD160 - SHA256W :: HashAlgorithmW 'SHA256 - SHA384W :: HashAlgorithmW 'SHA384 - SHA512W :: HashAlgorithmW 'SHA512 - SHA224W :: HashAlgorithmW 'SHA224 - SHA3_256W :: HashAlgorithmW 'SHA3_256 - SHA3_512W :: HashAlgorithmW 'SHA3_512 + DeprecatedMD5W :: HashAlgorithmW 'DeprecatedMD5 + SHA1W :: HashAlgorithmW 'SHA1 + RIPEMD160W :: HashAlgorithmW 'RIPEMD160 + SHA256W :: HashAlgorithmW 'SHA256 + SHA384W :: HashAlgorithmW 'SHA384 + SHA512W :: HashAlgorithmW 'SHA512 + SHA224W :: HashAlgorithmW 'SHA224 + SHA3_256W :: HashAlgorithmW 'SHA3_256 + SHA3_512W :: HashAlgorithmW 'SHA3_512 data SomeHashAlgorithmW where - SomeHashAlgorithmW :: HashAlgorithmW h -> SomeHashAlgorithmW + SomeHashAlgorithmW :: HashAlgorithmW h -> SomeHashAlgorithmW demoteHashAlgorithmW :: HashAlgorithmW h -> HashAlgorithm demoteHashAlgorithmW DeprecatedMD5W = DeprecatedMD5 @@ -126,7 +138,8 @@ promoteHashAlgorithm SHA3_512 = Just (SomeHashAlgorithmW SHA3_512W) promoteHashAlgorithm (OtherHA _) = Nothing -signatureV6SaltSizeForHashAlgorithm :: HashAlgorithm -> Maybe Word8 +signatureV6SaltSizeForHashAlgorithm + :: HashAlgorithm -> Maybe Word8 signatureV6SaltSizeForHashAlgorithm SHA224 = Just 16 signatureV6SaltSizeForHashAlgorithm SHA256 = Just 16 signatureV6SaltSizeForHashAlgorithm SHA384 = Just 24 @@ -136,200 +149,330 @@ signatureV6SaltSizeForHashAlgorithm _ = Nothing data HashAlgoStatus - = HashAllowed - | HashShouldNot - | HashMustNot + = HashAllowed + | HashShouldNot + | HashMustNot -type family HashAlgoStatusFor (rfc :: OpenPGPRFC) (h :: HashAlgorithm) :: HashAlgoStatus where - HashAlgoStatusFor 'RFC4880 'DeprecatedMD5 = 'HashShouldNot - HashAlgoStatusFor 'RFC9580 'DeprecatedMD5 = 'HashMustNot - HashAlgoStatusFor 'RFC9580 'SHA1 = 'HashMustNot - HashAlgoStatusFor 'RFC9580 'RIPEMD160 = 'HashShouldNot - HashAlgoStatusFor rfc h = 'HashAllowed +type family + HashAlgoStatusFor (rfc :: OpenPGPRFC) (h :: HashAlgorithm) + :: HashAlgoStatus + where + HashAlgoStatusFor 'RFC4880 'DeprecatedMD5 = 'HashShouldNot + HashAlgoStatusFor 'RFC9580 'DeprecatedMD5 = 'HashMustNot + HashAlgoStatusFor 'RFC9580 'SHA1 = 'HashMustNot + HashAlgoStatusFor 'RFC9580 'RIPEMD160 = 'HashShouldNot + HashAlgoStatusFor rfc h = 'HashAllowed type family AssertHashAllowed (status :: HashAlgoStatus) :: Constraint where - AssertHashAllowed 'HashAllowed = () - AssertHashAllowed 'HashShouldNot = - TypeError ('Text "Hash algorithm is deprecated (SHOULD NOT) for new signatures under this RFC") - AssertHashAllowed 'HashMustNot = - TypeError ('Text "Hash algorithm is disallowed (MUST NOT) for new signatures under this RFC") + AssertHashAllowed 'HashAllowed = () + AssertHashAllowed 'HashShouldNot = + TypeError + ( 'Text + "Hash algorithm is deprecated (SHOULD NOT) for new signatures under this RFC" + ) + AssertHashAllowed 'HashMustNot = + TypeError + ( 'Text + "Hash algorithm is disallowed (MUST NOT) for new signatures under this RFC" + ) -type HashAlgoAllowedFor rfc h = AssertHashAllowed (HashAlgoStatusFor rfc h) +type HashAlgoAllowedFor rfc h = + AssertHashAllowed (HashAlgoStatusFor rfc h) type family AssertHashVerifiable (status :: HashAlgoStatus) :: Constraint where - AssertHashVerifiable 'HashAllowed = () - AssertHashVerifiable 'HashShouldNot = () - AssertHashVerifiable 'HashMustNot = - TypeError ('Text "Hash algorithm is disallowed for verification in this RFC context") + AssertHashVerifiable 'HashAllowed = () + AssertHashVerifiable 'HashShouldNot = () + AssertHashVerifiable 'HashMustNot = + TypeError + ( 'Text + "Hash algorithm is disallowed for verification in this RFC context" + ) -type HashAlgoVerifiableFor rfc h = AssertHashVerifiable (HashAlgoStatusFor rfc h) +type HashAlgoVerifiableFor rfc h = + AssertHashVerifiable (HashAlgoStatusFor rfc h) data PKESKVersionPolicy - = PreferV6 - | ForceV3Interop - deriving (Eq, Show) + = PreferV6 + | ForceV3Interop + deriving (Eq, Show) data MessageEncryptionPolicy = MessageEncryptionPolicy - { messageDefaultSymmetricAlgorithm :: SymmetricAlgorithm - , messageDefaultAEADAlgorithm :: AEADAlgorithm - , messageDefaultChunkSize :: Word8 - , messageS2KSaltOctets :: Int - , messageSEIPDv2SaltOctets :: Int - , messageDefaultS2KForSalt :: Salt -> S2K - , messageSEIPDv2SymmetricAlgorithms :: [SymmetricAlgorithm] - } + { messageDefaultSymmetricAlgorithm :: SymmetricAlgorithm + , messageDefaultAEADAlgorithm :: AEADAlgorithm + , messageDefaultChunkSize :: Word8 + , messageS2KSaltOctets :: Int + , messageSEIPDv2SaltOctets :: Int + , messageDefaultS2KForSalt :: Salt -> S2K + , messageSEIPDv2SymmetricAlgorithms :: [SymmetricAlgorithm] + } data SecretKeyProtectionPolicy = SecretKeyProtectionPolicy - { secretKeyDefaultSymmetricAlgorithm :: SymmetricAlgorithm - , secretKeyDefaultAEADAlgorithm :: AEADAlgorithm - , secretKeyDefaultS2KForSalt :: Salt -> S2K - , secretKeyS2KSaltOctets :: Int - , secretKeyAEADNonceOctets :: Int - } + { secretKeyDefaultSymmetricAlgorithm :: SymmetricAlgorithm + , secretKeyDefaultAEADAlgorithm :: AEADAlgorithm + , secretKeyDefaultS2KForSalt :: Salt -> S2K + , secretKeyS2KSaltOctets :: Int + , secretKeyAEADNonceOctets :: Int + } data GenerationDeprecationPolicy = GenerationDeprecationPolicy - { deprecatedHashAlgorithms :: [HashAlgorithm] - , deprecatedSymmetricAlgorithms :: [SymmetricAlgorithm] - } + { deprecatedHashAlgorithms :: [HashAlgorithm] + , deprecatedSymmetricAlgorithms :: [SymmetricAlgorithm] + } data VerificationDefaults = VerificationDefaults - { verificationDefaultStrict :: Bool - , verificationDefaultStreaming :: Bool - } + { verificationDefaultStrict :: Bool + , verificationDefaultStreaming :: Bool + } --- | Per-message decrypt-side enforcement policy. --- --- 'defaultDecryptPolicy' applies RFC9580-strict rules: no unauthenticated --- (SED) ciphertext, modern symmetric algorithms only, and rejection of --- deprecated S2K specifiers in SKESK. Use 'lenientDecryptPolicy' when --- interoperating with older RFC4880 or RFC2440 messages. +-- | Action to take when a signature feature violates policy. +data VerificationPolicyAction + = -- | Treat as a hard verification error (reject signature) + VerificationError + | -- | Accept signature but record a warning + VerificationWarning + deriving (Eq, Show) + +{- | Policy controlling how signature verification handles deprecated or +discouraged features. This allows callers to choose between strict +rejection (errors) and lenient acceptance with warnings. +-} +data VerificationPolicy = VerificationPolicy + { vpDeprecatedHashAlgorithm :: VerificationPolicyAction + -- ^ Action for deprecated hash algorithms (MD5, SHA1, RIPEMD160) + , vpUnsupportedHashAlgorithm :: VerificationPolicyAction + -- ^ Action for unsupported/unknown hash algorithms + , vpPkaMismatch :: VerificationPolicyAction + -- ^ Action for PKA mismatch between signature and key + , vpUnsupportedCriticalSubpacket :: VerificationPolicyAction + -- ^ Action for unsupported critical subpackets + , vpLegacyIssuerKeyIdInV6 :: VerificationPolicyAction + -- ^ Action for legacy Issuer Key ID subpacket in v6 signatures + , vpMissingSubkeyBackSignature :: VerificationPolicyAction + -- ^ Action for missing subkey back-signature (v6 subkeys) + , vpInvalidSignatureContext :: VerificationPolicyAction + -- ^ Action for signature context violations (wrong sig type for context) + , vpExpiredSignature :: VerificationPolicyAction + -- ^ Action for expired signatures + } + deriving (Eq, Show) + +{- | Default verification policy: strict on security-critical issues, +lenient on deprecated but still verifiable features. +-} +defaultVerificationPolicy :: VerificationPolicy +defaultVerificationPolicy = + VerificationPolicy + { vpDeprecatedHashAlgorithm = VerificationWarning + , vpUnsupportedHashAlgorithm = VerificationError + , vpPkaMismatch = VerificationError + , vpUnsupportedCriticalSubpacket = VerificationError + , vpLegacyIssuerKeyIdInV6 = VerificationError + , vpMissingSubkeyBackSignature = VerificationWarning + , vpInvalidSignatureContext = VerificationError + , vpExpiredSignature = VerificationError + } + +-- | Strict verification policy: all policy violations are hard errors. +strictVerificationPolicy :: VerificationPolicy +strictVerificationPolicy = + VerificationPolicy + { vpDeprecatedHashAlgorithm = VerificationError + , vpUnsupportedHashAlgorithm = VerificationError + , vpPkaMismatch = VerificationError + , vpUnsupportedCriticalSubpacket = VerificationError + , vpLegacyIssuerKeyIdInV6 = VerificationError + , vpMissingSubkeyBackSignature = VerificationError + , vpInvalidSignatureContext = VerificationError + , vpExpiredSignature = VerificationError + } + +{- | Lenient verification policy: all policy violations are warnings. +Use only for interoperability with legacy data. +-} +lenientVerificationPolicy :: VerificationPolicy +lenientVerificationPolicy = + VerificationPolicy + { vpDeprecatedHashAlgorithm = VerificationWarning + , vpUnsupportedHashAlgorithm = VerificationWarning + , vpPkaMismatch = VerificationWarning + , vpUnsupportedCriticalSubpacket = VerificationWarning + , vpLegacyIssuerKeyIdInV6 = VerificationWarning + , vpMissingSubkeyBackSignature = VerificationWarning + , vpInvalidSignatureContext = VerificationWarning + , vpExpiredSignature = VerificationWarning + } + +-- | Check if a policy action is an error. +isVerificationError :: VerificationPolicyAction -> Bool +isVerificationError VerificationError = True +isVerificationError VerificationWarning = False + +-- | Check if a policy action is a warning. +isVerificationWarning :: VerificationPolicyAction -> Bool +isVerificationWarning VerificationWarning = True +isVerificationWarning VerificationError = False + +-- | Apply a policy action: return Left error or Right warning message. +applyVerificationPolicy + :: VerificationPolicyAction + -> String + -> Either String String +applyVerificationPolicy action msg = + if isVerificationError action + then Left msg + else Right msg + +{- | Per-message decrypt-side enforcement policy. + +'defaultDecryptPolicy' applies RFC9580-strict rules: no unauthenticated +(SED) ciphertext, modern symmetric algorithms only, and rejection of +deprecated S2K specifiers in SKESK. Use 'lenientDecryptPolicy' when +interoperating with older RFC4880 or RFC2440 messages. +-} data DecryptPolicy = DecryptPolicy - { -- | When 'False' (RFC9580 default), receiving a Symmetrically Encrypted - -- Data packet (SED, tag 9) is a hard error. RFC9580 §5.9 says - -- implementations SHOULD reject unauthenticated ciphertext. - decryptAllowSEDNoIntegrity :: Bool - -- | When 'False', receiving a SEIPDv1 (MDC-protected) packet is rejected. - -- Defaults to 'True' for interoperability with RFC4880 senders. - , decryptAllowSEIPDv1 :: Bool - -- | Allowed symmetric algorithms for session keys. 'Nothing' means - -- unrestricted. The RFC9580 default restricts to AES-128/192/256. - , decryptAllowedSymmetricAlgos :: Maybe [SymmetricAlgorithm] - -- | Allowed AEAD algorithms for SEIPDv2 payloads. 'Nothing' means - -- unrestricted. The RFC9580 default allows EAX, OCB, and GCM. - , decryptAllowedAEADAlgos :: Maybe [AEADAlgorithm] - -- | When 'True' (RFC9580 default), reject SKESK packets that use Simple - -- or Salted S2K specifiers (both deprecated since RFC9580). - , decryptRejectDeprecatedSKESK :: Bool - -- | When 'True' (RFC9580 default), any packet received after the - -- message-integrity boundary (MDC for SEIPDv1, final AEAD tag for - -- SEIPDv2, or the outer encrypted-data packet for SED) is a hard error. - -- RFC9580 §5.13.2 requires that implementations detect and reject - -- data appended after the authenticated payload. Set to 'False' only - -- when interoperating with legacy implementations that emit trailing - -- garbage (implies 'lenientDecryptPolicy'). - , decryptRejectTrailingData :: Bool - -- | When 'True' (RFC9580 default), a payload with no version-aligned - -- ESK is a hard error even when misaligned ESKs are present. This is a - -- distinct concern from trailing-data rejection: a message could have - -- correct framing yet still carry only v6 PKESKs before a SEIPDv1 - -- payload (or only v4 SKESKs before a SEIPDv2 payload), which indicates - -- a mis-assembled message rather than an integrity violation. - -- Set to 'False' only when salvaging malformed legacy messages. - , decryptRejectESKVersionMismatch :: Bool - } deriving (Eq, Show) + { decryptAllowSEDNoIntegrity :: Bool + {- ^ When 'False' (RFC9580 default), receiving a Symmetrically Encrypted + Data packet (SED, tag 9) is a hard error. RFC9580 §5.9 says + implementations SHOULD reject unauthenticated ciphertext. + -} + , decryptAllowSEIPDv1 :: Bool + {- ^ When 'False', receiving a SEIPDv1 (MDC-protected) packet is rejected. + Defaults to 'True' for interoperability with RFC4880 senders. + -} + , decryptAllowedSymmetricAlgos :: Maybe [SymmetricAlgorithm] + {- ^ Allowed symmetric algorithms for session keys. 'Nothing' means + unrestricted. The RFC9580 default restricts to AES-128/192/256. + -} + , decryptAllowedAEADAlgos :: Maybe [AEADAlgorithm] + {- ^ Allowed AEAD algorithms for SEIPDv2 payloads. 'Nothing' means + unrestricted. The RFC9580 default allows EAX, OCB, and GCM. + -} + , decryptRejectDeprecatedSKESK :: Bool + {- ^ When 'True' (RFC9580 default), reject SKESK packets that use Simple + or Salted S2K specifiers (both deprecated since RFC9580). + -} + , decryptRejectTrailingData :: Bool + {- ^ When 'True' (RFC9580 default), any packet received after the + message-integrity boundary (MDC for SEIPDv1, final AEAD tag for + SEIPDv2, or the outer encrypted-data packet for SED) is a hard error. + RFC9580 §5.13.2 requires that implementations detect and reject + data appended after the authenticated payload. Set to 'False' only + when interoperating with legacy implementations that emit trailing + garbage (implies 'lenientDecryptPolicy'). + -} + , decryptRejectESKVersionMismatch :: Bool + {- ^ When 'True' (RFC9580 default), a payload with no version-aligned + ESK is a hard error even when misaligned ESKs are present. This is a + distinct concern from trailing-data rejection: a message could have + correct framing yet still carry only v6 PKESKs before a SEIPDv1 + payload (or only v4 SKESKs before a SEIPDv2 payload), which indicates + a mis-assembled message rather than an integrity violation. + Set to 'False' only when salvaging malformed legacy messages. + -} + } + deriving (Eq, Show) data OpenPGPPolicy = OpenPGPPolicy - { policyRFC :: OpenPGPRFC - , policyMessageEncryption :: MessageEncryptionPolicy - , policySecretKeyProtection :: Maybe SecretKeyProtectionPolicy - , policyGenerationDeprecations :: GenerationDeprecationPolicy - , policyDecrypt :: DecryptPolicy - } + { policyRFC :: OpenPGPRFC + , policyMessageEncryption :: MessageEncryptionPolicy + , policySecretKeyProtection :: Maybe SecretKeyProtectionPolicy + , policyGenerationDeprecations :: GenerationDeprecationPolicy + , policyDecrypt :: DecryptPolicy + } policyForRFC :: OpenPGPRFC -> OpenPGPPolicy policyForRFC RFC2440 = - OpenPGPPolicy - { policyRFC = RFC2440 - , policyMessageEncryption = - MessageEncryptionPolicy - { messageDefaultSymmetricAlgorithm = TripleDES - , messageDefaultAEADAlgorithm = OCB - , messageDefaultChunkSize = 6 - , messageS2KSaltOctets = 8 - , messageSEIPDv2SaltOctets = 32 - , messageDefaultS2KForSalt = \salt -> IteratedSalted SHA1 (requireSalt8 "RFC2440 message S2K" salt) 65536 - , messageSEIPDv2SymmetricAlgorithms = [] - } - , policySecretKeyProtection = Nothing - , policyGenerationDeprecations = - GenerationDeprecationPolicy - { deprecatedHashAlgorithms = [] - , deprecatedSymmetricAlgorithms = [] - } - , policyDecrypt = lenientDecryptPolicy - } + OpenPGPPolicy + { policyRFC = RFC2440 + , policyMessageEncryption = + MessageEncryptionPolicy + { messageDefaultSymmetricAlgorithm = TripleDES + , messageDefaultAEADAlgorithm = OCB + , messageDefaultChunkSize = 6 + , messageS2KSaltOctets = 8 + , messageSEIPDv2SaltOctets = 32 + , messageDefaultS2KForSalt = \salt -> + IteratedSalted + SHA1 + (requireSalt8 "RFC2440 message S2K" salt) + 65536 + , messageSEIPDv2SymmetricAlgorithms = [] + } + , policySecretKeyProtection = Nothing + , policyGenerationDeprecations = + GenerationDeprecationPolicy + { deprecatedHashAlgorithms = [] + , deprecatedSymmetricAlgorithms = [] + } + , policyDecrypt = lenientDecryptPolicy + } policyForRFC RFC4880 = - OpenPGPPolicy - { policyRFC = RFC4880 - , policyMessageEncryption = - MessageEncryptionPolicy - { messageDefaultSymmetricAlgorithm = AES128 - , messageDefaultAEADAlgorithm = OCB - , messageDefaultChunkSize = 6 - , messageS2KSaltOctets = 8 - , messageSEIPDv2SaltOctets = 32 - , messageDefaultS2KForSalt = \salt -> IteratedSalted SHA256 (requireSalt8 "RFC4880 message S2K" salt) 65536 - , messageSEIPDv2SymmetricAlgorithms = [] - } - , policySecretKeyProtection = Nothing - , policyGenerationDeprecations = - GenerationDeprecationPolicy - { deprecatedHashAlgorithms = [DeprecatedMD5] - , deprecatedSymmetricAlgorithms = [] - } - , policyDecrypt = lenientDecryptPolicy - } + OpenPGPPolicy + { policyRFC = RFC4880 + , policyMessageEncryption = + MessageEncryptionPolicy + { messageDefaultSymmetricAlgorithm = AES128 + , messageDefaultAEADAlgorithm = OCB + , messageDefaultChunkSize = 6 + , messageS2KSaltOctets = 8 + , messageSEIPDv2SaltOctets = 32 + , messageDefaultS2KForSalt = \salt -> + IteratedSalted + SHA256 + (requireSalt8 "RFC4880 message S2K" salt) + 65536 + , messageSEIPDv2SymmetricAlgorithms = [] + } + , policySecretKeyProtection = Nothing + , policyGenerationDeprecations = + GenerationDeprecationPolicy + { deprecatedHashAlgorithms = [DeprecatedMD5] + , deprecatedSymmetricAlgorithms = [] + } + , policyDecrypt = lenientDecryptPolicy + } policyForRFC RFC9580 = - OpenPGPPolicy - { policyRFC = RFC9580 - , policyMessageEncryption = - MessageEncryptionPolicy - { messageDefaultSymmetricAlgorithm = AES256 - , messageDefaultAEADAlgorithm = OCB - , messageDefaultChunkSize = 6 - , messageS2KSaltOctets = 16 - , messageSEIPDv2SaltOctets = 32 - , messageDefaultS2KForSalt = \salt -> Argon2 (requireSalt16 "RFC9580 message S2K" salt) 1 4 15 - , messageSEIPDv2SymmetricAlgorithms = [AES128, AES192, AES256] - } - , policySecretKeyProtection = - Just - SecretKeyProtectionPolicy - { secretKeyDefaultSymmetricAlgorithm = AES256 - , secretKeyDefaultAEADAlgorithm = OCB - , secretKeyDefaultS2KForSalt = \salt -> Argon2 (requireSalt16 "RFC9580 secret key S2K" salt) 1 4 15 - , secretKeyS2KSaltOctets = 16 - , secretKeyAEADNonceOctets = 15 - } - , policyGenerationDeprecations = - GenerationDeprecationPolicy - { deprecatedHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160] - , deprecatedSymmetricAlgorithms = [IDEA, TripleDES, CAST5, Blowfish] - } - , policyDecrypt = defaultDecryptPolicy - } + OpenPGPPolicy + { policyRFC = RFC9580 + , policyMessageEncryption = + MessageEncryptionPolicy + { messageDefaultSymmetricAlgorithm = AES256 + , messageDefaultAEADAlgorithm = OCB + , messageDefaultChunkSize = 6 + , messageS2KSaltOctets = 16 + , messageSEIPDv2SaltOctets = 32 + , messageDefaultS2KForSalt = \salt -> Argon2 (requireSalt16 "RFC9580 message S2K" salt) 1 4 15 + , messageSEIPDv2SymmetricAlgorithms = [AES128, AES192, AES256] + } + , policySecretKeyProtection = + Just + SecretKeyProtectionPolicy + { secretKeyDefaultSymmetricAlgorithm = AES256 + , secretKeyDefaultAEADAlgorithm = OCB + , secretKeyDefaultS2KForSalt = \salt -> Argon2 (requireSalt16 "RFC9580 secret key S2K" salt) 1 4 15 + , secretKeyS2KSaltOctets = 16 + , secretKeyAEADNonceOctets = 15 + } + , policyGenerationDeprecations = + GenerationDeprecationPolicy + { deprecatedHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160] + , deprecatedSymmetricAlgorithms = + [IDEA, TripleDES, CAST5, Blowfish] + } + , policyDecrypt = defaultDecryptPolicy + } requireSalt8 :: String -> Salt -> Salt8 requireSalt8 context salt = - case salt8FromSalt salt of - Just salt8 -> salt8 - Nothing -> error (context ++ " requires an 8-octet salt") + case salt8FromSalt salt of + Just salt8 -> salt8 + Nothing -> error (context ++ " requires an 8-octet salt") requireSalt16 :: String -> Salt -> Salt16 requireSalt16 context salt = - case salt16FromSalt salt of - Just salt16 -> salt16 - Nothing -> error (context ++ " requires a 16-octet salt") + case salt16FromSalt salt of + Just salt16 -> salt16 + Nothing -> error (context ++ " requires a 16-octet salt") defaultPolicy :: OpenPGPPolicy defaultPolicy = policyForRFC RFC9580 @@ -339,51 +482,58 @@ defaultVerificationDefaults :: VerificationDefaults defaultVerificationDefaults = - VerificationDefaults - { verificationDefaultStrict = True - , verificationDefaultStreaming = True - } + VerificationDefaults + { verificationDefaultStrict = True + , verificationDefaultStreaming = True + } --- | RFC9580-strict decrypt policy. Rejects unauthenticated SED ciphertext, --- restricts session-key symmetric algorithms to AES-128/192/256 and AEAD to --- EAX/OCB/GCM, and rejects SKESK packets carrying deprecated Simple or --- Salted S2K specifiers. SEIPDv1 (MDC-protected) is still accepted for --- interoperability with RFC4880 senders. +{- | RFC9580-strict decrypt policy. Rejects unauthenticated SED ciphertext, +restricts session-key symmetric algorithms to AES-128/192/256 and AEAD to +EAX/OCB/GCM, and rejects SKESK packets carrying deprecated Simple or +Salted S2K specifiers. SEIPDv1 (MDC-protected) is still accepted for +interoperability with RFC4880 senders. +-} defaultDecryptPolicy :: DecryptPolicy defaultDecryptPolicy = - DecryptPolicy - { decryptAllowSEDNoIntegrity = False - , decryptAllowSEIPDv1 = True - , decryptAllowedSymmetricAlgos = Just [AES128, AES192, AES256] - , decryptAllowedAEADAlgos = Just [EAX, OCB, GCM] - , decryptRejectDeprecatedSKESK = True - , decryptRejectTrailingData = True - , decryptRejectESKVersionMismatch = True - } + DecryptPolicy + { decryptAllowSEDNoIntegrity = False + , decryptAllowSEIPDv1 = True + , decryptAllowedSymmetricAlgos = Just [AES128, AES192, AES256] + , decryptAllowedAEADAlgos = Just [EAX, OCB, GCM] + , decryptRejectDeprecatedSKESK = True + , decryptRejectTrailingData = True + , decryptRejectESKVersionMismatch = True + } --- | Permissive decrypt policy for interoperability with RFC4880 and RFC2440 --- messages. No algorithm or integrity restrictions are applied. +{- | Permissive decrypt policy for interoperability with RFC4880 and RFC2440 +messages. No algorithm or integrity restrictions are applied. +-} lenientDecryptPolicy :: DecryptPolicy lenientDecryptPolicy = - DecryptPolicy - { decryptAllowSEDNoIntegrity = True - , decryptAllowSEIPDv1 = True - , decryptAllowedSymmetricAlgos = Nothing - , decryptAllowedAEADAlgos = Nothing - , decryptRejectDeprecatedSKESK = False - , decryptRejectTrailingData = False - , decryptRejectESKVersionMismatch = False - } + DecryptPolicy + { decryptAllowSEDNoIntegrity = True + , decryptAllowSEIPDv1 = True + , decryptAllowedSymmetricAlgos = Nothing + , decryptAllowedAEADAlgos = Nothing + , decryptRejectDeprecatedSKESK = False + , decryptRejectTrailingData = False + , decryptRejectESKVersionMismatch = False + } -supportsSEIPDv2Symmetric :: OpenPGPPolicy -> SymmetricAlgorithm -> Bool +supportsSEIPDv2Symmetric + :: OpenPGPPolicy -> SymmetricAlgorithm -> Bool supportsSEIPDv2Symmetric policy sa = - sa `elem` messageSEIPDv2SymmetricAlgorithms (policyMessageEncryption policy) + sa + `elem` messageSEIPDv2SymmetricAlgorithms + (policyMessageEncryption policy) -secretKeyProtectionPolicyForKeyVersion :: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy +secretKeyProtectionPolicyForKeyVersion + :: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy secretKeyProtectionPolicyForKeyVersion policy V6 = policySecretKeyProtection policy secretKeyProtectionPolicyForKeyVersion _ _ = Nothing -ecdhKdfHashDigest :: HashAlgorithm -> B.ByteString -> Either String B.ByteString +ecdhKdfHashDigest + :: HashAlgorithm -> B.ByteString -> Either String B.ByteString ecdhKdfHashDigest SHA1 _ = Left "ECDH KDF hash algorithm SHA1 is disallowed by policy" ecdhKdfHashDigest SHA224 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA224)) ecdhKdfHashDigest SHA256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA256)) @@ -393,68 +543,74 @@ ecdhKdfHashDigest SHA3_512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA3_512)) ecdhKdfHashDigest _ _ = Left "ECDH KDF hash algorithm is unsupported" -validateTable30PolicyForRecipient :: - SomePKPayload -> HashAlgorithm -> SymmetricAlgorithm -> Either String () +validateTable30PolicyForRecipient + :: SomePKPayload + -> HashAlgorithm + -> SymmetricAlgorithm + -> Either String () validateTable30PolicyForRecipient recipientPKP kdfHA kdfSA = - case allowedTable30EcdhParameterSets recipientPKP (_pubkey recipientPKP) of - Nothing -> Right () - Just (curveName, allowedParams) -> - if (kdfHA, kdfSA) `elem` allowedParams - then Right () - else - Left - ("RFC9580 Table 30 policy violation for " ++ - show (_keyVersion recipientPKP) ++ - " ECDH key on " ++ - curveName ++ - ": expected one of " ++ - show allowedParams ++ - ", got (" ++ - show kdfHA ++ - ", " ++ - show kdfSA ++ - ")") + case allowedTable30EcdhParameterSets + recipientPKP + (_pubkey recipientPKP) of + Nothing -> Right () + Just (curveName, allowedParams) -> + if (kdfHA, kdfSA) `elem` allowedParams + then Right () + else + Left + ( "RFC9580 Table 30 policy violation for " + ++ show (_keyVersion recipientPKP) + ++ " ECDH key on " + ++ curveName + ++ ": expected one of " + ++ show allowedParams + ++ ", got (" + ++ show kdfHA + ++ ", " + ++ show kdfSA + ++ ")" + ) -allowedTable30EcdhParameterSets :: - SomePKPayload - -> PKey - -> Maybe (String, [(HashAlgorithm, SymmetricAlgorithm)]) +allowedTable30EcdhParameterSets + :: SomePKPayload + -> PKey + -> Maybe (String, [(HashAlgorithm, SymmetricAlgorithm)]) allowedTable30EcdhParameterSets recipientPKP (ECDHPubKey ecdhPub _ _) - | _keyVersion recipientPKP == V4 = - case ecdhPub of - EdDSAPubKey Ed25519 _ -> - Just - ( "Curve25519Legacy" - , [ (ha, sa) - | ha <- [SHA256, SHA384, SHA512] - , sa <- [AES128, AES192, AES256] - ] - ) - ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) - | curve == ECCT.getCurveByName ECCT.SEC_p256r1 -> - Just ("NIST P-256", [(SHA256, AES128)]) - | curve == ECCT.getCurveByName ECCT.SEC_p384r1 -> - Just ("NIST P-384", [(SHA384, AES192)]) - | curve == ECCT.getCurveByName ECCT.SEC_p521r1 -> - Just ("NIST P-521", [(SHA512, AES256)]) - _ -> Nothing - | _keyVersion recipientPKP == V6 = - case ecdhPub of - EdDSAPubKey Ed25519 _ -> Just ("Curve25519Legacy", [(SHA256, AES128)]) - ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) - | curve == ECCT.getCurveByName ECCT.SEC_p256r1 -> - Just ("NIST P-256", [(SHA256, AES128)]) - | curve == ECCT.getCurveByName ECCT.SEC_p384r1 -> - Just ("NIST P-384", [(SHA384, AES192)]) - | curve == ECCT.getCurveByName ECCT.SEC_p521r1 -> - Just ("NIST P-521", [(SHA512, AES256)]) - _ -> Nothing - | otherwise = Nothing + | _keyVersion recipientPKP == V4 = + case ecdhPub of + EdDSAPubKey EdSigningCurve25519 _ -> + Just + ( "Curve25519Legacy" + , [ (ha, sa) + | ha <- [SHA256, SHA384, SHA512] + , sa <- [AES128, AES192, AES256] + ] + ) + ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) + | curve == ECCT.getCurveByName ECCT.SEC_p256r1 -> + Just ("NIST P-256", [(SHA256, AES128)]) + | curve == ECCT.getCurveByName ECCT.SEC_p384r1 -> + Just ("NIST P-384", [(SHA384, AES192)]) + | curve == ECCT.getCurveByName ECCT.SEC_p521r1 -> + Just ("NIST P-521", [(SHA512, AES256)]) + _ -> Nothing + | _keyVersion recipientPKP == V6 = + case ecdhPub of + EdDSAPubKey EdSigningCurve25519 _ -> Just ("Curve25519Legacy", [(SHA256, AES128)]) + ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) + | curve == ECCT.getCurveByName ECCT.SEC_p256r1 -> + Just ("NIST P-256", [(SHA256, AES128)]) + | curve == ECCT.getCurveByName ECCT.SEC_p384r1 -> + Just ("NIST P-384", [(SHA384, AES192)]) + | curve == ECCT.getCurveByName ECCT.SEC_p521r1 -> + Just ("NIST P-521", [(SHA512, AES256)]) + _ -> Nothing + | otherwise = Nothing allowedTable30EcdhParameterSets _ _ = Nothing legacySecretKeyProtectionErrorMessage :: String legacySecretKeyProtectionErrorMessage = - "re-encrypting legacy secret keys without SHA-1 protection is unsupported; explicit legacy override required" + "re-encrypting legacy secret keys without SHA-1 protection is unsupported; explicit legacy override required" -- RFC9580/RFC4880 signature context validation predicates -- These enforce which signature types are allowed in which structural contexts diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -2,3130 +2,3620 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleInstances #-} - -module Codec.Encryption.OpenPGP.Serialize - ( - -- * Serialization functions - putPkt - , putPktEither - , putSKAddendum - , getSecretKey - , putSKeyForPKPayload - -- * Utilities - , dearmorIfAsciiArmored - , dearmorIfAsciiArmoredLenient - , looksLikeAsciiArmor - , armorPayloadsOfType - , singleArmorPayloadOfType - , singleClearSignedBlock - , recommendedArmorType - , WireRepInput(..) - , wireRepRefFromInput - , PktParseError(..) - , parsePkts - , parsePktsEither - , parsePktsWithWireRep - , conduitParsePktsWithWireRep - ) where - -import Control.Applicative (many, some) -import Control.Arrow ((***)) -import Control.Lens ((^.), _1) -import Control.Monad (guard, replicateM, replicateM_, when) -import Crypto.Number.Basic (numBits) -import Crypto.Number.ModArithmetic (inverse) -import Crypto.Number.Serialize (i2osp, os2ip) -import qualified Crypto.PubKey.DSA as D -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.ECC.Types as ECCT -import qualified Crypto.PubKey.RSA as R -import Data.Bifunctor (bimap) -import Data.Binary (Binary, get, put) -import Data.Binary.Get - ( ByteOffset - , Get - , bytesRead - , getByteString - , getLazyByteString - , getRemainingLazyByteString - , getWord16be - , getWord16le - , getWord32be - , getWord8 - , lookAhead - , runGetOrFail - ) -import Data.Binary.Put - ( Put - , putByteString - , putLazyByteString - , putWord16be - , putWord16le - , putWord32be - , putWord8 - , runPut - ) -import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit) -import qualified Data.ByteString as B -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC8 -import qualified Data.Foldable as F -import Data.Int (Int64) -import Data.List (mapAccumL) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (fromMaybe) -import Data.Set (Set) -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) -import Data.Text.Encoding.Error (lenientDecode) -import Data.Word (Word16, Word32, Word8) -import Network.URI (nullURI, parseURI, uriToString) - -import Codec.Encryption.OpenPGP.Internal - ( curve2Curve - , curveFromCurve - , curveToCurveoidBS - , curveoidBSToCurve - , curveoidBSToEdSigningCurve - , edSigningCurveToCurveoidBS - , leftPadTo - , pubkeyToMPIs - ) -import Codec.Encryption.OpenPGP.Policy (signatureV6SaltSizeForHashAlgorithm) -import Codec.Encryption.OpenPGP.Types -import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA -import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..)) -import Data.Conduit (ConduitT, await, yield) -import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes -import qualified Codec.Encryption.OpenPGP.Types.Internal.PKITypes as P - -instance Binary SigSubPacket where - get = getSigSubPacket - put = putSigSubPacket - --- instance Binary (Set NotationFlag) where --- put = putNotationFlagSet -instance Binary CompressionAlgorithm where - get = toFVal <$> getWord8 - put = putWord8 . fromFVal - -instance Binary PubKeyAlgorithm where - get = toFVal <$> getWord8 - put = putWord8 . fromFVal - -instance Binary HashAlgorithm where - get = toFVal <$> getWord8 - put = putWord8 . fromFVal - -instance Binary SymmetricAlgorithm where - get = toFVal <$> getWord8 - put = putWord8 . fromFVal - -instance Binary MPI where - get = getMPI - put = putMPI - -instance Binary SigType where - get = toFVal <$> getWord8 - put = putWord8 . fromFVal - -instance Binary UserAttrSubPacket where - get = getUserAttrSubPacket - put = putUserAttrSubPacket - -instance Binary S2K where - get = getS2K - put = putS2K - -instance Binary (PKESK 'PKESKV3) where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary (PKESK 'PKESKV6) where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary Signature where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary (SKESK 'SKESKV4) where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary (SKESK 'SKESKV6) where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary (OnePassSignature 'OPSV3) where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary (OnePassSignature 'OPSV6) where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary SecretKey where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary PublicKey where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary SecretSubkey where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary CompressedData where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary SymEncData where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary Marker where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary LiteralData where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary Trust where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary UserId where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary PublicSubkey where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary UserAttribute where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary SymEncIntegrityProtectedData where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary ModificationDetectionCode where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary OtherPacket where - get = getPkt >>= either fail pure . fromPktEither - put = putPkt . toPkt - -instance Binary Pkt where - get = getPkt - put = putPkt - -instance Binary a => Binary (Block a) where - get = Block `fmap` many get - put = mapM_ put . unBlock - -instance Binary SomePKPayload where - get = getPKPayload - put = putPKPayload - -instance Binary SignaturePayload where - get = getSignaturePayload - put = putSignaturePayload - -instance Binary TKUnknown where - get = fail "Binary TKUnknown decode is not implemented" - put = putTK - -getSigSubPacket :: Get SigSubPacket -getSigSubPacket = do - l <- fmap fromIntegral getSubPacketLength - (crit, pt) <- getSigSubPacketType - getSigSubPacket' pt crit l - where - getSigSubPacket' :: Word8 -> Bool -> ByteOffset -> Get SigSubPacket - getSigSubPacket' pt crit l - | pt == 2 = do - et <- fmap ThirtyTwoBitTimeStamp getWord32be - return $ SigSubPacket crit (SigCreationTime et) - | pt == 3 = do - et <- fmap ThirtyTwoBitDuration getWord32be - return $ SigSubPacket crit (SigExpirationTime et) - | pt == 4 = do - e <- get - return $ SigSubPacket crit (ExportableCertification e) - | pt == 5 = do - tl <- getWord8 - ta <- getWord8 - return $ SigSubPacket crit (TrustSignature tl ta) - | pt == 6 = do - apdre <- getLazyByteString (l - 2) - nul <- getWord8 - guard (nul == 0) - return $ SigSubPacket crit (RegularExpression (BL.copy apdre)) - | pt == 7 = do - r <- get - return $ SigSubPacket crit (Revocable r) - | pt == 9 = do - et <- fmap ThirtyTwoBitDuration getWord32be - return $ SigSubPacket crit (KeyExpirationTime et) - | pt == 11 = do - sa <- replicateM (fromIntegral (l - 1)) get - return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa) - | pt == 12 = do - rclass <- getWord8 - guard (testBit rclass 7) - algid <- get - fp <- getLazyByteString (fromIntegral l - 3) - return $ - SigSubPacket - crit - (RevocationKey - (bsToFFSet . BL.singleton $ rclass .&. 0x7f) - algid - (Fingerprint fp)) - | pt == 16 = do - keyid <- getLazyByteString (l - 1) - return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid)) - | pt == 20 = do - flags <- getLazyByteString 4 - nl <- getWord16be - vl <- getWord16be - nn <- getLazyByteString (fromIntegral nl) - nv <- getLazyByteString (fromIntegral vl) - return $ - SigSubPacket - crit - (NotationData (bsToFFSet flags) (NotationName nn) (NotationValue nv)) - | pt == 21 = do - ha <- replicateM (fromIntegral (l - 1)) get - return $ SigSubPacket crit (PreferredHashAlgorithms ha) - | pt == 22 = do - ca <- replicateM (fromIntegral (l - 1)) get - return $ SigSubPacket crit (PreferredCompressionAlgorithms ca) - | pt == 23 = do - ksps <- getLazyByteString (l - 1) - return $ SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps)) - | pt == 24 = do - pks <- getLazyByteString (l - 1) - return $ SigSubPacket crit (PreferredKeyServer pks) - | pt == 25 = do - primacy <- get - return $ SigSubPacket crit (PrimaryUserId primacy) - | pt == 26 = do - url <- - fmap - (URL . fromMaybe nullURI . parseURI . T.unpack . - decodeUtf8With lenientDecode) - (getByteString (fromIntegral (l - 1))) - return $ SigSubPacket crit (PolicyURL url) - | pt == 27 = do - kfs <- getLazyByteString (l - 1) - return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs)) - | pt == 28 = do - uid <- getByteString (fromIntegral (l - 1)) - return $ - SigSubPacket crit (SignersUserId (decodeUtf8With lenientDecode uid)) - | pt == 29 = do - rcode <- getWord8 - rreason <- - fmap - (decodeUtf8With lenientDecode) - (getByteString (fromIntegral (l - 2))) - return $ SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason) - | pt == 30 = do - fbs <- getLazyByteString (l - 1) - return $ SigSubPacket crit (Features (bsToFFSet fbs)) - | pt == 31 = do - pka <- get - ha <- get - hash <- getLazyByteString (l - 3) - return $ SigSubPacket crit (SignatureTarget pka ha hash) - | pt == 32 = do - spbs <- getLazyByteString (l - 1) - case runGetOrFail get spbs of - Left (_, _, e) -> fail ("embedded signature subpacket " ++ e) - Right (_, _, sp) -> return $ SigSubPacket crit (EmbeddedSignature sp) - | pt == 33 = do - when (l /= 22 && l /= 34) $ - fail ("invalid issuer fingerprint subpacket length: " ++ show l) - kv <- getWord8 - let fpLen = l - 2 - when (fpLen /= 20 && fpLen /= 32) $ - fail ("invalid issuer fingerprint length: " ++ show fpLen) - case BTypes.packetVersionToIssuerFingerprintVersion kv of - Nothing -> - fail ("invalid issuer fingerprint version marker: " ++ show kv) - Just ifVersion -> do - fp <- - case kv of - 4 -> getLazyByteString (fromIntegral fpLen) - 6 -> getLazyByteString (fromIntegral fpLen) - _ -> fail ("invalid issuer fingerprint version marker: " ++ show kv) - return $ - SigSubPacket crit (IssuerFingerprint ifVersion (Fingerprint fp)) - | pt > 99 && pt < 111 = do - payload <- getLazyByteString (l - 1) - return $ SigSubPacket crit (UserDefinedSigSub pt payload) - | otherwise = do - payload <- getLazyByteString (l - 1) - return $ SigSubPacket crit (OtherSigSub pt payload) - -putSigSubPacket :: SigSubPacket -> Put -putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do - putSubPacketLength 5 - putSigSubPacketType crit 2 - putWord32be . unThirtyTwoBitTimeStamp $ et -putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do - putSubPacketLength 5 - putSigSubPacketType crit 3 - putWord32be . unThirtyTwoBitDuration $ et -putSigSubPacket (SigSubPacket crit (ExportableCertification e)) = do - putSubPacketLength 2 - putSigSubPacketType crit 4 - put e -putSigSubPacket (SigSubPacket crit (TrustSignature tl ta)) = do - putSubPacketLength 3 - putSigSubPacketType crit 5 - put tl - put ta -putSigSubPacket (SigSubPacket crit (RegularExpression apdre)) = do - putSubPacketLength . fromIntegral $ (2 + BL.length apdre) - putSigSubPacketType crit 6 - putLazyByteString apdre - putWord8 0 -putSigSubPacket (SigSubPacket crit (Revocable r)) = do - putSubPacketLength 2 - putSigSubPacketType crit 7 - put r -putSigSubPacket (SigSubPacket crit (KeyExpirationTime et)) = do - putSubPacketLength 5 - putSigSubPacketType crit 9 - putWord32be . unThirtyTwoBitDuration $ et -putSigSubPacket (SigSubPacket crit (PreferredSymmetricAlgorithms ess)) = do - putSubPacketLength . fromIntegral $ (1 + length ess) - putSigSubPacketType crit 11 - mapM_ put ess -putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do - let fpLen = BL.length (unFingerprint fp) - putSubPacketLength (fromIntegral (3 + fpLen)) -- type(1) + rclass(1) + algid(1) + fingerprint - putSigSubPacketType crit 12 - putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $ - Set.insert (RClOther 0) rclass - put algid - putLazyByteString (unFingerprint fp) -putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do - putSubPacketLength 9 - putSigSubPacketType crit 16 - putLazyByteString (unEOKI keyid) -- 8 octets -putSigSubPacket (SigSubPacket crit (NotationData nfs (NotationName nn) (NotationValue nv))) = do - putSubPacketLength . fromIntegral $ (9 + BL.length nn + BL.length nv) - putSigSubPacketType crit 20 - putLazyByteString . ffSetToFixedLengthBS (4 :: Int) $ nfs - putWord16be . fromIntegral . BL.length $ nn - putWord16be . fromIntegral . BL.length $ nv - putLazyByteString nn - putLazyByteString nv -putSigSubPacket (SigSubPacket crit (PreferredHashAlgorithms ehs)) = do - putSubPacketLength . fromIntegral $ (1 + length ehs) - putSigSubPacketType crit 21 - mapM_ put ehs -putSigSubPacket (SigSubPacket crit (PreferredCompressionAlgorithms ecs)) = do - putSubPacketLength . fromIntegral $ (1 + length ecs) - putSigSubPacketType crit 22 - mapM_ put ecs -putSigSubPacket (SigSubPacket crit (KeyServerPreferences ksps)) = do - let kbs = ffSetToBS ksps - putSubPacketLength . fromIntegral $ (1 + BL.length kbs) - putSigSubPacketType crit 23 - putLazyByteString kbs -putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do - putSubPacketLength . fromIntegral $ (1 + BL.length ks) - putSigSubPacketType crit 24 - putLazyByteString ks -putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do - putSubPacketLength 2 - putSigSubPacketType crit 25 - put primacy -putSigSubPacket (SigSubPacket crit (PolicyURL (URL uri))) = do - let bs = encodeUtf8 (T.pack (uriToString id uri "")) - putSubPacketLength . fromIntegral $ (1 + B.length bs) - putSigSubPacketType crit 26 - putByteString bs -putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do - let kbs = ffSetToBS kfs - putSubPacketLength . fromIntegral $ (1 + BL.length kbs) - putSigSubPacketType crit 27 - putLazyByteString kbs -putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do - let bs = encodeUtf8 userid - putSubPacketLength . fromIntegral $ (1 + B.length bs) - putSigSubPacketType crit 28 - putByteString bs -putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do - let reasonbs = encodeUtf8 rreason - putSubPacketLength . fromIntegral $ (2 + B.length reasonbs) - putSigSubPacketType crit 29 - putWord8 . fromFVal $ rcode - putByteString reasonbs -putSigSubPacket (SigSubPacket crit (Features fs)) = do - let fbs = ffSetToBS fs - putSubPacketLength . fromIntegral $ (1 + BL.length fbs) - putSigSubPacketType crit 30 - putLazyByteString fbs -putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do - putSubPacketLength . fromIntegral $ (3 + BL.length hash) - putSigSubPacketType crit 31 - put pka - put ha - putLazyByteString hash -putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do - let spb = runPut (put sp) - putSubPacketLength . fromIntegral $ (1 + BL.length spb) - putSigSubPacketType crit 32 - putLazyByteString spb -putSigSubPacket (SigSubPacket crit (IssuerFingerprint kv fp)) = do - let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv - let fpb = unFingerprint fp - when (BL.length fpb /= 20 && BL.length fpb /= 32) $ - error ("invalid issuer fingerprint length: " ++ show (BL.length fpb)) - putSubPacketLength . fromIntegral $ (2 + BL.length fpb) - putSigSubPacketType crit 33 - putWord8 kv' - putLazyByteString fpb -putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) = - putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) -putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do - putSubPacketLength . fromIntegral $ (1 + BL.length payload) - putSigSubPacketType crit ptype - putLazyByteString payload - -getSubPacketLength :: Get Word32 -getSubPacketLength = getSubPacketLength' =<< getWord8 - where - getSubPacketLength' :: Integral a => Word8 -> Get a - getSubPacketLength' f - | f < 192 = return . fromIntegral $ f - | f < 224 = do - secondOctet <- getWord8 - return . fromIntegral $ shiftL (fromIntegral (f - 192) :: Int) 8 + - (fromIntegral secondOctet :: Int) + - 192 - | f == 255 = do - len <- getWord32be - return . fromIntegral $ len - | otherwise = fail "Partial body length invalid." - -putSubPacketLength :: Word32 -> Put -putSubPacketLength l - | l < 192 = putWord8 (fromIntegral l) - | l < 8384 = - putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >> - putWord8 (fromIntegral (l - 192) .&. 0xff) - | l <= 0xffffffff = putWord8 255 >> putWord32be (fromIntegral l) - | otherwise = error ("too big (" ++ show l ++ ")") - -getSigSubPacketType :: Get (Bool, Word8) -getSigSubPacketType = do - x <- getWord8 - return - (if x .&. 128 == 128 - then (True, x .&. 127) - else (False, x)) - -putSigSubPacketType :: Bool -> Word8 -> Put -putSigSubPacketType False sst = putWord8 sst -putSigSubPacketType True sst = putWord8 (sst .|. 0x80) - -bsToFFSet :: FutureFlag a => ByteString -> Set a -bsToFFSet bs = - Set.fromAscList . concat . snd $ - mapAccumL - (\acc y -> (acc + 8, concatMap (shifty acc y) [0 .. 7])) - 0 - (BL.unpack bs) - where - shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x] - -ffSetToFixedLengthBS :: (Integral a, FutureFlag b) => a -> Set b -> ByteString -ffSetToFixedLengthBS len ffs = - BL.take - (fromIntegral len) - (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0))) - -ffSetToBS :: FutureFlag a => Set a -> ByteString -ffSetToBS = BL.pack . ffSetToBS' - where - ffSetToBS' :: FutureFlag a => Set a -> [Word8] - ffSetToBS' ks - -- Emit a single zero octet for an empty flag set so encoded flag - -- subpackets always carry an explicit flags byte. - | Set.null ks = [0] - | otherwise = - map - ((foldl (.|.) 0 . map (shiftR 128 . flip mod 8 . fromFFlag) . - Set.toAscList) . - (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks)) - [0 .. fromFFlag (Set.findMax ks) `div` 8] - -fromS2K :: S2K -> ByteString -fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo] -fromS2K (Salted hashalgo salt) = - BL.pack [1, fromIntegral . fromFVal $ hashalgo] `BL.append` - (BL.fromStrict . unSalt8) salt -fromS2K (IteratedSalted hashalgo salt count) = - BL.pack [3, fromIntegral . fromFVal $ hashalgo] `BL.append` - (BL.fromStrict . unSalt8) salt `BL.snoc` - encodeIterationCount count -fromS2K (Argon2 salt t p encodedM) = - BL.pack [4] `BL.append` (BL.fromStrict . unSalt16) salt `BL.append` - BL.pack [t, p, encodedM] -fromS2K (OtherS2K _ bs) = bs - -getPacketLength :: Get Integer -getPacketLength = do - firstOctet <- getWord8 - lenOrPartial <- lengthOctetToLength firstOctet - case lenOrPartial of - Left _ -> - fail "Partial body length is invalid in this context" - Right len -> return len - where - lengthOctetToLength :: Word8 -> Get (Either Integer Integer) - lengthOctetToLength f - | f < 192 = return . Right . fromIntegral $ f - | f < 224 = do - secondOctet <- getWord8 - return . Right . fromIntegral $ - shiftL (fromIntegral (f - 192) :: Int) 8 + - (fromIntegral secondOctet :: Int) + - 192 - | f < 255 = - return . Left . fromIntegral $ (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f) - | otherwise = do - len <- getWord32be - return . Right . fromIntegral $ len - -putPacketLength :: Integer -> Put -putPacketLength l - | l < 192 = putWord8 (fromIntegral l) - | l < 8384 = - putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >> - putWord8 (fromIntegral (l - 192) .&. 0xff) - | l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l) - | otherwise = error "packet length exceeds 32-bit definite length encoding" - -putPartialLength :: Word8 -> Put -putPartialLength n = putWord8 (224 + n) - -getPacketLengthFromOctet :: Word8 -> Get (Either Int64 Int64) -getPacketLengthFromOctet f - | f < 192 = return . Right . fromIntegral $ f - | f < 224 = do - secondOctet <- getWord8 - return . Right . fromIntegral $ - shiftL (fromIntegral (f - 192) :: Int) 8 + - (fromIntegral secondOctet :: Int) + - 192 - | f < 255 = - return . Left . fromIntegral $ (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f) - | otherwise = do - len <- getWord32be - return . Right . fromIntegral $ len - -getS2K :: Get S2K -getS2K = getS2K' =<< getWord8 - where - getS2K' :: Word8 -> Get S2K - getS2K' t - | t == 0 = do - ha <- getWord8 - return $ Simple (toFVal ha) - | t == 1 = do - ha <- getWord8 - salt <- getByteString 8 - return $ Salted (toFVal ha) (Salt8 salt) - | t == 3 = do - ha <- getWord8 - salt <- getByteString 8 - count <- getWord8 - return $ - IteratedSalted (toFVal ha) (Salt8 salt) (decodeIterationCount count) - | t == 4 = do - salt <- getByteString 16 - passes <- getWord8 - parallelism <- getWord8 - encodedM <- getWord8 - return $ Argon2 (Salt16 salt) passes parallelism encodedM - | otherwise = do - bs <- getRemainingLazyByteString - return $ OtherS2K t bs - -putS2K :: S2K -> Put -putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo) -putS2K (Salted hashalgo salt) = - error ("confused by salted" ++ show hashalgo ++ " by " ++ show salt) -putS2K (IteratedSalted ha salt count) = do - putWord8 3 - put ha - putByteString (unSalt8 salt) - putWord8 $ encodeIterationCount count -putS2K (Argon2 salt t p encodedM) = do - putWord8 4 - putByteString (unSalt16 salt) - putWord8 t - putWord8 p - putWord8 encodedM -putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs - -v6SaltSizeForHashAlgorithm :: HashAlgorithm -> Maybe Word8 -v6SaltSizeForHashAlgorithm = signatureV6SaltSizeForHashAlgorithm - -getPacketTypeAndPayload :: Get (Word8, ByteString) -getPacketTypeAndPayload = do - tag <- getWord8 - guard (testBit tag 7) - case tag .&. 0x40 of - 0x00 -> do - let t = shiftR (tag .&. 0x3c) 2 - case tag .&. 0x03 of - 0 -> do - len <- getWord8 - bs <- getLazyByteString (fromIntegral len) - return (t, bs) - 1 -> do - len <- getWord16be - bs <- getLazyByteString (fromIntegral len) - return (t, bs) - 2 -> do - len <- getWord32be - bs <- getLazyByteString (fromIntegral len) - return (t, bs) - 3 -> do - bs <- getRemainingLazyByteString - return (t, bs) - _ -> error "This should never happen (getPacketTypeAndPayload/0x00)." - 0x40 -> do - firstLenOctet <- getWord8 - bs <- getPacketPayloadFromLengthOctet firstLenOctet - return (tag .&. 0x3f, bs) - _ -> error "This should never happen (getPacketTypeAndPayload/???)." - where - getPacketPayloadFromLengthOctet :: Word8 -> Get ByteString - getPacketPayloadFromLengthOctet lenOctet = do - lenOrPartial <- getPacketLengthFromOctet lenOctet - case lenOrPartial of - Right len -> getLazyByteString len - Left partialLen -> do - chunk <- getLazyByteString partialLen - rest <- getRemainingPartialPayload - return (chunk <> rest) - getRemainingPartialPayload :: Get ByteString - getRemainingPartialPayload = do - lenOctet <- getWord8 - lenOrPartial <- getPacketLengthFromOctet lenOctet - case lenOrPartial of - Right len -> getLazyByteString len - Left partialLen -> do - chunk <- getLazyByteString partialLen - (chunk <>) <$> getRemainingPartialPayload - -getPkt :: Get Pkt -getPkt = do - (t, pl) <- getPacketTypeAndPayload - case runGetOrFail (getPkt' t (BL.length pl)) pl of - Left (_, _, e) -> return $! BrokenPacketPkt e t pl - Right (_, _, p) -> return p - where - parseLegacyPKESK :: PacketVersion -> BL.ByteString -> Either String Pkt - parseLegacyPKESK pv body = do - (_, _, (eokeyid, pkaRaw, mpib)) <- - bimap (\(_, _, e) -> e) id $ - runGetOrFail - (do eokeyid <- getLazyByteString 8 - pka <- getWord8 - mpib <- getRemainingLazyByteString - pure (eokeyid, pka, mpib)) - body - let pka = toFVal pkaRaw - sk <- parseLegacyPKESKMPIs pka mpib - pure $ - PKESKPkt - (PKESKPayloadV3Packet (PKESKPayloadV3 pv (EightOctetKeyId eokeyid) pka sk)) - - parseLegacyPKESKMPIs :: PubKeyAlgorithm -> BL.ByteString -> Either String (NE.NonEmpty MPI) - parseLegacyPKESKMPIs pka mpib = do - case parseLegacyPKESKMPIsStrict pka mpib of - Right sk -> pure sk - Left strictErr - | pka == X25519 -> - case parseLegacyPKESKX25519V3Octets mpib of - Right sk -> Right sk - Left octetErr -> - Left - (strictErr ++ - "; also failed to parse RFC9580 X25519 v3 octet layout: " ++ - octetErr) - | pka == ECDH -> - case parseLegacyPKESKECDHOctets mpib of - Right sk -> Right sk - Left octetErr -> - Left - (strictErr ++ - "; also failed to parse RFC6637 ECDH v3 octet layout: " ++ - octetErr) - | otherwise -> Left strictErr - - parseLegacyPKESKMPIsStrict :: - PubKeyAlgorithm -> BL.ByteString -> Either String (NE.NonEmpty MPI) - parseLegacyPKESKMPIsStrict pka mpib = do - (rest, _, sk) <- - bimap (\(_, _, e) -> e) id $ - runGetOrFail (parserForLegacyPKESKMPIs pka) mpib - if BL.null rest - then pure (NE.fromList sk) - else - Left - ("unexpected trailing PKESK MPI data for algorithm " ++ show pka) - - parseLegacyPKESKX25519V3Octets :: BL.ByteString -> Either String (NE.NonEmpty MPI) - parseLegacyPKESKX25519V3Octets mpib = do - if BL.length mpib < 33 - then Left "X25519 v3 PKESK octet layout is too short" - else Right () - let ephemeral = BL.toStrict (BL.take 32 mpib) - eskLen = fromIntegral (BL.index mpib 32) :: Int - eskWithAlgo = BL.toStrict (BL.drop 33 mpib) - if eskLen /= B.length eskWithAlgo - then Left "X25519 v3 PKESK octet layout has inconsistent ESK length" - else Right () - if B.null eskWithAlgo - then Left "X25519 v3 PKESK octet layout must include a symmetric algorithm octet" - else Right () - let symAlgo = B.head eskWithAlgo - if symAlgo `elem` [fromIntegral (fromFVal AES128), fromIntegral (fromFVal AES192), fromIntegral (fromFVal AES256)] - then pure (NE.fromList [MPI (os2ip ephemeral), MPI (os2ip eskWithAlgo)]) - else - Left - ("X25519 v3 PKESK octet layout has unsupported symmetric algorithm octet " ++ - show symAlgo) - - -- | Parse an RFC 6637 §8 ECDH PKESKv3 body as MPI(ephemeral) || 1-octet-count || C. - -- This is the interoperable wire format produced by GnuPG and other RFC-compliant - -- implementations. hOpenPGP previously wrote both fields as MPIs; this fallback - -- allows reading RFC-compliant packets when the strict two-MPI path fails. - parseLegacyPKESKECDHOctets :: BL.ByteString -> Either String (NE.NonEmpty MPI) - parseLegacyPKESKECDHOctets mpib = do - (rest, _, ephMPI) <- - bimap (\(_, _, e) -> e) id $ runGetOrFail getMPI mpib - let restBS = BL.toStrict rest - when (B.null restBS) $ - Left "ECDH v3 PKESK RFC6637 octet layout: missing wrapped-key length octet after ephemeral MPI" - let wrappedLen = fromIntegral (B.head restBS) :: Int - wrapped = B.tail restBS - when (wrappedLen /= B.length wrapped) $ - Left - ("ECDH v3 PKESK RFC6637 octet layout: wrapped key length field " ++ - show wrappedLen ++ " does not match body length " ++ show (B.length wrapped)) - when (wrappedLen < 24 || wrappedLen `mod` 8 /= 0) $ - Left - ("ECDH v3 PKESK RFC6637 octet layout: wrapped key length " ++ - show wrappedLen ++ " is not a valid RFC 3394 wrapped key size") - pure (ephMPI NE.:| [MPI (os2ip wrapped)]) - - parserForLegacyPKESKMPIs :: PubKeyAlgorithm -> Get [MPI] - parserForLegacyPKESKMPIs pka = - case expectedLegacyPKESKMPIArity pka of - Just mpiCount -> replicateM mpiCount getMPI - Nothing -> some getMPI - - expectedLegacyPKESKMPIArity :: PubKeyAlgorithm -> Maybe Int - expectedLegacyPKESKMPIArity pka - | pka `elem` [RSA, DeprecatedRSAEncryptOnly] = Just 1 - | pka `elem` [ElgamalEncryptOnly, ForbiddenElgamal, ECDH, X25519] = Just 2 - | otherwise = Nothing - - validateV4SKESKEncryptedSessionKeyS2K :: S2K -> Maybe BL.ByteString -> Get () - validateV4SKESKEncryptedSessionKeyS2K _ Nothing = pure () - validateV4SKESKEncryptedSessionKeyS2K Simple {} (Just _) = - fail - "v4 SKESK packets with encrypted session keys must not use Simple S2K" - validateV4SKESKEncryptedSessionKeyS2K _ (Just _) = pure () - - parseV6PKESK :: BL.ByteString -> Either String Pkt - parseV6PKESK body = do - (_, _, (recipientKeyIdentifier, pka, esk)) <- - bimap (\(_, _, e) -> e) id $ - runGetOrFail - (do keyIdentifierLen <- getWord8 - recipientKeyIdentifier <- getLazyByteString (fromIntegral keyIdentifierLen) - pka <- getWord8 - esk <- getRemainingLazyByteString - pure (recipientKeyIdentifier, pka, esk)) - body - validateV6PKESKRecipientIdentifier recipientKeyIdentifier - pure $ - PKESKPkt - (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier (toFVal pka) esk)) - where - validateV6PKESKRecipientIdentifier :: BL.ByteString -> Either String () - validateV6PKESKRecipientIdentifier rid = - case BL.length rid of - 0 -> Right () - 20 -> Right () - 32 -> Right () - 21 -> validateVersionedFingerprint rid - 33 -> validateVersionedFingerprint rid - ridLen -> - Left - ("invalid PKESK v6 recipient identifier length: " ++ - show ridLen ++ - " (expected 0, 20, 21, 32, or 33)") - - validateVersionedFingerprint :: BL.ByteString -> Either String () - validateVersionedFingerprint rid = - let keyVersion = BL.head rid - fingerprintLen = BL.length (BL.tail rid) - in case keyVersion of - 4 -> - if fingerprintLen == 20 - then Right () - else - Left - ("PKESK v6 recipient identifier length/version mismatch: key version 4 requires fingerprint length 20, got " ++ - show fingerprintLen) - 6 -> - if fingerprintLen == 32 - then Right () - else - Left - ("PKESK v6 recipient identifier length/version mismatch: key version 6 requires fingerprint length 32, got " ++ - show fingerprintLen) - _ -> - Left - ("invalid PKESK v6 recipient key version: " ++ - show keyVersion ++ " (expected 4 or 6)") - - getPkt' :: Word8 -> ByteOffset -> Get Pkt - getPkt' t len - | t == 1 = do - pv <- getWord8 - body <- getRemainingLazyByteString - if pv == 6 - then case parseV6PKESK body of - Right pkt -> return pkt - Left v6Err -> fail ("PKESK v6 parse failed: " ++ v6Err) - else case parseLegacyPKESK pv body of - Right pkt -> return pkt - Left legacyErr -> fail ("PKESK MPIs " ++ legacyErr) - | t == 2 = do - bs <- getRemainingLazyByteString - case runGetOrFail get bs of - Left (_, _, e) -> fail ("signature packet " ++ e) - Right (_, _, sp) -> return $ SignaturePkt sp - | t == 3 = do - pv <- getWord8 - let getV6SKESKParams = do - symalgoWord <- getWord8 - aeadWord <- getWord8 - s2kLen <- getWord8 - s2kBytes <- getLazyByteString (fromIntegral s2kLen) - s2k <- - case runGetOrFail getS2K s2kBytes of - Left (_, _, err) -> fail err - Right (rest, _, parsed) - | not (BL.null rest) -> fail "unexpected trailing bytes in v6 SKESK S2K specifier" - | otherwise -> pure parsed - let symalgo = toFVal symalgoWord - aead = toFVal aeadWord - ivLen = fromIntegral (aeadNonceSize aead) - iv <- getLazyByteString ivLen - pure (symalgo, aead, s2k, iv) - case pv of - 6 -> do - paramsLen <- getWord8 - params <- getLazyByteString (fromIntegral paramsLen) - (symalgo, aead, s2k, iv) <- - case runGetOrFail getV6SKESKParams params of - Left (_, _, err) -> fail err - Right (rest, _, parsed) - | not (BL.null rest) -> fail "unexpected trailing v6 SKESK parameters" - | otherwise -> pure parsed - payload <- getRemainingLazyByteString - when (BL.length payload < 16) $ - fail "v6 SKESK payload must include encrypted session key and authentication tag" - let (esk, tag) = BL.splitAt (BL.length payload - 16) payload - return $ - SKESKPkt - (SKESKPayloadV6Packet - (SKESKPayloadV6 - symalgo - aead - s2k - iv - esk - tag)) - 4 -> do - symalgo <- getWord8 - s2k <- getS2K - esk <- getRemainingLazyByteString - let mesk = if BL.null esk then Nothing else Just esk - validateV4SKESKEncryptedSessionKeyS2K s2k mesk - return $ - SKESKPkt - (SKESKPayloadV4Packet - (SKESKPayloadV4 - (toFVal symalgo) - s2k - mesk)) - _ -> fail ("unsupported SKESK packet version " ++ show pv) - | t == 4 = do - pv <- getWord8 - sigtype <- toFVal <$> getWord8 - ha <- toFVal <$> getWord8 - pka <- toFVal <$> getWord8 - case pv of - 3 -> do - skeyid <- getLazyByteString 8 - nested <- getWord8 >>= parseOPSNestedFlag - return $ - OnePassSignaturePkt - (OPSPayloadV3Packet - (OPSPayloadV3 - pv - sigtype - ha - pka - (EightOctetKeyId skeyid) - nested)) - 6 -> do - saltSize <- getWord8 - expectedSaltSize <- - maybe - (fail ("signature hash algorithm does not define a V6 salt size: " ++ show ha)) - pure - (v6SaltSizeForHashAlgorithm ha) - when (saltSize /= expectedSaltSize) $ - fail - ("OPS v6 salt size mismatch for " ++ - show ha ++ ": expected " ++ show expectedSaltSize ++ ", got " ++ show saltSize) - salt <- SignatureSalt <$> getLazyByteString (fromIntegral saltSize) - signerFingerprint <- getLazyByteString 32 - nested <- getWord8 >>= parseOPSNestedFlag - return $ - OnePassSignaturePkt - (OPSPayloadV6Packet - (OPSPayloadV6 - sigtype - ha - pka - salt - signerFingerprint - nested)) - _ -> fail ("Unsupported OPS version: " ++ show pv) - | t == 5 = do - bs <- getLazyByteString len - let ps = - flip runGetOrFail bs $ do - pkp <- getPKPayload - ska <- getSKAddendum pkp - return $ SecretKeyPkt pkp ska - case ps of - Left (_, _, err) -> fail ("secret key " ++ err) - Right (_, _, pkt) -> return pkt - | t == 6 = do - pkp <- getPKPayload - return $ PublicKeyPkt pkp - | t == 7 = do - bs <- getLazyByteString len - let ps = - flip runGetOrFail bs $ do - pkp <- getPKPayload - ska <- getSKAddendum pkp - return $ SecretSubkeyPkt pkp ska - case ps of - Left (_, _, err) -> fail ("secret subkey " ++ err) - Right (_, _, pkt) -> return pkt - | t == 8 = do - ca <- getWord8 - cdata <- getLazyByteString (len - 1) - return $ CompressedDataPkt (toFVal ca) cdata - | t == 9 = do - sdata <- getLazyByteString len - return $ SymEncDataPkt sdata - | t == 10 = do - marker <- getLazyByteString len - return $ MarkerPkt marker - | t == 11 = do - dt <- getWord8 - flen <- getWord8 - fn <- getLazyByteString (fromIntegral flen) - ts <- fmap ThirtyTwoBitTimeStamp getWord32be - ldata <- getLazyByteString (len - (6 + fromIntegral flen)) - return $ LiteralDataPkt (toFVal dt) fn ts ldata - | t == 12 = do - tdata <- getLazyByteString len - return $ TrustPkt tdata - | t == 13 = do - udata <- getByteString (fromIntegral len) - return . UserIdPkt . decodeUtf8With lenientDecode $ udata - | t == 14 = do - bs <- getLazyByteString len - let ps = - flip runGetOrFail bs $ do - pkp <- getPKPayload - return $ PublicSubkeyPkt pkp - case ps of - Left (_, _, err) -> fail ("public subkey " ++ err) - Right (_, _, pkt) -> return pkt - | t == 17 = do - bs <- getLazyByteString len - case runGetOrFail (many getUserAttrSubPacket) bs of - Left (_, _, err) -> fail ("user attribute " ++ err) - Right (_, _, uas) -> return $ UserAttributePkt uas - | t == 18 = do - pv <- getWord8 - case pv of - 1 -> do - b <- getLazyByteString (len - 1) - return $ SymEncIntegrityProtectedDataPkt (SEIPD1 pv b) - 2 -> do - when (len < 36) $ - fail "SEIPD v2 packet too short" - symalgo <- toFVal <$> getWord8 - aeadalgo <- toFVal <$> getWord8 - chunkSize <- getWord8 - salt <- Salt <$> getByteString 32 - encrypted <- getLazyByteString (len - 36) - validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted - return $ - SymEncIntegrityProtectedDataPkt - (SEIPD2 - symalgo - aeadalgo - chunkSize - salt - encrypted) - _ -> fail ("Unsupported SEIPD version: " ++ show pv) - | t == 19 = do - hash <- getLazyByteString 20 - return $ ModificationDetectionCodePkt hash - | otherwise = do - payload <- getLazyByteString len - return $ OtherPacketPkt t payload - -getUserAttrSubPacket :: Get UserAttrSubPacket -getUserAttrSubPacket = do - l <- fmap fromIntegral getSubPacketLength - t <- getWord8 - getUserAttrSubPacket' t l - where - getUserAttrSubPacket' :: Word8 -> ByteOffset -> Get UserAttrSubPacket - getUserAttrSubPacket' t l - | t == 1 = do - _ <- getWord16le -- ihlen - hver <- getWord8 -- should be 1 - iformat <- getWord8 - nuls <- getLazyByteString 12 -- should be NULs - bs <- getLazyByteString (l - 17) - if hver /= 1 || nuls /= BL.pack (replicate 12 0) - then fail "Corrupt UAt subpacket" - else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs - | otherwise = do - bs <- getLazyByteString (l - 1) - return $ OtherUASub t bs - -putUserAttrSubPacket :: UserAttrSubPacket -> Put -putUserAttrSubPacket ua = do - let sp = runPut $ putUserAttrSubPacket' ua - putSubPacketLength . fromIntegral . BL.length $ sp - putLazyByteString sp - where - putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do - putWord8 1 - putWord16le 16 - putWord8 1 - putWord8 (fromFVal iformat) - replicateM_ 12 $ putWord8 0 - putLazyByteString idata - putUserAttrSubPacket' (OtherUASub t bs) = do - putWord8 t - putLazyByteString bs - --- | Serialize PKESKv3 session-key material. --- For ECDH and X25519 the RFC 6637 §8 / RFC 9580 §5.1.6 wire format is used: --- MPI(ephemeral_key) || 1-octet-count || wrapped_session_key_bytes. --- All other algorithms use the standard MPI sequence. -putPKESKv3SessionKeyMaterial :: PubKeyAlgorithm -> NE.NonEmpty MPI -> Put -putPKESKv3SessionKeyMaterial pka mpis - | pka `elem` [ECDH, X25519] - , (ephMPI NE.:| [wrappedMPI]) <- mpis = do - put ephMPI - let rawWrapped = i2osp (unMPI wrappedMPI) - -- Left-pad to the nearest valid RFC 3394 wrapped-key length so that - -- leading-zero bytes stripped by i2osp are restored. - targetLen = headDef (B.length rawWrapped) (filter (>= B.length rawWrapped) [32, 40, 48]) - paddedWrapped = leftPadTo targetLen rawWrapped - putWord8 (fromIntegral (B.length paddedWrapped)) - putByteString paddedWrapped - | otherwise = F.mapM_ put mpis - where - headDef d [] = d - headDef _ (x:_) = x - -putPkt :: Pkt -> Put -putPkt (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eokeyid pka mpis))) = do - putWord8 (0xc0 .|. 1) - let bsk = runPut $ putPKESKv3SessionKeyMaterial pka mpis - putPacketLength . fromIntegral $ 10 + BL.length bsk - putWord8 pv -- must be 3 - putLazyByteString (unEOKI eokeyid) -- must be 8 octets - putWord8 $ fromIntegral . fromFVal $ pka - putLazyByteString bsk -putPkt (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier pka esk))) = do - putWord8 (0xc0 .|. 1) - let keyIdentifierLen = BL.length recipientKeyIdentifier - when (keyIdentifierLen > 255) $ - error "PKESK v6 recipient key identifier must fit in one octet" - putPacketLength . fromIntegral $ 3 + keyIdentifierLen + BL.length esk - putWord8 6 - putWord8 (fromIntegral keyIdentifierLen) - putLazyByteString recipientKeyIdentifier - putWord8 $ fromIntegral . fromFVal $ pka - putLazyByteString esk -putPkt (SignaturePkt sp) = do - putWord8 (0xc0 .|. 2) - let bs = runPut $ put sp - putLengthThenPayload bs -putPkt (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 symalgo s2k mesk))) = do - putWord8 (0xc0 .|. 3) - let bs2k = fromS2K s2k - let bsk = fromMaybe BL.empty mesk - putPacketLength . fromIntegral $ 2 + BL.length bs2k + BL.length bsk - putWord8 4 - putWord8 $ fromIntegral . fromFVal $ symalgo - putLazyByteString bs2k - putLazyByteString bsk -putPkt (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 symalgo aead s2k iv esk tag))) = do - putWord8 (0xc0 .|. 3) - let bs2k = fromS2K s2k - let params = - BL.pack - [ fromIntegral (fromFVal symalgo) - , fromIntegral (fromFVal aead) - , fromIntegral (BL.length bs2k) - ] <> - bs2k <> iv - putPacketLength . fromIntegral $ 2 + BL.length params + BL.length esk + BL.length tag - putWord8 6 - putWord8 (fromIntegral (BL.length params)) - putLazyByteString params - putLazyByteString esk - putLazyByteString tag -putPkt (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 pv sigtype ha pka skeyid nested))) = do - putWord8 (0xc0 .|. 4) - let bs = - runPut $ do - putWord8 pv -- should be 3 - putWord8 $ fromIntegral . fromFVal $ sigtype - putWord8 $ fromIntegral . fromFVal $ ha - putWord8 $ fromIntegral . fromFVal $ pka - putLazyByteString (unEOKI skeyid) - putWord8 . fromIntegral . fromEnum $ not nested - putLengthThenPayload bs -putPkt (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 sigtype ha pka salt signerFingerprint nested))) = do - putWord8 (0xc0 .|. 4) - let saltBytes = unSignatureSalt salt - saltSize = BL.length saltBytes - expectedSaltSize = - maybe - (error ("signature hash algorithm does not define a V6 salt size: " ++ show ha)) - id - (v6SaltSizeForHashAlgorithm ha) - when (fromIntegral saltSize /= expectedSaltSize) $ - error - ("OPS v6 salt size mismatch for " ++ - show ha ++ ": expected " ++ show expectedSaltSize ++ ", got " ++ show saltSize) - when (BL.length signerFingerprint /= 32) $ - error "OPS v6 signer fingerprint must be exactly 32 octets" - let bs = - runPut $ do - putWord8 6 - putWord8 $ fromIntegral . fromFVal $ sigtype - putWord8 $ fromIntegral . fromFVal $ ha - putWord8 $ fromIntegral . fromFVal $ pka - putWord8 (fromIntegral saltSize) - putLazyByteString saltBytes - putLazyByteString signerFingerprint - putWord8 . fromIntegral . fromEnum $ not nested - putLengthThenPayload bs -putPkt (SecretKeyPkt pkp ska) = do - putWord8 (0xc0 .|. 5) - let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska) - putLengthThenPayload bs -putPkt (PublicKeyPkt pkp) = do - putWord8 (0xc0 .|. 6) - let bs = runPut $ putPKPayload pkp - putLengthThenPayload bs -putPkt (SecretSubkeyPkt pkp ska) = do - putWord8 (0xc0 .|. 7) - let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska) - putLengthThenPayload bs -putPkt (CompressedDataPkt ca cdata) = do - putWord8 (0xc0 .|. 8) - let bs = - runPut $ do - putWord8 $ fromIntegral . fromFVal $ ca - putLazyByteString cdata - putLengthThenPayload bs -putPkt (SymEncDataPkt b) = do - putWord8 (0xc0 .|. 9) - putLengthThenPayload b -putPkt (MarkerPkt b) = do - putWord8 (0xc0 .|. 10) - putLengthThenPayload b -putPkt (LiteralDataPkt dt fn ts b) = do - putWord8 (0xc0 .|. 11) - let bs = - runPut $ do - putWord8 $ fromIntegral . fromFVal $ dt - putWord8 $ fromIntegral . BL.length $ fn - putLazyByteString fn - putWord32be . unThirtyTwoBitTimeStamp $ ts - putLazyByteString b - putLengthThenPayload bs -putPkt (TrustPkt b) = do - putWord8 (0xc0 .|. 12) - putLengthThenPayload b -putPkt (UserIdPkt u) = do - putWord8 (0xc0 .|. 13) - let bs = encodeUtf8 u - putPacketLength . fromIntegral $ B.length bs - putByteString bs -putPkt (PublicSubkeyPkt pkp) = do - putWord8 (0xc0 .|. 14) - let bs = runPut $ putPKPayload pkp - putLengthThenPayload bs -putPkt (UserAttributePkt us) = do - putWord8 (0xc0 .|. 17) - let bs = runPut $ mapM_ put us - putLengthThenPayload bs -putPkt (SymEncIntegrityProtectedDataPkt (SEIPD1 pv b)) = do - putWord8 (0xc0 .|. 18) - putPacketLength . fromIntegral $ BL.length b + 1 - putWord8 pv -- should be 1 - putLazyByteString b -putPkt (SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aeadalgo chunkSize salt b)) = do - when (B.length (unSalt salt) /= 32) $ - error "SEIPD v2 salt must be exactly 32 octets" - when (chunkSize > 16) $ - error "SEIPD v2 chunk size octet must be between 0 and 16" - case symalgo of - OtherSA _ -> error "SEIPD v2 requires a known symmetric algorithm" - Plaintext -> error "SEIPD v2 cannot use plaintext cipher" - _ -> return () - case aeadalgo of - OtherAEADAlgo _ -> error "SEIPD v2 requires a known AEAD algorithm" - _ -> return () - putWord8 (0xc0 .|. 18) - putPacketLength . fromIntegral $ BL.length b + 36 - putWord8 2 - putWord8 (fromFVal symalgo) - putWord8 (fromFVal aeadalgo) - putWord8 chunkSize - putByteString (unSalt salt) - putLazyByteString b -putPkt (ModificationDetectionCodePkt hash) = do - putWord8 (0xc0 .|. 19) - putLengthThenPayload hash -putPkt (OtherPacketPkt t payload) = do - when (t > 63) $ - error ("cannot serialize OtherPacket packet tag > 63: " ++ show t) - putWord8 (0xc0 .|. t) - putLengthThenPayload payload -putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload) - --- | Validate a packet before serialization to catch constraint violations early. --- Returns Left with descriptive error if validation fails. -validatePkt :: Pkt -> Either String () -validatePkt (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier _ _))) = do - let keyIdentifierLen = BL.length recipientKeyIdentifier - when (keyIdentifierLen > 255) $ - Left "PKESK v6 recipient key identifier must fit in one octet (max 255 bytes)" - Right () -validatePkt (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 _ ha _ salt signerFingerprint _))) = do - let saltBytes = unSignatureSalt salt - saltSize = BL.length saltBytes - expectedSaltSize <- - case v6SaltSizeForHashAlgorithm ha of - Nothing -> Left $ "signature hash algorithm does not define a V6 salt size: " ++ show ha - Just sz -> Right sz - when (fromIntegral saltSize /= expectedSaltSize) $ - Left - ("OPS v6 salt size mismatch for " ++ - show ha ++ ": expected " ++ show expectedSaltSize ++ ", got " ++ show saltSize) - when (BL.length signerFingerprint /= 32) $ - Left "OPS v6 signer fingerprint must be exactly 32 octets" - Right () -validatePkt (SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aeadalgo chunkSize salt _)) = do - when (B.length (unSalt salt) /= 32) $ - Left "SEIPD v2 salt must be exactly 32 octets" - when (chunkSize > 16) $ - Left "SEIPD v2 chunk size octet must be between 0 and 16" - case symalgo of - OtherSA _ -> Left "SEIPD v2 requires a known symmetric algorithm" - Plaintext -> Left "SEIPD v2 cannot use plaintext cipher" - _ -> Right () - case aeadalgo of - OtherAEADAlgo _ -> Left "SEIPD v2 requires a known AEAD algorithm" - _ -> Right () -validatePkt (OtherPacketPkt t _) = do - when (t > 63) $ - Left ("cannot serialize OtherPacket packet tag > 63: " ++ show t) - Right () -validatePkt _ = Right () - --- | Serialize a packet with explicit validation and error handling. --- Validates constraints before calling putPkt to ensure errors are caught early. -putPktEither :: Pkt -> Either String Put -putPktEither pkt = case validatePkt pkt of - Left err -> Left err - Right () -> Right (putPkt pkt) - -putLengthThenPayload :: ByteString -> Put -putLengthThenPayload bs = do - let len = BL.length bs - if len < fromIntegral (0x100000000 :: Integer) - then do - putPacketLength (fromIntegral len) - putLazyByteString bs - else putPartialLengthPayload bs - where - maxPartialChunkSize :: Int64 - maxPartialChunkSize = 1 `shiftL` (30 :: Int) - putPartialLengthPayload :: ByteString -> Put - putPartialLengthPayload payload - | BL.length payload > maxPartialChunkSize = do - let (chunk, rest) = BL.splitAt maxPartialChunkSize payload - putPartialLength 30 - putLazyByteString chunk - putPartialLengthPayload rest - | otherwise = do - putPacketLength (fromIntegral (BL.length payload)) - putLazyByteString payload - -validateSEIPDv2Header :: - SymmetricAlgorithm -> AEADAlgorithm -> Word8 -> ByteString -> Get () -validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted = do - when (chunkSize > 16) $ - fail "SEIPD v2 chunk size octet must be between 0 and 16" - when (BL.null encrypted) $ - fail "SEIPD v2 payload is missing encrypted data and final authentication tag" - case symalgo of - OtherSA _ -> fail "SEIPD v2 requires a known symmetric algorithm" - Plaintext -> fail "SEIPD v2 cannot use plaintext cipher" - _ -> return () - case aeadalgo of - OtherAEADAlgo _ -> fail "SEIPD v2 requires a known AEAD algorithm" - _ -> return () - -getMPI :: Get MPI -getMPI = do - mpilen <- getWord16be - bs <- getByteString (fromIntegral (mpilen + 7) `div` 8) - return $ MPI (os2ip bs) - -getPubkey :: PubKeyAlgorithm -> Get PKey -getPubkey RSA = do - MPI n <- get - MPI e <- get - return $ - RSAPubKey - (RSA_PublicKey (R.PublicKey (fromIntegral . B.length . i2osp $ n) n e)) -getPubkey DeprecatedRSAEncryptOnly = getPubkey RSA -getPubkey DeprecatedRSASignOnly = getPubkey RSA -getPubkey DSA = do - MPI p <- get - MPI q <- get - MPI g <- get - MPI y <- get - return $ DSAPubKey (DSA_PublicKey (D.PublicKey (D.Params p g q) y)) -getPubkey ElgamalEncryptOnly = getPubkey ForbiddenElgamal -getPubkey ForbiddenElgamal = do - MPI p <- get - MPI g <- get - MPI y <- get - return $ ElGamalPubKey p g y -getPubkey ECDSA = do - curvelength <- getWord8 - when (curvelength == 0 || curvelength == 0xff) $ - fail "invalid ECC curve OID length octet (reserved value)" - curveoid <- getByteString (fromIntegral curvelength) - MPI mpi <- getMPI - case curveoidBSToCurve curveoid of - Left e -> fail e - Right Curve25519 -> - EdDSAPubKey P.Ed25519 <$> (PrefixedNativeEPoint <$> validatePrefixedNativePoint 32 "Curve25519Legacy" mpi) - Right curve -> - case bs2Point (i2osp mpi) of - Left e -> fail e - Right point -> - return . ECDSAPubKey . ECDSA_PublicKey . - ECDSA.PublicKey (curve2Curve curve) $ - point -getPubkey ECDH = do - ed <- getPubkey ECDSA -- could be an ECDSA or an EdDSA - kdflen <- getWord8 - when (kdflen == 0 || kdflen == 0xff) $ - fail "invalid ECDH KDF field length octet (reserved value)" - when (kdflen /= 3) $ - fail ("invalid ECDH KDF field length: " ++ show kdflen) - one <- getWord8 - when (one /= 1) $ - fail ("invalid ECDH KDF reserved octet: " ++ show one) - kdfHA <- get - kdfSA <- get - return $ ECDHPubKey ed kdfHA kdfSA -getPubkey EdDSA = do - curvelength <- getWord8 - when (curvelength == 0 || curvelength == 0xff) $ - fail "invalid EdDSA curve OID length octet (reserved value)" - curveoid <- getByteString (fromIntegral curvelength) - MPI mpi <- getMPI - case curveoidBSToEdSigningCurve curveoid of - Left e -> fail e - Right P.Ed25519 -> - EdDSAPubKey P.Ed25519 <$> (PrefixedNativeEPoint <$> validatePrefixedNativePoint 32 "Ed25519Legacy" mpi) - Right P.Ed448 -> - EdDSAPubKey P.Ed448 <$> (PrefixedNativeEPoint <$> validatePrefixedNativePoint 57 "Ed448Legacy" mpi) -getPubkey pka | pka == BTypes.Ed25519 = - parseFixedLengthOrLegacyPubkey - 32 - (EdDSAPubKey P.Ed25519 . NativeEPoint . EPoint . os2ip . BL.toStrict) - (getPubkey EdDSA) -getPubkey pka | pka == BTypes.Ed448 = - parseFixedLengthOrLegacyPubkey - 57 - (EdDSAPubKey P.Ed448 . NativeEPoint . EPoint . os2ip . BL.toStrict) - (getPubkey EdDSA) -getPubkey X25519 = - parseFixedLengthOrLegacyPubkey - 32 - (EdDSAPubKey P.Ed25519 . NativeEPoint . EPoint . os2ip . BL.toStrict) - (getPubkey ECDH) -getPubkey X448 = - parseFixedLengthOrLegacyPubkey - 56 - (EdDSAPubKey P.Ed448 . NativeEPoint . EPoint . os2ip . BL.toStrict) - (getPubkey ECDH) -getPubkey _ = UnknownPKey <$> getRemainingLazyByteString - -parseFixedLengthOrLegacyPubkey :: Int64 -> (BL.ByteString -> PKey) -> Get PKey -> Get PKey -parseFixedLengthOrLegacyPubkey expectedLen decodeFixed legacyParser = do - remaining <- lookAhead getRemainingLazyByteString - if BL.length remaining == expectedLen - then decodeFixed <$> getLazyByteString expectedLen - else legacyParser - -getPubkeyV6 :: PubKeyAlgorithm -> Get PKey -getPubkeyV6 pka - | pka == BTypes.Ed25519 = do - len <- getWord32be - bs <- getByteString (fromIntegral len) - when (B.length bs /= 32) $ - fail "invalid v6 Ed25519 public key length" - return $ EdDSAPubKey P.Ed25519 (NativeEPoint (EPoint (os2ip bs))) - | pka == BTypes.Ed448 = do - len <- getWord32be - bs <- getByteString (fromIntegral len) - when (B.length bs /= 57) $ - fail "invalid v6 Ed448 public key length" - return $ EdDSAPubKey P.Ed448 (NativeEPoint (EPoint (os2ip bs))) - | pka == BTypes.X25519 = do - len <- getWord32be - bs <- getByteString (fromIntegral len) - when (B.length bs /= 32) $ - fail "invalid v6 X25519 public key length" - return $ EdDSAPubKey P.Ed25519 (NativeEPoint (EPoint (os2ip bs))) - | pka == BTypes.X448 = do - len <- getWord32be - bs <- getByteString (fromIntegral len) - when (B.length bs /= 56) $ - fail "invalid v6 X448 public key length" - return $ EdDSAPubKey P.Ed448 (NativeEPoint (EPoint (os2ip bs))) - | otherwise = getPubkey pka - -bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint -bs2Point bs = - if B.null bs - then Left "empty EC point encoding" - else - let xy = B.drop 1 bs - l = B.length xy - in if B.head bs /= 0x04 - then Left $ "unknown type of point: " ++ show (B.unpack bs) - else if odd l - then Left "malformed EC point encoding: odd coordinate payload length" - else - return - (uncurry - ECCT.Point - ((os2ip *** os2ip) (B.splitAt (div l 2) xy))) - -putPubkey :: PKey -> Put -putPubkey (UnknownPKey bs) = putLazyByteString bs -putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) = - let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) - in putCurveOID curveoidbs >> - mapM_ put (pubkeyToMPIs p) -putPubkey p@(ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) kha ksa) = - let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) - in putCurveOID curveoidbs >> - mapM_ put (pubkeyToMPIs p) >> - putECDHKDFParams kha ksa -putPubkey p@(ECDHPubKey (EdDSAPubKey curve (PrefixedNativeEPoint _)) kha ksa) = - let Right curveoidbs = curveToCurveoidBS (ed2ec curve) - in putCurveOID curveoidbs >> - mapM_ put (pubkeyToMPIs p) >> - putECDHKDFParams kha ksa - where - ed2ec P.Ed25519 = Curve25519 - ed2ec P.Ed448 = Curve448 -putPubkey p@(EdDSAPubKey curve (PrefixedNativeEPoint _)) = - let Right curveoidbs = edSigningCurveToCurveoidBS curve - in putCurveOID curveoidbs >> - mapM_ put (pubkeyToMPIs p) -putPubkey (ECDHPubKey (EdDSAPubKey curve (NativeEPoint _)) _ _) = - error ("legacy ECDH serialization requires a prefixed-native " ++ show curve ++ " point") -putPubkey (EdDSAPubKey curve (NativeEPoint _)) = - error ("legacy EdDSA serialization requires a prefixed-native " ++ show curve ++ " point") -putPubkey p = mapM_ put (pubkeyToMPIs p) - -putPubkeyV6 :: PKey -> Put -putPubkeyV6 (EdDSAPubKey P.Ed25519 (NativeEPoint (EPoint x))) = do - let bs = fixedLengthOctets 32 x - putWord32be . fromIntegral . B.length $ bs - putByteString bs -putPubkeyV6 (EdDSAPubKey P.Ed448 (NativeEPoint (EPoint x))) = do - let bs = fixedLengthOctets 57 x - putWord32be . fromIntegral . B.length $ bs - putByteString bs -putPubkeyV6 (ECDHPubKey (EdDSAPubKey P.Ed25519 (NativeEPoint (EPoint x))) kha ksa) = do - let bs = fixedLengthOctets 32 x - putWord32be . fromIntegral . B.length $ bs - putByteString bs - put kha - put ksa -putPubkeyV6 (ECDHPubKey (EdDSAPubKey P.Ed448 (NativeEPoint (EPoint x))) kha ksa) = do - let bs = fixedLengthOctets 56 x - putWord32be . fromIntegral . B.length $ bs - putByteString bs - put kha - put ksa -putPubkeyV6 p = putPubkey p - -fixedLengthOctets :: Int -> Integer -> B.ByteString -fixedLengthOctets targetLen x = - let bs = i2osp x - in if B.length bs > targetLen - then error ("public key element does not fit in " ++ show targetLen ++ " octets") - else B.replicate (targetLen - B.length bs) 0 <> bs - -validatePrefixedNativePoint :: Int -> String -> Integer -> Get EPoint -validatePrefixedNativePoint targetLen label i = - let bs = i2osp i - in if B.length bs /= targetLen + 1 - then - fail - ("invalid " ++ label ++ " public key length: expected " ++ - show (targetLen + 1) ++ " octets with 0x40 prefix, got " ++ show (B.length bs)) - else - if B.head bs /= 0x40 - then fail ("invalid " ++ label ++ " public key: missing 0x40 prefix") - else pure (EPoint i) - -putCurveOID :: B.ByteString -> Put -putCurveOID oid = do - let oidLength = B.length oid - when (oidLength == 0 || oidLength == 0xff) $ - error "curve OID length cannot use reserved values 0 or 255" - putWord8 (fromIntegral oidLength) - putByteString oid - -putECDHKDFParams :: HashAlgorithm -> SymmetricAlgorithm -> Put -putECDHKDFParams kdfHA kdfSA = do - let kdfLengthOctet = 0x03 - when (kdfLengthOctet == 0 || kdfLengthOctet == 0xff) $ - error "ECDH KDF field length cannot use reserved values 0 or 255" - putWord8 kdfLengthOctet - putWord8 0x01 - put kdfHA - put kdfSA - -parseOPSNestedFlag :: Word8 -> Get NestedFlag -parseOPSNestedFlag 0 = pure True -parseOPSNestedFlag 1 = pure False -parseOPSNestedFlag other = - fail ("invalid OPS nested flag octet: " ++ show other) - -getSecretKey :: SomePKPayload -> Get SKey -getSecretKey pkp - | _pkalgo pkp `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do - MPI d <- get - MPI p <- get - MPI q <- get - MPI _ <- get -- u - case inverse q p of - Nothing -> fail "invalid RSA secret key: q has no inverse modulo p" - Just qinv -> do - let dP = d `mod` (p - 1) - dQ = d `mod` (q - 1) - pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (_pubkey pkp) - return $ RSAPrivateKey (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv)) - | _pkalgo pkp == DSA = do - MPI x <- get - return $ DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x)) - | _pkalgo pkp `elem` [ElgamalEncryptOnly, ForbiddenElgamal] = do - MPI x <- get - return $ ElGamalPrivateKey x - | _pkalgo pkp == ECDSA = do - let pubcurve = - (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p) - (_pubkey pkp) - getECDSAScalarPrivateKey pubcurve - | _pkalgo pkp == ECDH - = do - pubcurve <- ecdhPrivateCurveFromPKPayload pkp - getECDHScalarPrivateKey pubcurve - | _pkalgo pkp == X25519 = do - if _keyVersion pkp == V6 - then do - sk <- getByteString 32 - return $ X25519PrivateKey sk - else do - pubcurve <- ecdhPrivateCurveFromPKPayload pkp - getECDHScalarPrivateKey pubcurve - | _pkalgo pkp == X448 = do - if _keyVersion pkp == V6 - then do - sk <- getByteString 56 - return $ X448PrivateKey sk - else UnknownSKey <$> getRemainingLazyByteString - | _pkalgo pkp == EdDSA = do - if _keyVersion pkp == V6 - then do - case _pubkey pkp of - EdDSAPubKey P.Ed25519 _ -> EdDSAPrivateKey P.Ed25519 <$> getByteString 32 - EdDSAPubKey P.Ed448 _ -> EdDSAPrivateKey P.Ed448 <$> getByteString 57 - _ -> UnknownSKey <$> getRemainingLazyByteString - else do - MPI x <- get - case _pubkey pkp of - EdDSAPubKey P.Ed25519 _ -> - return $ EdDSAPrivateKey P.Ed25519 (leftPadTo 32 (i2osp x)) - EdDSAPubKey P.Ed448 _ -> - return $ EdDSAPrivateKey P.Ed448 (leftPadTo 57 (i2osp x)) - _ -> return $ UnknownSKey (BL.fromStrict (i2osp x)) - | otherwise = UnknownSKey <$> getRemainingLazyByteString - -getECDSAScalarPrivateKey :: ECCT.Curve -> Get SKey -getECDSAScalarPrivateKey curve = do - MPI pn <- get - pure $ ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn)) - -getECDHScalarPrivateKey :: ECCT.Curve -> Get SKey -getECDHScalarPrivateKey curve = do - MPI pn <- get - pure $ ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn)) - -ecdhPrivateCurveFromPKPayload :: SomePKPayload -> Get ECCT.Curve -ecdhPrivateCurveFromPKPayload pkp = - case _pubkey pkp of - ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey p)) _ _ -> - pure (ECDSA.public_curve p) - ECDHPubKey (EdDSAPubKey P.Ed25519 _) _ _ -> - pure (curve2Curve Curve25519) - ECDHPubKey (EdDSAPubKey P.Ed448 _) _ _ -> - pure (curve2Curve Curve448) - other -> - fail - ("ECDH/X25519 secret key requires an ECDH public key packet, got " ++ - show other) - -putSKey :: SKey -> Either String Put -putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) = - case inverse q p of - Just u -> - Right (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)) - Nothing -> - Left - "putSKey: invalid RSA key — q has no multiplicative inverse mod p (key is mathematically broken)" -putSKey (DSAPrivateKey (DSA_PrivateKey (D.PrivateKey _ x))) = - Right (put (MPI x)) -putSKey (ElGamalPrivateKey x) = - Right (put (MPI x)) -putSKey (ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) = - Right (put (MPI d)) -putSKey (ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) = - Right (put (MPI d)) -putSKey (EdDSAPrivateKey P.Ed25519 sk) = Right (putByteString sk) -putSKey (EdDSAPrivateKey P.Ed448 sk) = Right (putByteString sk) -putSKey (X25519PrivateKey sk) = Right (putByteString sk) -putSKey (X448PrivateKey sk) = Right (putByteString sk) -putSKey (UnknownSKey bs) = Right (putLazyByteString bs) - -putSKeyForPKPayload :: SomePKPayload -> SKey -> Either String Put -putSKeyForPKPayload pkp sk@(EdDSAPrivateKey _ bs) - | _keyVersion pkp == V6 = putSKey sk - | otherwise = Right (put (MPI (os2ip bs))) -putSKeyForPKPayload _ sk = putSKey sk - -putMPI :: MPI -> Put -putMPI (MPI i) = do - let bs = i2osp i - putWord16be . fromIntegral . numBits $ i - putByteString bs - -data PKPayloadReadCase where - PKPayloadReadCaseV3 :: V3Expiration -> PubKeyAlgorithm -> PKPayloadReadCase - PKPayloadReadCaseV4 :: PubKeyAlgorithm -> PKPayloadReadCase - PKPayloadReadCaseV6 :: PubKeyAlgorithm -> PKPayloadReadCase - -pkPayloadReadCase :: Word8 -> Get PKPayloadReadCase -pkPayloadReadCase version = - case version of - 2 -> do - v3e <- getWord16be - pka <- get - pure (PKPayloadReadCaseV3 v3e pka) - 3 -> do - v3e <- getWord16be - pka <- get - pure (PKPayloadReadCaseV3 v3e pka) - 4 -> PKPayloadReadCaseV4 <$> get - 6 -> PKPayloadReadCaseV6 <$> get - _ -> fail ("unsupported key packet version " ++ show version) - -getPKPayload :: Get SomePKPayload -getPKPayload = do - version <- getWord8 - ctime <- fmap ThirtyTwoBitTimeStamp getWord32be - readCase <- pkPayloadReadCase version - case readCase of - PKPayloadReadCaseV3 v3e pka -> do - pk <- getPubkey pka - pure $! PKPayload DeprecatedV3 ctime v3e pka pk - PKPayloadReadCaseV4 pka -> do - pk <- getPubkey pka - pure $! PKPayload V4 ctime 0 pka pk - PKPayloadReadCaseV6 pka -> do - pk <- getPubkeyV6 pka - pure $! PKPayload V6 ctime 0 pka pk - -data PKPayloadWriteCase where - PKPayloadWriteCaseV3 :: PKPayload 'DeprecatedV3 -> PKPayloadWriteCase - PKPayloadWriteCaseV4 :: PKPayload 'V4 -> PKPayloadWriteCase - PKPayloadWriteCaseV6 :: PKPayload 'V6 -> PKPayloadWriteCase - -pkPayloadWriteCase :: SomePKPayload -> PKPayloadWriteCase -pkPayloadWriteCase (SomePKPayload pkp) = - case pkp of - PKPayloadV3 {} -> PKPayloadWriteCaseV3 pkp - PKPayloadV4 {} -> PKPayloadWriteCaseV4 pkp - PKPayloadV6 {} -> PKPayloadWriteCaseV6 pkp - -putPKPayload :: SomePKPayload -> Put -putPKPayload pkpSome = - case pkPayloadWriteCase pkpSome of - PKPayloadWriteCaseV3 (PKPayloadV3 ctime v3e pka pk) -> do - putWord8 3 - putWord32be . unThirtyTwoBitTimeStamp $ ctime - putWord16be v3e - put pka - putPubkey pk - PKPayloadWriteCaseV4 (PKPayloadV4 ctime pka pk) -> do - putWord8 4 - putWord32be . unThirtyTwoBitTimeStamp $ ctime - put pka - putPubkeyV4ForAlgorithm pka pk - PKPayloadWriteCaseV6 (PKPayloadV6 ctime pka pk) -> do - putWord8 6 - putWord32be . unThirtyTwoBitTimeStamp $ ctime - put pka - putPubkeyV6 pk - -putPubkeyV4ForAlgorithm :: PubKeyAlgorithm -> PKey -> Put -putPubkeyV4ForAlgorithm pka pk - | pka == BTypes.Ed25519 = putPubkeyV4Fixed 32 P.Ed25519 pk - | pka == BTypes.Ed448 = putPubkeyV4Fixed 57 P.Ed448 pk - | pka == BTypes.X25519 = putPubkeyV4Fixed 32 P.Ed25519 pk - | pka == BTypes.X448 = putPubkeyV4Fixed 56 P.Ed448 pk - | otherwise = putPubkey pk - -putPubkeyV4Fixed :: Int -> P.EdSigningCurve -> PKey -> Put -putPubkeyV4Fixed targetLen expectedCurve (EdDSAPubKey curve (NativeEPoint (EPoint x))) - | curve == expectedCurve = putByteString (fixedLengthOctets targetLen x) -putPubkeyV4Fixed _ _ pk = putPubkey pk - -getSKAddendum :: SomePKPayload -> Get SKAddendum -getSKAddendum (SomePKPayload pkp) = - toSKAddendum <$> getSKAddendumTyped pkp - -getSKAddendumTyped :: PKPayload v -> Get (SKAddendumV v) -getSKAddendumTyped pkp = do - s2kusage <- getWord8 - let pkpSome = SomePKPayload pkp - getLegacyS2KProtected constructor = do - symencWord <- getWord8 - s2k <- getS2K - let symenc = toFVal symencWord - case s2k of - OtherS2K _ _ -> return $ constructor symenc s2k mempty BL.empty - _ -> do - blockSize <- either fail pure (symEncBlockSize symenc) - iv <- IV <$> getByteString blockSize - encryptedblock <- getRemainingLazyByteString - return $ constructor symenc s2k iv encryptedblock - case s2kusage of - 0 -> - case pkp of - PKPayloadV6 {} -> do - sk <- getSecretKey pkpSome - return (SKAUnencryptedV6 sk) - PKPayloadV3 {} -> do - rest <- lookAhead getRemainingLazyByteString - secretLen <- - case runGetOrFail - (do - start <- bytesRead - _ <- getSecretKey pkpSome - end <- bytesRead - pure (end - start)) - rest of - Left (_, _, err) -> fail err - Right (_, _, len) -> pure len - sk <- getSecretKey pkpSome - checksum <- getWord16be - let expectedChecksum = - checksum16Bytes (BL.toStrict (BL.take secretLen rest)) - when (checksum /= expectedChecksum) $ - fail - ("legacy unencrypted secret-key checksum mismatch: expected " ++ - show expectedChecksum ++ ", got " ++ show checksum) - return (SKAUnencryptedLegacy sk checksum) - PKPayloadV4 {} -> do - rest <- lookAhead getRemainingLazyByteString - secretLen <- - case runGetOrFail - (do - start <- bytesRead - _ <- getSecretKey pkpSome - end <- bytesRead - pure (end - start)) - rest of - Left (_, _, err) -> fail err - Right (_, _, len) -> pure len - sk <- getSecretKey pkpSome - checksum <- getWord16be - let expectedChecksum = - checksum16Bytes (BL.toStrict (BL.take secretLen rest)) - when (checksum /= expectedChecksum) $ - fail - ("legacy unencrypted secret-key checksum mismatch: expected " ++ - show expectedChecksum ++ ", got " ++ show checksum) - return (SKAUnencryptedLegacy sk checksum) - 255 -> - case pkp of - PKPayloadV6 {} -> - fail "v6 secret key packets MUST NOT use s2k usage 255" - PKPayloadV3 {} -> - getLegacyS2KProtected SKA16bit - PKPayloadV4 {} -> - getLegacyS2KProtected SKA16bit - 254 -> - case pkp of - PKPayloadV6 {} -> do - paramsLen <- getWord8 - params <- getLazyByteString (fromIntegral paramsLen) - (symenc, s2k, iv) <- - case runGetOrFail getV6CFBParams params of - Left (_, _, err) -> fail err - Right (rest, _, parsed) - | not (BL.null rest) -> fail "unexpected trailing v6 CFB parameters" - | otherwise -> pure parsed - encryptedblock <- getRemainingLazyByteString - return (SKASHA1V6 symenc s2k (IV iv) encryptedblock) - PKPayloadV3 {} -> - getLegacyS2KProtected SKASHA1Legacy - PKPayloadV4 {} -> - getLegacyS2KProtected SKASHA1Legacy - where - getV6CFBParams = do - symencWord <- getWord8 - s2kLen <- getWord8 - s2kBytes <- getLazyByteString (fromIntegral s2kLen) - s2k <- - case runGetOrFail getS2K s2kBytes of - Left (_, _, err) -> fail err - Right (rest, _, parsed) - | not (BL.null rest) -> fail "unexpected trailing bytes in v6 S2K specifier" - | otherwise -> pure parsed - iv <- getRemainingLazyByteString - let symenc = toFVal symencWord - blockSize <- either fail pure (symEncBlockSize symenc) - when (BL.length iv /= fromIntegral blockSize) $ - fail "invalid v6 CFB IV length" - pure (symenc, s2k, BL.toStrict iv) - 253 -> - case pkp of - PKPayloadV6 {} -> do - paramsLen <- getWord8 - params <- getLazyByteString (fromIntegral paramsLen) - (symenc, aead, s2k, iv) <- - case runGetOrFail getV6AEADParams params of - Left (_, _, err) -> fail err - Right (rest, _, parsed) - | not (BL.null rest) -> fail "unexpected trailing v6 AEAD parameters" - | otherwise -> pure parsed - encryptedblock <- getRemainingLazyByteString - return (SKAAEADV6 symenc aead s2k (IV iv) encryptedblock) - PKPayloadV3 {} -> do - (symenc, aead, s2k, iv) <- getLegacyAEADParams - encryptedblock <- getRemainingLazyByteString - return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock) - PKPayloadV4 {} -> do - (symenc, aead, s2k, iv) <- getLegacyAEADParams - encryptedblock <- getRemainingLazyByteString - return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock) - where - getV6AEADParams :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString) - getV6AEADParams = do - symencWord <- getWord8 - aeadWord <- getWord8 - s2kLen <- getWord8 - s2kBytes <- getLazyByteString (fromIntegral s2kLen) - s2k <- - case runGetOrFail getS2K s2kBytes of - Left (_, _, err) -> fail err - Right (rest, _, parsed) - | not (BL.null rest) -> fail "unexpected trailing bytes in v6 S2K specifier" - | otherwise -> pure parsed - iv <- getRemainingLazyByteString - let symenc = toFVal symencWord - aead = toFVal aeadWord - when (BL.length iv /= fromIntegral (aeadNonceSize aead)) $ - fail "invalid v6 AEAD IV length" - pure (symenc, aead, s2k, BL.toStrict iv) - -- v3/v4: no cumulative-params-length octet, no S2K-size octet - getLegacyAEADParams :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString) - getLegacyAEADParams = do - symencWord <- getWord8 - aeadWord <- getWord8 - s2k <- getS2K - let aead = toFVal aeadWord - iv <- BL.toStrict <$> getLazyByteString (fromIntegral (aeadNonceSize aead)) - pure (toFVal symencWord, aead, s2k, iv) - symenc -> - case pkp of - PKPayloadV6 {} -> do - paramsLen <- getWord8 - iv <- getByteString (fromIntegral paramsLen) - let symencAlg = toFVal symenc - blockSize <- either fail pure (symEncBlockSize symencAlg) - when (B.length iv /= blockSize) $ - fail "invalid v6 CFB IV length" - encryptedblock <- getRemainingLazyByteString - return (SKASymV6 symencAlg (IV iv) encryptedblock) - PKPayloadV3 {} -> do - blockSize <- either fail pure (symEncBlockSize (toFVal symenc)) - iv <- getByteString blockSize - encryptedblock <- getRemainingLazyByteString - return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock) - PKPayloadV4 {} -> do - blockSize <- either fail pure (symEncBlockSize (toFVal symenc)) - iv <- getByteString blockSize - encryptedblock <- getRemainingLazyByteString - return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock) - -putSKAddendum :: SKAddendum -> Either String Put -putSKAddendum (SUS16bit symenc s2k iv encryptedblock) = - Right $ do - putWord8 255 - put symenc - put s2k - putByteString (unIV iv) - putLazyByteString encryptedblock -putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = - Right $ do - putWord8 254 - put symenc - put s2k - putByteString (unIV iv) - putLazyByteString encryptedblock -putSKAddendum (SUSAEAD symenc aead s2k iv encryptedblock) = - Right $ do - putWord8 253 - put symenc - putWord8 (fromFVal aead) - put s2k - putByteString (unIV iv) - putLazyByteString encryptedblock -putSKAddendum (SUSym symenc iv encryptedblock) = - Right $ do - put symenc - putByteString (unIV iv) - putLazyByteString encryptedblock -putSKAddendum (SUUnencrypted sk checksum) = - do - putSecret <- putSKey sk - Right $ do - putWord8 0 - let skb = runPut putSecret - putLazyByteString skb - putWord16be - (if checksum == 0 - then checksum16Bytes (BL.toStrict skb) - else checksum) - -checksum16Bytes :: B.ByteString -> Word16 -checksum16Bytes = - B.foldl' - (\a b -> fromIntegral ((fromIntegral a + fromIntegral b) `mod` (65536 :: Integer))) - 0 - -putSKAddendumForPKPayload :: SomePKPayload -> SKAddendum -> Put -putSKAddendumForPKPayload pkp ska = - case fromSKAddendumForPKPayload pkp ska of - Left e -> error e - Right (SomeSKAddendumV skaV) -> - putSKAddendumForPKPayloadTyped pkp skaV - -putSKAddendumForPKPayloadTyped :: - SomePKPayload - -> SKAddendumV v - -> Put -putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedLegacy sk checksum) = do - putWord8 0 - let putSecret = - case putSKeyForPKPayload pkp sk of - Left err -> error err - Right p -> p - skb = runPut putSecret - putLazyByteString skb - putWord16be - (if checksum == 0 - then BL.foldl (\a b -> mod (a + fromIntegral b) 0xffff) (0 :: Word16) skb - else checksum) -putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedV6 sk) = do - putWord8 0 - let putSecret = - case putSKeyForPKPayload pkp sk of - Left err -> error err - Right p -> p - skb = runPut putSecret - putLazyByteString skb -putSKAddendumForPKPayloadTyped _ (SKASHA1V6 symenc s2k iv encryptedblock) = do - let s2kbs = runPut (put s2k) - paramsLen = 1 + 1 + BL.length s2kbs + fromIntegral (B.length (unIV iv)) - putWord8 254 - putWord8 (fromIntegral paramsLen) - put symenc - putWord8 (fromIntegral (BL.length s2kbs)) - putLazyByteString s2kbs - putByteString (unIV iv) - putLazyByteString encryptedblock -putSKAddendumForPKPayloadTyped _ (SKAAEADV6 symenc aead s2k iv encryptedblock) = do - let s2kbs = runPut (put s2k) - paramsLen = 1 + 1 + 1 + BL.length s2kbs + fromIntegral (B.length (unIV iv)) - putWord8 253 - putWord8 (fromIntegral paramsLen) - put symenc - putWord8 (fromFVal aead) - putWord8 (fromIntegral (BL.length s2kbs)) - putLazyByteString s2kbs - putByteString (unIV iv) - putLazyByteString encryptedblock -putSKAddendumForPKPayloadTyped _ (SKAAEADLegacy symenc aead s2k iv encryptedblock) = do - putWord8 253 - put symenc - putWord8 (fromFVal aead) - put s2k - putByteString (unIV iv) - putLazyByteString encryptedblock -putSKAddendumForPKPayloadTyped _ (SKASymV6 symenc iv encryptedblock) = do - putWord8 (fromFVal symenc) - putWord8 (fromIntegral (B.length (unIV iv))) - putByteString (unIV iv) - putLazyByteString encryptedblock -putSKAddendumForPKPayloadTyped _ skaV = - case putSKAddendum (toSKAddendum skaV) of - Left e -> error e - Right p -> p - -aeadNonceSize :: AEADAlgorithm -> Int -aeadNonceSize EAX = 16 -aeadNonceSize OCB = 15 -aeadNonceSize GCM = 12 -aeadNonceSize (OtherAEADAlgo _) = 0 - -symEncBlockSize :: SymmetricAlgorithm -> Either String Int -symEncBlockSize Plaintext = Right 0 -symEncBlockSize IDEA = Right 8 -symEncBlockSize TripleDES = Right 8 -symEncBlockSize CAST5 = Right 8 -symEncBlockSize Blowfish = Right 8 -symEncBlockSize AES128 = Right 16 -symEncBlockSize AES192 = Right 16 -symEncBlockSize AES256 = Right 16 -symEncBlockSize Twofish = Right 16 -symEncBlockSize Camellia128 = Right 16 -symEncBlockSize Camellia192 = Right 16 -symEncBlockSize Camellia256 = Right 16 -symEncBlockSize sa = - Left ("unsupported symmetric algorithm for secret-key IV sizing: " ++ show sa) - -decodeIterationCount :: Word8 -> IterationCount -decodeIterationCount c = - IterationCount - ((16 + (fromIntegral c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6)) - -encodeIterationCount :: IterationCount -> Word8 -- should this really be a lookup table? -encodeIterationCount 1024 = 0 -encodeIterationCount 1088 = 1 -encodeIterationCount 1152 = 2 -encodeIterationCount 1216 = 3 -encodeIterationCount 1280 = 4 -encodeIterationCount 1344 = 5 -encodeIterationCount 1408 = 6 -encodeIterationCount 1472 = 7 -encodeIterationCount 1536 = 8 -encodeIterationCount 1600 = 9 -encodeIterationCount 1664 = 10 -encodeIterationCount 1728 = 11 -encodeIterationCount 1792 = 12 -encodeIterationCount 1856 = 13 -encodeIterationCount 1920 = 14 -encodeIterationCount 1984 = 15 -encodeIterationCount 2048 = 16 -encodeIterationCount 2176 = 17 -encodeIterationCount 2304 = 18 -encodeIterationCount 2432 = 19 -encodeIterationCount 2560 = 20 -encodeIterationCount 2688 = 21 -encodeIterationCount 2816 = 22 -encodeIterationCount 2944 = 23 -encodeIterationCount 3072 = 24 -encodeIterationCount 3200 = 25 -encodeIterationCount 3328 = 26 -encodeIterationCount 3456 = 27 -encodeIterationCount 3584 = 28 -encodeIterationCount 3712 = 29 -encodeIterationCount 3840 = 30 -encodeIterationCount 3968 = 31 -encodeIterationCount 4096 = 32 -encodeIterationCount 4352 = 33 -encodeIterationCount 4608 = 34 -encodeIterationCount 4864 = 35 -encodeIterationCount 5120 = 36 -encodeIterationCount 5376 = 37 -encodeIterationCount 5632 = 38 -encodeIterationCount 5888 = 39 -encodeIterationCount 6144 = 40 -encodeIterationCount 6400 = 41 -encodeIterationCount 6656 = 42 -encodeIterationCount 6912 = 43 -encodeIterationCount 7168 = 44 -encodeIterationCount 7424 = 45 -encodeIterationCount 7680 = 46 -encodeIterationCount 7936 = 47 -encodeIterationCount 8192 = 48 -encodeIterationCount 8704 = 49 -encodeIterationCount 9216 = 50 -encodeIterationCount 9728 = 51 -encodeIterationCount 10240 = 52 -encodeIterationCount 10752 = 53 -encodeIterationCount 11264 = 54 -encodeIterationCount 11776 = 55 -encodeIterationCount 12288 = 56 -encodeIterationCount 12800 = 57 -encodeIterationCount 13312 = 58 -encodeIterationCount 13824 = 59 -encodeIterationCount 14336 = 60 -encodeIterationCount 14848 = 61 -encodeIterationCount 15360 = 62 -encodeIterationCount 15872 = 63 -encodeIterationCount 16384 = 64 -encodeIterationCount 17408 = 65 -encodeIterationCount 18432 = 66 -encodeIterationCount 19456 = 67 -encodeIterationCount 20480 = 68 -encodeIterationCount 21504 = 69 -encodeIterationCount 22528 = 70 -encodeIterationCount 23552 = 71 -encodeIterationCount 24576 = 72 -encodeIterationCount 25600 = 73 -encodeIterationCount 26624 = 74 -encodeIterationCount 27648 = 75 -encodeIterationCount 28672 = 76 -encodeIterationCount 29696 = 77 -encodeIterationCount 30720 = 78 -encodeIterationCount 31744 = 79 -encodeIterationCount 32768 = 80 -encodeIterationCount 34816 = 81 -encodeIterationCount 36864 = 82 -encodeIterationCount 38912 = 83 -encodeIterationCount 40960 = 84 -encodeIterationCount 43008 = 85 -encodeIterationCount 45056 = 86 -encodeIterationCount 47104 = 87 -encodeIterationCount 49152 = 88 -encodeIterationCount 51200 = 89 -encodeIterationCount 53248 = 90 -encodeIterationCount 55296 = 91 -encodeIterationCount 57344 = 92 -encodeIterationCount 59392 = 93 -encodeIterationCount 61440 = 94 -encodeIterationCount 63488 = 95 -encodeIterationCount 65536 = 96 -encodeIterationCount 69632 = 97 -encodeIterationCount 73728 = 98 -encodeIterationCount 77824 = 99 -encodeIterationCount 81920 = 100 -encodeIterationCount 86016 = 101 -encodeIterationCount 90112 = 102 -encodeIterationCount 94208 = 103 -encodeIterationCount 98304 = 104 -encodeIterationCount 102400 = 105 -encodeIterationCount 106496 = 106 -encodeIterationCount 110592 = 107 -encodeIterationCount 114688 = 108 -encodeIterationCount 118784 = 109 -encodeIterationCount 122880 = 110 -encodeIterationCount 126976 = 111 -encodeIterationCount 131072 = 112 -encodeIterationCount 139264 = 113 -encodeIterationCount 147456 = 114 -encodeIterationCount 155648 = 115 -encodeIterationCount 163840 = 116 -encodeIterationCount 172032 = 117 -encodeIterationCount 180224 = 118 -encodeIterationCount 188416 = 119 -encodeIterationCount 196608 = 120 -encodeIterationCount 204800 = 121 -encodeIterationCount 212992 = 122 -encodeIterationCount 221184 = 123 -encodeIterationCount 229376 = 124 -encodeIterationCount 237568 = 125 -encodeIterationCount 245760 = 126 -encodeIterationCount 253952 = 127 -encodeIterationCount 262144 = 128 -encodeIterationCount 278528 = 129 -encodeIterationCount 294912 = 130 -encodeIterationCount 311296 = 131 -encodeIterationCount 327680 = 132 -encodeIterationCount 344064 = 133 -encodeIterationCount 360448 = 134 -encodeIterationCount 376832 = 135 -encodeIterationCount 393216 = 136 -encodeIterationCount 409600 = 137 -encodeIterationCount 425984 = 138 -encodeIterationCount 442368 = 139 -encodeIterationCount 458752 = 140 -encodeIterationCount 475136 = 141 -encodeIterationCount 491520 = 142 -encodeIterationCount 507904 = 143 -encodeIterationCount 524288 = 144 -encodeIterationCount 557056 = 145 -encodeIterationCount 589824 = 146 -encodeIterationCount 622592 = 147 -encodeIterationCount 655360 = 148 -encodeIterationCount 688128 = 149 -encodeIterationCount 720896 = 150 -encodeIterationCount 753664 = 151 -encodeIterationCount 786432 = 152 -encodeIterationCount 819200 = 153 -encodeIterationCount 851968 = 154 -encodeIterationCount 884736 = 155 -encodeIterationCount 917504 = 156 -encodeIterationCount 950272 = 157 -encodeIterationCount 983040 = 158 -encodeIterationCount 1015808 = 159 -encodeIterationCount 1048576 = 160 -encodeIterationCount 1114112 = 161 -encodeIterationCount 1179648 = 162 -encodeIterationCount 1245184 = 163 -encodeIterationCount 1310720 = 164 -encodeIterationCount 1376256 = 165 -encodeIterationCount 1441792 = 166 -encodeIterationCount 1507328 = 167 -encodeIterationCount 1572864 = 168 -encodeIterationCount 1638400 = 169 -encodeIterationCount 1703936 = 170 -encodeIterationCount 1769472 = 171 -encodeIterationCount 1835008 = 172 -encodeIterationCount 1900544 = 173 -encodeIterationCount 1966080 = 174 -encodeIterationCount 2031616 = 175 -encodeIterationCount 2097152 = 176 -encodeIterationCount 2228224 = 177 -encodeIterationCount 2359296 = 178 -encodeIterationCount 2490368 = 179 -encodeIterationCount 2621440 = 180 -encodeIterationCount 2752512 = 181 -encodeIterationCount 2883584 = 182 -encodeIterationCount 3014656 = 183 -encodeIterationCount 3145728 = 184 -encodeIterationCount 3276800 = 185 -encodeIterationCount 3407872 = 186 -encodeIterationCount 3538944 = 187 -encodeIterationCount 3670016 = 188 -encodeIterationCount 3801088 = 189 -encodeIterationCount 3932160 = 190 -encodeIterationCount 4063232 = 191 -encodeIterationCount 4194304 = 192 -encodeIterationCount 4456448 = 193 -encodeIterationCount 4718592 = 194 -encodeIterationCount 4980736 = 195 -encodeIterationCount 5242880 = 196 -encodeIterationCount 5505024 = 197 -encodeIterationCount 5767168 = 198 -encodeIterationCount 6029312 = 199 -encodeIterationCount 6291456 = 200 -encodeIterationCount 6553600 = 201 -encodeIterationCount 6815744 = 202 -encodeIterationCount 7077888 = 203 -encodeIterationCount 7340032 = 204 -encodeIterationCount 7602176 = 205 -encodeIterationCount 7864320 = 206 -encodeIterationCount 8126464 = 207 -encodeIterationCount 8388608 = 208 -encodeIterationCount 8912896 = 209 -encodeIterationCount 9437184 = 210 -encodeIterationCount 9961472 = 211 -encodeIterationCount 10485760 = 212 -encodeIterationCount 11010048 = 213 -encodeIterationCount 11534336 = 214 -encodeIterationCount 12058624 = 215 -encodeIterationCount 12582912 = 216 -encodeIterationCount 13107200 = 217 -encodeIterationCount 13631488 = 218 -encodeIterationCount 14155776 = 219 -encodeIterationCount 14680064 = 220 -encodeIterationCount 15204352 = 221 -encodeIterationCount 15728640 = 222 -encodeIterationCount 16252928 = 223 -encodeIterationCount 16777216 = 224 -encodeIterationCount 17825792 = 225 -encodeIterationCount 18874368 = 226 -encodeIterationCount 19922944 = 227 -encodeIterationCount 20971520 = 228 -encodeIterationCount 22020096 = 229 -encodeIterationCount 23068672 = 230 -encodeIterationCount 24117248 = 231 -encodeIterationCount 25165824 = 232 -encodeIterationCount 26214400 = 233 -encodeIterationCount 27262976 = 234 -encodeIterationCount 28311552 = 235 -encodeIterationCount 29360128 = 236 -encodeIterationCount 30408704 = 237 -encodeIterationCount 31457280 = 238 -encodeIterationCount 32505856 = 239 -encodeIterationCount 33554432 = 240 -encodeIterationCount 35651584 = 241 -encodeIterationCount 37748736 = 242 -encodeIterationCount 39845888 = 243 -encodeIterationCount 41943040 = 244 -encodeIterationCount 44040192 = 245 -encodeIterationCount 46137344 = 246 -encodeIterationCount 48234496 = 247 -encodeIterationCount 50331648 = 248 -encodeIterationCount 52428800 = 249 -encodeIterationCount 54525952 = 250 -encodeIterationCount 56623104 = 251 -encodeIterationCount 58720256 = 252 -encodeIterationCount 60817408 = 253 -encodeIterationCount 62914560 = 254 -encodeIterationCount 65011712 = 255 -encodeIterationCount n = error ("invalid iteration count" ++ show n) - -getSignaturePayload :: Get SignaturePayload -getSignaturePayload = do - pv <- getWord8 - case pv of - 3 -> do - hashlen <- getWord8 - guard (hashlen == 5) - st <- getWord8 - ctime <- fmap ThirtyTwoBitTimeStamp getWord32be - eok <- getLazyByteString 8 - pka <- get - ha <- get - left16 <- getWord16be - mpib <- getRemainingLazyByteString - case runGetOrFail (some getMPI) mpib of - Left (_, _, e) -> fail ("v3 sig MPIs " ++ e) - Right (_, _, mpis) -> - return $ - SigV3 - (toFVal st) - ctime - (EightOctetKeyId eok) - (toFVal pka) - (toFVal ha) - left16 - (NE.fromList mpis) - 4 -> do - st <- getWord8 - pkaOctet <- get - ha <- get - let pka = toFVal pkaOctet :: PubKeyAlgorithm - hlen <- getWord16be - hb <- getLazyByteString (fromIntegral hlen) - let hashed = - case runGetOrFail (many getSigSubPacket) hb of - Left (_, _, err) -> fail ("v4 sig hasheds " ++ err) - Right (_, _, h) -> h - ulen <- getWord16be - ub <- getLazyByteString (fromIntegral ulen) - let unhashed = - case runGetOrFail (many getSigSubPacket) ub of - Left (_, _, err) -> fail ("v4 sig unhasheds " ++ err) - Right (_, _, u) -> u - left16 <- getWord16be - mpib <- getRemainingLazyByteString - let parseV4MPIs parseErrPrefix = - case runGetOrFail (some getMPI) mpib of - Left (_, _, e) -> fail (parseErrPrefix ++ e) - Right (_, _, mpis) -> - return $ - SigV4 - (toFVal st) - pka - (toFVal ha) - hashed - unhashed - left16 - (NE.fromList mpis) - if pka == BTypes.Ed25519 - then - if BL.length mpib == 64 - then do - let sig = BL.toStrict mpib - (rbs, sbs) = B.splitAt 32 sig - return $ - SigV4 - (toFVal st) - pka - (toFVal ha) - hashed - unhashed - left16 - (NE.fromList [MPI (os2ip rbs), MPI (os2ip sbs)]) - else parseV4MPIs "v4 Ed25519 legacy MPIs " - else - if pka == BTypes.Ed448 - then - if BL.length mpib == 114 - then do - let sig = BL.toStrict mpib - (rbs, sbs) = B.splitAt 57 sig - return $ - SigV4 - (toFVal st) - pka - (toFVal ha) - hashed - unhashed - left16 - (NE.fromList [MPI (os2ip rbs), MPI (os2ip sbs)]) - else parseV4MPIs "v4 Ed448 legacy MPIs " - else parseV4MPIs "v4 sig MPIs " - 6 -> do - st <- getWord8 - pka <- get - ha <- get - hlen <- getWord32be - hb <- getLazyByteString (fromIntegral hlen) - let hashed = - case runGetOrFail (many getSigSubPacket) hb of - Left (_, _, err) -> fail ("v6 sig hasheds " ++ err) - Right (_, _, h) -> h - ulen <- getWord32be - ub <- getLazyByteString (fromIntegral ulen) - let unhashed = - case runGetOrFail (many getSigSubPacket) ub of - Left (_, _, err) -> fail ("v6 sig unhasheds " ++ err) - Right (_, _, u) -> u - left16 <- getWord16be - saltSize <- getWord8 - let haVal = (toFVal ha :: HashAlgorithm) - expectedSaltSize <- - maybe - (fail ("signature hash algorithm does not define a V6 salt size: " ++ show haVal)) - pure - (v6SaltSizeForHashAlgorithm haVal) - when (saltSize /= expectedSaltSize) $ - fail - ("v6 signature salt size mismatch for " ++ - show haVal ++ ": expected " ++ show expectedSaltSize ++ ", got " ++ show saltSize) - saltbs <- getByteString (fromIntegral saltSize) - let salt = SignatureSalt (BL.fromStrict saltbs) - if pka == BTypes.Ed25519 - then do - sig <- getByteString 64 - let (rbs, sbs) = B.splitAt 32 sig - mpis = [MPI (os2ip rbs), MPI (os2ip sbs)] - return $ - SigV6 - (toFVal st) - pka - (toFVal ha) - salt - hashed - unhashed - left16 - (NE.fromList mpis) - else - if pka == BTypes.Ed448 - then do - sig <- getByteString 114 - let (rbs, sbs) = B.splitAt 57 sig - mpis = [MPI (os2ip rbs), MPI (os2ip sbs)] - return $ - SigV6 - (toFVal st) - pka - (toFVal ha) - salt - hashed - unhashed - left16 - (NE.fromList mpis) - else do - mpib <- getRemainingLazyByteString - case runGetOrFail (some getMPI) mpib of - Left (_, _, e) -> fail ("v6 sig MPIs " ++ e) - Right (_, _, mpis) -> - return $ - SigV6 - (toFVal st) - pka - (toFVal ha) - salt - hashed - unhashed - left16 - (NE.fromList mpis) - _ -> do - bs <- getRemainingLazyByteString - return $ SigVOther pv bs - -putSignaturePayload :: SignaturePayload -> Put -putSignaturePayload (SigV3 st ctime eok pka ha left16 mpis) = do - putWord8 3 - putWord8 5 -- hashlen - put st - putWord32be . unThirtyTwoBitTimeStamp $ ctime - putLazyByteString (unEOKI eok) - put pka - put ha - putWord16be left16 - F.mapM_ put mpis -putSignaturePayload (SigV4 st pka ha hashed unhashed left16 mpis) = do - putWord8 4 - put st - put pka - put ha - let hb = runPut $ mapM_ put hashed - putWord16be . fromIntegral . BL.length $ hb - putLazyByteString hb - let ub = runPut $ mapM_ put unhashed - putWord16be . fromIntegral . BL.length $ ub - putLazyByteString ub - putWord16be left16 - if pka == BTypes.Ed25519 - then - case NE.toList mpis of - [MPI r, MPI s] -> do - putByteString (padN 32 r) - putByteString (padN 32 s) - _ -> error "Ed25519 v4 signatures must have two MPIs" - else - if pka == BTypes.Ed448 - then - case NE.toList mpis of - [MPI r, MPI s] -> do - putByteString (padN 57 r) - putByteString (padN 57 s) - _ -> error "Ed448 v4 signatures must have two MPIs" - else F.mapM_ put mpis - where - padN n i = - let bs = i2osp i - in B.replicate (max 0 (n - B.length bs)) 0 <> bs -putSignaturePayload (SigV6 st pka ha salt hashed unhashed left16 mpis) = do - let expectedSaltSize = - maybe - (error ("signature hash algorithm does not define a V6 salt size: " ++ show ha)) - id - (v6SaltSizeForHashAlgorithm ha) - actualSaltSize = fromIntegral (BL.length (unSignatureSalt salt)) - when (actualSaltSize /= expectedSaltSize) $ - error - ("v6 signature salt size mismatch for " ++ - show ha ++ ": expected " ++ show expectedSaltSize ++ ", got " ++ show actualSaltSize) - putWord8 6 - put st - put pka - put ha - let hb = runPut $ mapM_ put hashed - putWord32be . fromIntegral . BL.length $ hb - putLazyByteString hb - let ub = runPut $ mapM_ put unhashed - putWord32be . fromIntegral . BL.length $ ub - putLazyByteString ub - putWord16be left16 - putWord8 . fromIntegral . BL.length . unSignatureSalt $ salt - putByteString (BL.toStrict (unSignatureSalt salt)) - if pka == BTypes.Ed25519 - then - case NE.toList mpis of - [MPI r, MPI s] -> do - putByteString (padN 32 r) - putByteString (padN 32 s) - _ -> error "Ed25519 v6 signatures must have two MPIs" - else - if pka == BTypes.Ed448 - then - case NE.toList mpis of - [MPI r, MPI s] -> do - putByteString (padN 57 r) - putByteString (padN 57 s) - _ -> error "Ed448 v6 signatures must have two MPIs" - else F.mapM_ put mpis - where - padN n i = - let bs = i2osp i - in B.replicate (max 0 (n - B.length bs)) 0 <> bs -putSignaturePayload (SigVOther pv bs) = do - putWord8 pv - putLazyByteString bs - -putTK :: TKUnknown -> Put -putTK tk = do - let pkp = tk ^. tkuKey . _1 - maybe - (put (PublicKey pkp)) - (\ska -> put (SecretKey pkp ska)) - (snd (tk ^. tkuKey)) - mapM_ (put . Signature) (_tkuRevs tk) - mapM_ putUid' (_tkuUIDs tk) - mapM_ putUat' (_tkuUAts tk) - mapM_ putSub' (_tkuSubs tk) - where - putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps - putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps - putSub' (p, sps) = put p >> mapM_ (put . Signature) sps - --- | Parse the packets from a ByteString, with no error reporting -parsePkts :: ByteString -> [Pkt] -parsePkts = reverse . fst . parsePktsAccum 0 [] - --- | Parse packets from a ByteString and report the first parse failure. -parsePktsEither :: ByteString -> Either PktParseError [Pkt] -parsePktsEither lbs = - case parsePktsAccum 0 [] lbs of - (pkts, Nothing) -> Right (reverse pkts) - (_, Just err) -> Left err - -data PktParseError = - PktParseError - { pktParseErrorOffset :: Int64 - , pktParseErrorMessage :: String - } - deriving (Eq, Show) - -parsePktsAccum :: - Int64 -> [Pkt] -> ByteString -> ([Pkt], Maybe PktParseError) -parsePktsAccum offset acc lbs - | BL.null lbs = (acc, Nothing) - | otherwise = - case runGetOrFail getPkt lbs of - Left (_, parseOffset, msg) -> (acc, err parseOffset msg) - Right (rest, consumed, pkt) -> - parsePktsAccum (offset + consumed) (pkt : acc) rest - where - err parseOffset msg = - Just - PktParseError - { pktParseErrorOffset = offset + parseOffset - , pktParseErrorMessage = msg - } - -armorPayloads :: [Armor] -> [ByteString] -armorPayloads = - foldr collect [] - where - collect (Armor _ _ payload) = (BL.fromStrict (BLC8.toStrict payload) :) - collect (ClearSigned _ _ inner) = (armorPayloads [inner] ++) - -looksLikeAsciiArmor :: ByteString -> Bool -looksLikeAsciiArmor = - (armorHeaderLazy `BL.isPrefixOf`) . BL.dropWhile isLeadingArmorWhitespace - -looksLikeAsciiArmorLenient :: ByteString -> Bool -looksLikeAsciiArmorLenient = looksLikeAsciiArmor . stripUtf8Bom - -armorPayloadsOfType :: ArmorType -> [Armor] -> [ByteString] -armorPayloadsOfType atype = - foldr collect [] - where - collect (Armor innerType _ payload) - | innerType == atype = (BL.fromStrict (BLC8.toStrict payload) :) - | otherwise = id - collect (ClearSigned _ _ inner) = (armorPayloadsOfType atype [inner] ++) - -singleArmorPayloadOfType :: ArmorType -> [Armor] -> Either String ByteString -singleArmorPayloadOfType atype armors = - case armorPayloadsOfType atype armors of - [payload] -> Right payload - [] -> Left ("ASCII armor decode returned no " ++ show atype ++ " blocks") - payloads -> - Left - ("ASCII armor decode returned " ++ - show (length payloads) ++ " " ++ show atype ++ " blocks (expected exactly one)") - -singleClearSignedBlock :: - [Armor] -> Either String ([(String, String)], ByteString, ByteString) -singleClearSignedBlock armors = - case [clearSignedBlockFromArmor armor | armor@ClearSigned {} <- armors] of - [Right clearSigned] -> Right clearSigned - [Left err] -> Left err - [] -> Left "ASCII armor decode returned no clear-signed blocks" - clearSigneds -> - Left - ("ASCII armor decode returned " ++ - show (length clearSigneds) ++ " clear-signed blocks (expected exactly one)") - where - clearSignedBlockFromArmor (ClearSigned hs cleartext inner) = - case inner of - Armor ArmorSignature _ sig -> - Right - ( hs - , BL.fromStrict (BLC8.toStrict cleartext) - , BL.fromStrict (BLC8.toStrict sig) - ) - Armor atype _ _ -> - Left - ("clear-signed block contained inner armor type " ++ - show atype ++ " (expected ArmorSignature)") - ClearSigned {} -> - Left "clear-signed block contained nested clear-signed payload" - clearSignedBlockFromArmor _ = - Left "internal error: expected ClearSigned armor block" - -recommendedArmorType :: [Pkt] -> Maybe ArmorType -recommendedArmorType [] = Nothing -recommendedArmorType (pkt:_) - | isPrivateKeyPacket pkt = Just ArmorPrivateKeyBlock - | isPublicKeyPacket pkt = Just ArmorPublicKeyBlock - | isSignaturePacket pkt = Just ArmorSignature - | otherwise = Just ArmorMessage - where - isPrivateKeyPacket SecretKeyPkt {} = True - isPrivateKeyPacket SecretSubkeyPkt {} = True - isPrivateKeyPacket _ = False - - isPublicKeyPacket PublicKeyPkt {} = True - isPublicKeyPacket PublicSubkeyPkt {} = True - isPublicKeyPacket _ = False - - isSignaturePacket SignaturePkt {} = True - isSignaturePacket _ = False - -dearmorIfAsciiArmored :: ByteString -> Either String (Bool, ByteString) -dearmorIfAsciiArmored bs - | looksLikeAsciiArmor bs = - (\payload -> (True, payload)) <$> decodeSingleArmorPayload bs - | otherwise = Right (False, bs) - -dearmorIfAsciiArmoredLenient :: ByteString -> Either String (Bool, ByteString) -dearmorIfAsciiArmoredLenient bs - | looksLikeAsciiArmorLenient bs = - (\payload -> (True, payload)) <$> decodeSingleArmorPayloadLenient (stripUtf8Bom bs) - | otherwise = Right (False, bs) - -decodeSingleArmorPayload :: ByteString -> Either String ByteString -decodeSingleArmorPayload bs = - case AA.decodeLazy bs of - Left err -> Left err - Right armors -> singleArmorPayload armors - -decodeSingleArmorPayloadLenient :: ByteString -> Either String ByteString -decodeSingleArmorPayloadLenient bs = - case decodeSingleArmorPayload bs of - Right payload -> Right payload - Left strictErr -> - let normalized = normalizeAsciiArmorForLenientDecode bs - in if normalized == bs - then Left strictErr - else case decodeSingleArmorPayload normalized of - Left lenientErr -> - Left - (strictErr ++ - " (lenient normalization retry failed: " ++ lenientErr ++ ")") - Right payload -> Right payload - -singleArmorPayload :: [Armor] -> Either String ByteString -singleArmorPayload armors = - case armorPayloads armors of - [payload] -> Right payload - [] -> Left "ASCII armor decode succeeded but returned no blocks" - payloads -> - Left - ("ASCII armor decode returned " ++ - show (length payloads) ++ " blocks (expected exactly one)") - -data WireRepInput = - WireRepInput - { wireRepInputRef :: WireRepRef - , wireRepInputPayload :: ByteString - } - -wireRepRefFromInput :: Maybe T.Text -> ByteString -> Either String WireRepInput -wireRepRefFromInput mname bs = - (\(wasArmored, payload) -> - WireRepInput - { wireRepInputRef = BTypes.mkWireRepRef mname wasArmored payload - , wireRepInputPayload = payload - }) <$> - dearmorIfAsciiArmored bs - -data ParseState = - ParseState - { psOffset :: Int64 - , psIndex :: Int - , psSource :: WireRepRef - , psRemaining :: BL.ByteString - } - --- | Parse packets from a source bytestream, preserving packet provenance. -parsePktsWithWireRep :: WireRepRef -> ByteString -> [PktWithWireRep] -parsePktsWithWireRep src input = go initialState - where - initialState = - ParseState - { psOffset = 0 - , psIndex = 0 - , psSource = src - , psRemaining = input - } - go state - | BL.null (psRemaining state) = [] - | otherwise = - case runGetOrFail getPkt (psRemaining state) of - Left (_, _, _) -> [] - Right (rest, consumed, pkt) -> - let raw = BL.take consumed (psRemaining state) - newState = - state - { psOffset = psOffset state + consumed - , psIndex = psIndex state + 1 - , psRemaining = rest - } - pktWithSource = - PktWithWireRep - (psSource state) - (ByteRange (psOffset state) consumed) - raw - (psIndex state) - pkt - in pktWithSource : go newState - -conduitParsePktsWithWireRep :: - Monad m => Maybe T.Text -> ConduitT B.ByteString PktWithWireRep m () -conduitParsePktsWithWireRep mname = go (UndecidedInput []) - where - go !state = do - mchunk <- await - case mchunk of - Nothing -> mapM_ yield (finishConduitState mname state) - Just chunk -> - let !nextState = consumeConduitChunk chunk state - in go nextState - -data ConduitParseState - = UndecidedInput ![B.ByteString] - | ArmoredInput ![B.ByteString] - | BinaryInput !BinaryParseState - -data BinaryParseState = - BinaryParseState - { bpsLength :: !Int64 - , bpsOffset :: !Int64 - , bpsIndex :: !Int - , bpsBuffer :: !B.ByteString - , bpsParsedRev :: [ParsedPacketChunk] - } - -data ArmorPrefixDecision - = PrefixNeedsMore - | PrefixIsArmored - | PrefixIsBinary - -consumeConduitChunk :: B.ByteString -> ConduitParseState -> ConduitParseState -consumeConduitChunk chunk (UndecidedInput chunksRev) = - let prefixChunksRev = chunk : chunksRev - prefix = B.concat (reverse prefixChunksRev) - in case classifyArmorPrefix prefix of - PrefixNeedsMore -> UndecidedInput prefixChunksRev - PrefixIsArmored -> ArmoredInput prefixChunksRev - PrefixIsBinary -> feedBinaryChunk prefix initialBinaryParseState -consumeConduitChunk chunk (ArmoredInput chunksRev) = ArmoredInput (chunk : chunksRev) -consumeConduitChunk chunk (BinaryInput state) = BinaryInput (advanceBinaryParseState chunk state) - -finishConduitState :: Maybe T.Text -> ConduitParseState -> [PktWithWireRep] -finishConduitState mname (UndecidedInput chunksRev) = - finalizeBinaryParseState - mname - (advanceBinaryParseState (B.concat (reverse chunksRev)) initialBinaryParseState) -finishConduitState mname (ArmoredInput chunksRev) = - let input = BL.fromChunks (reverse chunksRev) - in case wireRepRefFromInput mname input of - Left _ -> [] - Right WireRepInput - { wireRepInputRef = src - , wireRepInputPayload = payload - } -> - parsePktsWithWireRep src payload -finishConduitState mname (BinaryInput state) = finalizeBinaryParseState mname state - -initialBinaryParseState :: BinaryParseState -initialBinaryParseState = - BinaryParseState - { bpsLength = 0 - , bpsOffset = 0 - , bpsIndex = 0 - , bpsBuffer = B.empty - , bpsParsedRev = [] - } - -feedBinaryChunk :: B.ByteString -> BinaryParseState -> ConduitParseState -feedBinaryChunk chunk = BinaryInput . advanceBinaryParseState chunk - -advanceBinaryParseState :: B.ByteString -> BinaryParseState -> BinaryParseState -advanceBinaryParseState chunk state = - let !nextLength = bpsLength state + fromIntegral (B.length chunk) - !(nextOffset, nextIndex, nextBuffer, nextParsedRev) = - drainParsedPackets - (bpsOffset state) - (bpsIndex state) - (bpsBuffer state <> chunk) - (bpsParsedRev state) - in BinaryParseState - { bpsLength = nextLength - , bpsOffset = nextOffset - , bpsIndex = nextIndex - , bpsBuffer = nextBuffer - , bpsParsedRev = nextParsedRev - } - -finalizeBinaryParseState :: Maybe T.Text -> BinaryParseState -> [PktWithWireRep] -finalizeBinaryParseState mname state = - let src = BTypes.mkWireRepRefWithLength mname False (bpsLength state) - in map (toPktWithWireRep src) (reverse (bpsParsedRev state)) - -classifyArmorPrefix :: B.ByteString -> ArmorPrefixDecision -classifyArmorPrefix prefix = - case B.dropWhile isLeadingArmorWhitespace prefix of - rest - | B.null rest -> PrefixNeedsMore - | armorHeader `B.isPrefixOf` rest -> PrefixIsArmored - | rest `B.isPrefixOf` armorHeader -> PrefixNeedsMore - | otherwise -> PrefixIsBinary - -armorHeader :: B.ByteString -armorHeader = B.pack (map (fromIntegral . fromEnum) "-----BEGIN PGP ") - -armorHeaderLazy :: ByteString -armorHeaderLazy = BL.fromStrict armorHeader - -utf8Bom :: ByteString -utf8Bom = BL.pack [0xef, 0xbb, 0xbf] - -isLeadingArmorWhitespace :: Word8 -> Bool -isLeadingArmorWhitespace w = w == 0x20 || w == 0x09 || w == 0x0d || w == 0x0a - -stripUtf8Bom :: ByteString -> ByteString -stripUtf8Bom bs - | utf8Bom `BL.isPrefixOf` bs = BL.drop (fromIntegral (BL.length utf8Bom)) bs - | otherwise = bs - -normalizeAsciiArmorForLenientDecode :: ByteString -> ByteString -normalizeAsciiArmorForLenientDecode = - ensureTrailingLf . normalizeLineEndings - where - ensureTrailingLf lbs - | BL.null lbs = lbs - | BL.last lbs == 0x0a = lbs - | otherwise = lbs <> BL.singleton 0x0a - normalizeLineEndings lbs = - case BL.uncons lbs of - Nothing -> BL.empty - Just (0x0d, rest) -> - case BL.uncons rest of - Just (0x0a, rest') -> BL.cons 0x0a (normalizeLineEndings rest') - _ -> BL.cons 0x0a (normalizeLineEndings rest) - Just (w, rest) -> BL.cons w (normalizeLineEndings rest) - -data ParsedPacketChunk = - ParsedPacketChunk - { ppcRange :: ByteRange - , ppcRaw :: ByteString - , ppcIndex :: Int - , ppcValue :: Pkt - } - -toPktWithWireRep :: WireRepRef -> ParsedPacketChunk -> PktWithWireRep -toPktWithWireRep src ppc = - PktWithWireRep src (ppcRange ppc) (ppcRaw ppc) (ppcIndex ppc) (ppcValue ppc) - -drainParsedPackets :: - Int64 - -> Int - -> B.ByteString - -> [ParsedPacketChunk] - -> (Int64, Int, B.ByteString, [ParsedPacketChunk]) -drainParsedPackets !offset !idx !buffer acc - | B.null buffer = (offset, idx, B.empty, acc) - | otherwise = - case runGetOrFail getPkt (BL.fromStrict buffer) of - Left _ -> (offset, idx, buffer, acc) - Right (rest, consumed, pkt) -> - let !consumedLen = fromIntegral consumed - !nextOffset = offset + consumed - !nextIdx = idx + 1 - !nextBuffer = BL.toStrict rest - parsedPacket = - ParsedPacketChunk - { ppcRange = ByteRange offset consumed - , ppcRaw = BL.fromStrict (B.take consumedLen buffer) - , ppcIndex = idx - , ppcValue = pkt - } - in drainParsedPackets - nextOffset - nextIdx - nextBuffer - (parsedPacket : acc) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} + +module Codec.Encryption.OpenPGP.Serialize + ( -- * Serialization functions + putPkt + , putPktEither + , putSKAddendum + , getSecretKey + , putSKeyForPKPayload + + -- * Utilities + , dearmorIfAsciiArmored + , dearmorIfAsciiArmoredLenient + , looksLikeAsciiArmor + , armorPayloadsOfType + , singleArmorPayloadOfType + , singleClearSignedBlock + , recommendedArmorType + , WireRepInput (..) + , wireRepRefFromInput + , PktParseError (..) + , parsePkts + , parsePktsEither + , parsePktsWithWireRep + , conduitParsePktsWithWireRep + ) where + +import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA +import Codec.Encryption.OpenPGP.ASCIIArmor.Types + ( Armor (..) + , ArmorType (..) + ) +import Control.Applicative (many, some) +import Control.Arrow ((***)) +import Control.Lens ((^.), _1) +import Control.Monad (guard, replicateM, replicateM_, when) +import Crypto.Number.Basic (numBits) +import Crypto.Number.ModArithmetic (inverse) +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Crypto.PubKey.DSA as D +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Types as ECCT +import qualified Crypto.PubKey.RSA as R +import Data.Bifunctor (bimap) +import Data.Binary (Binary, get, put) +import Data.Binary.Get + ( ByteOffset + , Get + , bytesRead + , getByteString + , getLazyByteString + , getRemainingLazyByteString + , getWord16be + , getWord16le + , getWord32be + , getWord8 + , lookAhead + , runGetOrFail + ) +import Data.Binary.Put + ( Put + , putByteString + , putLazyByteString + , putWord16be + , putWord16le + , putWord32be + , putWord8 + , runPut + ) +import Data.Bits (shiftL, shiftR, testBit, (.&.), (.|.)) +import qualified Data.ByteString as B +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import Data.Conduit (ConduitT, await, yield) +import qualified Data.Foldable as F +import Data.Int (Int64) +import Data.List (mapAccumL) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +import Data.Word (Word16, Word32, Word8) +import Network.URI (nullURI, parseURI, uriToString) + +import Codec.Encryption.OpenPGP.Internal + ( curve2Curve + , curveFromCurve + , curveToCurveoidBS + , curveoidBSToCurve + , curveoidBSToEdSigningCurve + , edSigningCurveToCurveoidBS + , leftPadTo + , pubkeyToMPIs + ) +import Codec.Encryption.OpenPGP.Policy + ( signatureV6SaltSizeForHashAlgorithm + ) +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes +import qualified Codec.Encryption.OpenPGP.Types.Internal.PKITypes as P + +instance Binary SigSubPacket where + get = getSigSubPacket + put = putSigSubPacket + +-- instance Binary (Set NotationFlag) where +-- put = putNotationFlagSet +instance Binary CompressionAlgorithm where + get = toFVal <$> getWord8 + put = putWord8 . fromFVal + +instance Binary PubKeyAlgorithm where + get = toFVal <$> getWord8 + put = putWord8 . fromFVal + +instance Binary HashAlgorithm where + get = toFVal <$> getWord8 + put = putWord8 . fromFVal + +instance Binary SymmetricAlgorithm where + get = toFVal <$> getWord8 + put = putWord8 . fromFVal + +instance Binary AEADAlgorithm where + get = toFVal <$> getWord8 + put = putWord8 . fromFVal + +instance Binary MPI where + get = getMPI + put = putMPI + +instance Binary SigType where + get = toFVal <$> getWord8 + put = putWord8 . fromFVal + +instance Binary UserAttrSubPacket where + get = getUserAttrSubPacket + put = putUserAttrSubPacket + +instance Binary S2K where + get = getS2K + put = putS2K + +instance Binary (PKESK 'PKESKV3) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary (PKESK 'PKESKV6) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary Signature where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary (SKESK 'SKESKV4) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary (SKESK 'SKESKV6) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary (OnePassSignature 'OPSV3) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary (OnePassSignature 'OPSV6) where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary SecretKey where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary PublicKey where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary SecretSubkey where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary CompressedData where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary SymEncData where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary Marker where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary LiteralData where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary Trust where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary UserId where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary PublicSubkey where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary UserAttribute where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary SymEncIntegrityProtectedData where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary ModificationDetectionCode where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary OtherPacket where + get = getPkt >>= either fail pure . fromPktEither + put = putPkt . toPkt + +instance Binary Pkt where + get = getPkt + put = putPkt + +instance (Binary a) => Binary (Block a) where + get = Block `fmap` many get + put = mapM_ put . unBlock + +instance Binary SomePKPayload where + get = getPKPayload + put = putPKPayload + +instance Binary SignaturePayload where + get = getSignaturePayload + put = putSignaturePayload + +instance Binary TKUnknown where + get = fail "Binary TKUnknown decode is not implemented" + put = putTK + +getSigSubPacket :: Get SigSubPacket +getSigSubPacket = do + l <- fmap fromIntegral getSubPacketLength + (crit, pt) <- getSigSubPacketType + getSigSubPacket' pt crit l + where + getSigSubPacket' + :: Word8 -> Bool -> ByteOffset -> Get SigSubPacket + getSigSubPacket' pt crit l + | pt == 2 = do + et <- fmap ThirtyTwoBitTimeStamp getWord32be + return $ SigSubPacket crit (SigCreationTime et) + | pt == 3 = do + et <- fmap ThirtyTwoBitDuration getWord32be + return $ SigSubPacket crit (SigExpirationTime et) + | pt == 4 = do + e <- get + return $ SigSubPacket crit (ExportableCertification e) + | pt == 5 = do + tl <- getWord8 + ta <- getWord8 + return $ SigSubPacket crit (TrustSignature tl ta) + | pt == 6 = do + apdre <- getLazyByteString (l - 2) + nul <- getWord8 + guard (nul == 0) + return $ SigSubPacket crit (RegularExpression (BL.copy apdre)) + | pt == 7 = do + r <- get + return $ SigSubPacket crit (Revocable r) + | pt == 9 = do + et <- fmap ThirtyTwoBitDuration getWord32be + return $ SigSubPacket crit (KeyExpirationTime et) + | pt == 11 = do + sa <- replicateM (fromIntegral (l - 1)) get + return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa) + | pt == 12 = do + rclass <- getWord8 + guard (testBit rclass 7) + algid <- get + fp <- getLazyByteString (fromIntegral l - 3) + return $ + SigSubPacket + crit + ( RevocationKey + (bsToFFSet . BL.singleton $ rclass .&. 0x7f) + algid + (Fingerprint fp) + ) + | pt == 16 = do + keyid <- getLazyByteString (l - 1) + return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid)) + | pt == 20 = do + flags <- getLazyByteString 4 + nl <- getWord16be + vl <- getWord16be + nn <- getLazyByteString (fromIntegral nl) + nv <- getLazyByteString (fromIntegral vl) + return $ + SigSubPacket + crit + ( NotationData + (bsToFFSet flags) + (NotationName nn) + (NotationValue nv) + ) + | pt == 21 = do + ha <- replicateM (fromIntegral (l - 1)) get + return $ SigSubPacket crit (PreferredHashAlgorithms ha) + | pt == 22 = do + ca <- replicateM (fromIntegral (l - 1)) get + return $ SigSubPacket crit (PreferredCompressionAlgorithms ca) + | pt == 23 = do + ksps <- getLazyByteString (l - 1) + return $ + SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps)) + | pt == 24 = do + pks <- getLazyByteString (l - 1) + return $ SigSubPacket crit (PreferredKeyServer pks) + | pt == 25 = do + primacy <- get + return $ SigSubPacket crit (PrimaryUserId primacy) + | pt == 26 = do + url <- + fmap + ( URL + . fromMaybe nullURI + . parseURI + . T.unpack + . decodeUtf8With lenientDecode + ) + (getByteString (fromIntegral (l - 1))) + return $ SigSubPacket crit (PolicyURL url) + | pt == 27 = do + kfs <- getLazyByteString (l - 1) + return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs)) + | pt == 28 = do + uid <- getByteString (fromIntegral (l - 1)) + return $ + SigSubPacket + crit + (SignersUserId (decodeUtf8With lenientDecode uid)) + | pt == 29 = do + rcode <- getWord8 + rreason <- + fmap + (decodeUtf8With lenientDecode) + (getByteString (fromIntegral (l - 2))) + return $ + SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason) + | pt == 30 = do + fbs <- getLazyByteString (l - 1) + return $ SigSubPacket crit (Features (bsToFFSet fbs)) + | pt == 31 = do + pka <- get + ha <- get + hash <- getLazyByteString (l - 3) + return $ SigSubPacket crit (SignatureTarget pka ha hash) + | pt == 32 = do + spbs <- getLazyByteString (l - 1) + case runGetOrFail get spbs of + Left (_, _, e) -> fail ("embedded signature subpacket " ++ e) + Right (_, _, sp) -> return $ SigSubPacket crit (EmbeddedSignature sp) + | pt == 33 = do + when (l /= 22 && l /= 34) $ + fail ("invalid issuer fingerprint subpacket length: " ++ show l) + kv <- getWord8 + let fpLen = l - 2 + when (fpLen /= 20 && fpLen /= 32) $ + fail ("invalid issuer fingerprint length: " ++ show fpLen) + case BTypes.packetVersionToIssuerFingerprintVersion kv of + Nothing -> + fail ("invalid issuer fingerprint version marker: " ++ show kv) + Just ifVersion -> do + fp <- + case kv of + 4 -> getLazyByteString (fromIntegral fpLen) + 6 -> getLazyByteString (fromIntegral fpLen) + _ -> + fail ("invalid issuer fingerprint version marker: " ++ show kv) + return $ + SigSubPacket crit (IssuerFingerprint ifVersion (Fingerprint fp)) + | pt == 35 = do + kv <- getWord8 + fp <- getLazyByteString (l - 2) + when (BL.length fp /= 20 && BL.length fp /= 32) $ + fail + ( "invalid intended recipient fingerprint length: " + ++ show (BL.length fp) + ) + case BTypes.packetVersionToIssuerFingerprintVersion kv of + Nothing -> + fail + ( "invalid intended recipient fingerprint version marker: " + ++ show kv + ) + Just ifVersion -> + return $ + SigSubPacket crit (IntendedRecipient ifVersion (Fingerprint fp)) + | pt == 39 = do + let payloadLen = fromIntegral (l - 1) + when (payloadLen `mod` 2 /= 0) $ + fail "preferred AEAD ciphersuites subpacket length must be even" + pairs <- replicateM (payloadLen `div` 2) $ do + sa <- get + aead <- get + return (sa, aead) + return $ SigSubPacket crit (PreferredAEADCiphersuites pairs) + | pt > 99 && pt < 111 = do + payload <- getLazyByteString (l - 1) + return $ SigSubPacket crit (UserDefinedSigSub pt payload) + | otherwise = do + payload <- getLazyByteString (l - 1) + return $ SigSubPacket crit (OtherSigSub pt payload) + +putSigSubPacket :: SigSubPacket -> Put +putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do + putSubPacketLength 5 + putSigSubPacketType crit 2 + putWord32be . unThirtyTwoBitTimeStamp $ et +putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do + putSubPacketLength 5 + putSigSubPacketType crit 3 + putWord32be . unThirtyTwoBitDuration $ et +putSigSubPacket (SigSubPacket crit (ExportableCertification e)) = do + putSubPacketLength 2 + putSigSubPacketType crit 4 + put e +putSigSubPacket (SigSubPacket crit (TrustSignature tl ta)) = do + putSubPacketLength 3 + putSigSubPacketType crit 5 + put tl + put ta +putSigSubPacket (SigSubPacket crit (RegularExpression apdre)) = do + putSubPacketLength . fromIntegral $ (2 + BL.length apdre) + putSigSubPacketType crit 6 + putLazyByteString apdre + putWord8 0 +putSigSubPacket (SigSubPacket crit (Revocable r)) = do + putSubPacketLength 2 + putSigSubPacketType crit 7 + put r +putSigSubPacket (SigSubPacket crit (KeyExpirationTime et)) = do + putSubPacketLength 5 + putSigSubPacketType crit 9 + putWord32be . unThirtyTwoBitDuration $ et +putSigSubPacket (SigSubPacket crit (PreferredSymmetricAlgorithms ess)) = do + putSubPacketLength . fromIntegral $ (1 + length ess) + putSigSubPacketType crit 11 + mapM_ put ess +putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do + let fpLen = BL.length (unFingerprint fp) + putSubPacketLength (fromIntegral (3 + fpLen)) -- type(1) + rclass(1) + algid(1) + fingerprint + putSigSubPacketType crit 12 + putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $ + Set.insert (RClOther 0) rclass + put algid + putLazyByteString (unFingerprint fp) +putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do + putSubPacketLength 9 + putSigSubPacketType crit 16 + putLazyByteString (unEOKI keyid) -- 8 octets +putSigSubPacket + ( SigSubPacket + crit + (NotationData nfs (NotationName nn) (NotationValue nv)) + ) = do + putSubPacketLength . fromIntegral $ + (9 + BL.length nn + BL.length nv) + putSigSubPacketType crit 20 + putLazyByteString . ffSetToFixedLengthBS (4 :: Int) $ nfs + putWord16be . fromIntegral . BL.length $ nn + putWord16be . fromIntegral . BL.length $ nv + putLazyByteString nn + putLazyByteString nv +putSigSubPacket (SigSubPacket crit (PreferredHashAlgorithms ehs)) = do + putSubPacketLength . fromIntegral $ (1 + length ehs) + putSigSubPacketType crit 21 + mapM_ put ehs +putSigSubPacket (SigSubPacket crit (PreferredCompressionAlgorithms ecs)) = do + putSubPacketLength . fromIntegral $ (1 + length ecs) + putSigSubPacketType crit 22 + mapM_ put ecs +putSigSubPacket (SigSubPacket crit (KeyServerPreferences ksps)) = do + let kbs = ffSetToBS ksps + putSubPacketLength . fromIntegral $ (1 + BL.length kbs) + putSigSubPacketType crit 23 + putLazyByteString kbs +putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do + putSubPacketLength . fromIntegral $ (1 + BL.length ks) + putSigSubPacketType crit 24 + putLazyByteString ks +putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do + putSubPacketLength 2 + putSigSubPacketType crit 25 + put primacy +putSigSubPacket (SigSubPacket crit (PolicyURL (URL uri))) = do + let bs = encodeUtf8 (T.pack (uriToString id uri "")) + putSubPacketLength . fromIntegral $ (1 + B.length bs) + putSigSubPacketType crit 26 + putByteString bs +putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do + let kbs = ffSetToBS kfs + putSubPacketLength . fromIntegral $ (1 + BL.length kbs) + putSigSubPacketType crit 27 + putLazyByteString kbs +putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do + let bs = encodeUtf8 userid + putSubPacketLength . fromIntegral $ (1 + B.length bs) + putSigSubPacketType crit 28 + putByteString bs +putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do + let reasonbs = encodeUtf8 rreason + putSubPacketLength . fromIntegral $ (2 + B.length reasonbs) + putSigSubPacketType crit 29 + putWord8 . fromFVal $ rcode + putByteString reasonbs +putSigSubPacket (SigSubPacket crit (Features fs)) = do + let fbs = ffSetToBS fs + putSubPacketLength . fromIntegral $ (1 + BL.length fbs) + putSigSubPacketType crit 30 + putLazyByteString fbs +putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do + putSubPacketLength . fromIntegral $ (3 + BL.length hash) + putSigSubPacketType crit 31 + put pka + put ha + putLazyByteString hash +putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do + let spb = runPut (put sp) + putSubPacketLength . fromIntegral $ (1 + BL.length spb) + putSigSubPacketType crit 32 + putLazyByteString spb +putSigSubPacket (SigSubPacket crit (IssuerFingerprint kv fp)) = do + let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv + let fpb = unFingerprint fp + when (BL.length fpb /= 20 && BL.length fpb /= 32) $ + error + ("invalid issuer fingerprint length: " ++ show (BL.length fpb)) + putSubPacketLength . fromIntegral $ (2 + BL.length fpb) + putSigSubPacketType crit 33 + putWord8 kv' + putLazyByteString fpb +putSigSubPacket (SigSubPacket crit (IntendedRecipient kv irf)) = do + let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv + let fpb = unFingerprint irf + when (BL.length fpb /= 20 && BL.length fpb /= 32) $ + error + ( "invalid intended-recipient fingerprint length: " + ++ show (BL.length fpb) + ) + putSubPacketLength . fromIntegral $ (2 + BL.length fpb) + putSigSubPacketType crit 35 + putWord8 kv' + putLazyByteString fpb +putSigSubPacket (SigSubPacket crit (PreferredAEADCiphersuites ps)) = do + putSubPacketLength . fromIntegral $ (1 + 2 * length ps) + putSigSubPacketType crit 39 + mapM_ (\(sa, aead) -> put sa >> put aead) ps +putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) = + putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) +putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do + putSubPacketLength . fromIntegral $ (1 + BL.length payload) + putSigSubPacketType crit ptype + putLazyByteString payload + +getSubPacketLength :: Get Word32 +getSubPacketLength = getSubPacketLength' =<< getWord8 + where + getSubPacketLength' :: (Integral a) => Word8 -> Get a + getSubPacketLength' f + | f < 192 = return . fromIntegral $ f + | f < 224 = do + secondOctet <- getWord8 + return . fromIntegral $ + shiftL (fromIntegral (f - 192) :: Int) 8 + + (fromIntegral secondOctet :: Int) + + 192 + | f == 255 = do + len <- getWord32be + return . fromIntegral $ len + | otherwise = fail "Partial body length invalid." + +putSubPacketLength :: Word32 -> Put +putSubPacketLength l + | l < 192 = putWord8 (fromIntegral l) + | l < 8384 = + putWord8 + (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) + >> putWord8 (fromIntegral (l - 192) .&. 0xff) + | l <= 0xffffffff = putWord8 255 >> putWord32be (fromIntegral l) + | otherwise = error ("too big (" ++ show l ++ ")") + +getSigSubPacketType :: Get (Bool, Word8) +getSigSubPacketType = do + x <- getWord8 + return + ( if x .&. 128 == 128 + then (True, x .&. 127) + else (False, x) + ) + +putSigSubPacketType :: Bool -> Word8 -> Put +putSigSubPacketType False sst = putWord8 sst +putSigSubPacketType True sst = putWord8 (sst .|. 0x80) + +bsToFFSet :: (FutureFlag a) => ByteString -> Set a +bsToFFSet bs = + Set.fromAscList . concat . snd $ + mapAccumL + (\acc y -> (acc + 8, concatMap (shifty acc y) [0 .. 7])) + 0 + (BL.unpack bs) + where + shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x] + +ffSetToFixedLengthBS + :: (FutureFlag b, Integral a) => a -> Set b -> ByteString +ffSetToFixedLengthBS len ffs = + BL.take + (fromIntegral len) + (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0))) + +ffSetToBS :: (FutureFlag a) => Set a -> ByteString +ffSetToBS = BL.pack . ffSetToBS' + where + ffSetToBS' :: (FutureFlag a) => Set a -> [Word8] + ffSetToBS' ks + -- Emit a single zero octet for an empty flag set so encoded flag + -- subpackets always carry an explicit flags byte. + | Set.null ks = [0] + | otherwise = + map + ( ( foldl (.|.) 0 + . map (shiftR 128 . flip mod 8 . fromFFlag) + . Set.toAscList + ) + . (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks) + ) + [0 .. fromFFlag (Set.findMax ks) `div` 8] + +fromS2K :: S2K -> ByteString +fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo] +fromS2K (Salted hashalgo salt) = + BL.pack [1, fromIntegral . fromFVal $ hashalgo] + `BL.append` (BL.fromStrict . unSalt8) salt +fromS2K (IteratedSalted hashalgo salt count) = + BL.pack [3, fromIntegral . fromFVal $ hashalgo] + `BL.append` (BL.fromStrict . unSalt8) salt + `BL.snoc` encodeIterationCount count +fromS2K (Argon2 salt t p encodedM) = + BL.pack [4] + `BL.append` (BL.fromStrict . unSalt16) salt + `BL.append` BL.pack [t, p, encodedM] +fromS2K (OtherS2K _ bs) = bs + +getPacketLength :: Get Integer +getPacketLength = do + firstOctet <- getWord8 + lenOrPartial <- lengthOctetToLength firstOctet + case lenOrPartial of + Left _ -> + fail "Partial body length is invalid in this context" + Right len -> return len + where + lengthOctetToLength :: Word8 -> Get (Either Integer Integer) + lengthOctetToLength f + | f < 192 = return . Right . fromIntegral $ f + | f < 224 = do + secondOctet <- getWord8 + return . Right . fromIntegral $ + shiftL (fromIntegral (f - 192) :: Int) 8 + + (fromIntegral secondOctet :: Int) + + 192 + | f < 255 = + return . Left . fromIntegral $ + (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f) + | otherwise = do + len <- getWord32be + return . Right . fromIntegral $ len + +putPacketLength :: Integer -> Put +putPacketLength l + | l < 192 = putWord8 (fromIntegral l) + | l < 8384 = + putWord8 + (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) + >> putWord8 (fromIntegral (l - 192) .&. 0xff) + | l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l) + | otherwise = + error "packet length exceeds 32-bit definite length encoding" + +putPartialLength :: Word8 -> Put +putPartialLength n = putWord8 (224 + n) + +getPacketLengthFromOctet :: Word8 -> Get (Either Int64 Int64) +getPacketLengthFromOctet f + | f < 192 = return . Right . fromIntegral $ f + | f < 224 = do + secondOctet <- getWord8 + return . Right . fromIntegral $ + shiftL (fromIntegral (f - 192) :: Int) 8 + + (fromIntegral secondOctet :: Int) + + 192 + | f < 255 = + return . Left . fromIntegral $ + (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f) + | otherwise = do + len <- getWord32be + return . Right . fromIntegral $ len + +getS2K :: Get S2K +getS2K = getS2K' =<< getWord8 + where + getS2K' :: Word8 -> Get S2K + getS2K' t + | t == 0 = do + ha <- getWord8 + return $ Simple (toFVal ha) + | t == 1 = do + ha <- getWord8 + salt <- getByteString 8 + return $ Salted (toFVal ha) (Salt8 salt) + | t == 3 = do + ha <- getWord8 + salt <- getByteString 8 + count <- getWord8 + return $ + IteratedSalted + (toFVal ha) + (Salt8 salt) + (decodeIterationCount count) + | t == 4 = do + salt <- getByteString 16 + passes <- getWord8 + parallelism <- getWord8 + encodedM <- getWord8 + return $ Argon2 (Salt16 salt) passes parallelism encodedM + | otherwise = do + bs <- getRemainingLazyByteString + return $ OtherS2K t bs + +putS2K :: S2K -> Put +putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo) +putS2K (Salted hashalgo salt) = + error + ("confused by salted" ++ show hashalgo ++ " by " ++ show salt) +putS2K (IteratedSalted ha salt count) = do + putWord8 3 + put ha + putByteString (unSalt8 salt) + putWord8 $ encodeIterationCount count +putS2K (Argon2 salt t p encodedM) = do + putWord8 4 + putByteString (unSalt16 salt) + putWord8 t + putWord8 p + putWord8 encodedM +putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs + +v6SaltSizeForHashAlgorithm :: HashAlgorithm -> Maybe Word8 +v6SaltSizeForHashAlgorithm = signatureV6SaltSizeForHashAlgorithm + +getPacketTypeAndPayload :: Get (Word8, ByteString) +getPacketTypeAndPayload = do + tag <- getWord8 + guard (testBit tag 7) + case tag .&. 0x40 of + 0x00 -> do + let t = shiftR (tag .&. 0x3c) 2 + case tag .&. 0x03 of + 0 -> do + len <- getWord8 + bs <- getLazyByteString (fromIntegral len) + return (t, bs) + 1 -> do + len <- getWord16be + bs <- getLazyByteString (fromIntegral len) + return (t, bs) + 2 -> do + len <- getWord32be + bs <- getLazyByteString (fromIntegral len) + return (t, bs) + 3 -> do + bs <- getRemainingLazyByteString + return (t, bs) + _ -> + error "This should never happen (getPacketTypeAndPayload/0x00)." + 0x40 -> do + firstLenOctet <- getWord8 + bs <- getPacketPayloadFromLengthOctet firstLenOctet + return (tag .&. 0x3f, bs) + _ -> + error "This should never happen (getPacketTypeAndPayload/???)." + where + getPacketPayloadFromLengthOctet :: Word8 -> Get ByteString + getPacketPayloadFromLengthOctet lenOctet = do + lenOrPartial <- getPacketLengthFromOctet lenOctet + case lenOrPartial of + Right len -> getLazyByteString len + Left partialLen -> do + chunk <- getLazyByteString partialLen + rest <- getRemainingPartialPayload + return (chunk <> rest) + getRemainingPartialPayload :: Get ByteString + getRemainingPartialPayload = do + lenOctet <- getWord8 + lenOrPartial <- getPacketLengthFromOctet lenOctet + case lenOrPartial of + Right len -> getLazyByteString len + Left partialLen -> do + chunk <- getLazyByteString partialLen + (chunk <>) <$> getRemainingPartialPayload + +getPkt :: Get Pkt +getPkt = do + (t, pl) <- getPacketTypeAndPayload + case runGetOrFail (getPkt' t (BL.length pl)) pl of + Left (_, _, e) -> return $! BrokenPacketPkt e t pl + Right (_, _, p) -> return p + where + parseLegacyPKESK + :: PacketVersion -> BL.ByteString -> Either String Pkt + parseLegacyPKESK pv body = do + (_, _, (eokeyid, pkaRaw, mpib)) <- + bimap (\(_, _, e) -> e) id $ + runGetOrFail + ( do + eokeyid <- getLazyByteString 8 + pka <- getWord8 + mpib <- getRemainingLazyByteString + pure (eokeyid, pka, mpib) + ) + body + let pka = toFVal pkaRaw + sk <- parseLegacyPKESKMPIs pka mpib + pure $ + PKESKPkt + ( PKESKPayloadV3Packet + (PKESKPayloadV3 pv (EightOctetKeyId eokeyid) pka sk) + ) + + parseLegacyPKESKMPIs + :: PubKeyAlgorithm + -> BL.ByteString + -> Either String (NE.NonEmpty MPI) + parseLegacyPKESKMPIs pka mpib = do + case parseLegacyPKESKMPIsStrict pka mpib of + Right sk -> pure sk + Left strictErr + | pka == X25519 -> + case parseLegacyPKESKX25519V3Octets mpib of + Right sk -> Right sk + Left octetErr -> + Left + ( strictErr + ++ "; also failed to parse RFC9580 X25519 v3 octet layout: " + ++ octetErr + ) + | pka == ECDH -> + case parseLegacyPKESKECDHOctets mpib of + Right sk -> Right sk + Left octetErr -> + Left + ( strictErr + ++ "; also failed to parse RFC6637 ECDH v3 octet layout: " + ++ octetErr + ) + | otherwise -> Left strictErr + + parseLegacyPKESKMPIsStrict + :: PubKeyAlgorithm + -> BL.ByteString + -> Either String (NE.NonEmpty MPI) + parseLegacyPKESKMPIsStrict pka mpib = do + (rest, _, sk) <- + bimap (\(_, _, e) -> e) id $ + runGetOrFail (parserForLegacyPKESKMPIs pka) mpib + if BL.null rest + then pure (NE.fromList sk) + else + Left + ("unexpected trailing PKESK MPI data for algorithm " ++ show pka) + + parseLegacyPKESKX25519V3Octets + :: BL.ByteString -> Either String (NE.NonEmpty MPI) + parseLegacyPKESKX25519V3Octets mpib = do + if BL.length mpib < 33 + then Left "X25519 v3 PKESK octet layout is too short" + else Right () + let ephemeral = BL.toStrict (BL.take 32 mpib) + eskLen = fromIntegral (BL.index mpib 32) :: Int + eskWithAlgo = BL.toStrict (BL.drop 33 mpib) + if eskLen /= B.length eskWithAlgo + then + Left "X25519 v3 PKESK octet layout has inconsistent ESK length" + else Right () + if B.null eskWithAlgo + then + Left + "X25519 v3 PKESK octet layout must include a symmetric algorithm octet" + else Right () + let symAlgo = B.head eskWithAlgo + if symAlgo + `elem` [ fromIntegral (fromFVal AES128) + , fromIntegral (fromFVal AES192) + , fromIntegral (fromFVal AES256) + ] + then + pure + (NE.fromList [MPI (os2ip ephemeral), MPI (os2ip eskWithAlgo)]) + else + Left + ( "X25519 v3 PKESK octet layout has unsupported symmetric algorithm octet " + ++ show symAlgo + ) + + -- \| Parse an RFC 6637 §8 ECDH PKESKv3 body as MPI(ephemeral) || 1-octet-count || C. + -- This is the interoperable wire format produced by GnuPG and other RFC-compliant + -- implementations. hOpenPGP previously wrote both fields as MPIs; this fallback + -- allows reading RFC-compliant packets when the strict two-MPI path fails. + parseLegacyPKESKECDHOctets + :: BL.ByteString -> Either String (NE.NonEmpty MPI) + parseLegacyPKESKECDHOctets mpib = do + (rest, _, ephMPI) <- + bimap (\(_, _, e) -> e) id $ runGetOrFail getMPI mpib + let restBS = BL.toStrict rest + when (B.null restBS) $ + Left + "ECDH v3 PKESK RFC6637 octet layout: missing wrapped-key length octet after ephemeral MPI" + let wrappedLen = fromIntegral (B.head restBS) :: Int + wrapped = B.tail restBS + when (wrappedLen /= B.length wrapped) $ + Left + ( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length field " + ++ show wrappedLen + ++ " does not match body length " + ++ show (B.length wrapped) + ) + when (wrappedLen < 24 || wrappedLen `mod` 8 /= 0) $ + Left + ( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length " + ++ show wrappedLen + ++ " is not a valid RFC 3394 wrapped key size" + ) + pure (ephMPI NE.:| [MPI (os2ip wrapped)]) + + parserForLegacyPKESKMPIs :: PubKeyAlgorithm -> Get [MPI] + parserForLegacyPKESKMPIs pka = + case expectedLegacyPKESKMPIArity pka of + Just mpiCount -> replicateM mpiCount getMPI + Nothing -> some getMPI + + expectedLegacyPKESKMPIArity :: PubKeyAlgorithm -> Maybe Int + expectedLegacyPKESKMPIArity pka + | pka `elem` [RSA, DeprecatedRSAEncryptOnly] = Just 1 + | pka `elem` [ElgamalEncryptOnly, ForbiddenElgamal, ECDH, X25519] = + Just 2 + | otherwise = Nothing + + validateV4SKESKEncryptedSessionKeyS2K + :: S2K -> Maybe BL.ByteString -> Get () + validateV4SKESKEncryptedSessionKeyS2K _ Nothing = pure () + validateV4SKESKEncryptedSessionKeyS2K Simple {} (Just _) = + fail + "v4 SKESK packets with encrypted session keys must not use Simple S2K" + validateV4SKESKEncryptedSessionKeyS2K _ (Just _) = pure () + + parseV6PKESK :: BL.ByteString -> Either String Pkt + parseV6PKESK body = do + (_, _, (recipientKeyIdentifier, pka, esk)) <- + bimap (\(_, _, e) -> e) id $ + runGetOrFail + ( do + keyIdentifierLen <- getWord8 + recipientKeyIdentifier <- + getLazyByteString (fromIntegral keyIdentifierLen) + pka <- getWord8 + esk <- getRemainingLazyByteString + pure (recipientKeyIdentifier, pka, esk) + ) + body + validateV6PKESKRecipientIdentifier recipientKeyIdentifier + pure $ + PKESKPkt + ( PKESKPayloadV6Packet + (PKESKPayloadV6 recipientKeyIdentifier (toFVal pka) esk) + ) + where + validateV6PKESKRecipientIdentifier + :: BL.ByteString -> Either String () + validateV6PKESKRecipientIdentifier rid = + case BL.length rid of + 0 -> Right () + 20 -> Right () + 32 -> Right () + 21 -> validateVersionedFingerprint rid + 33 -> validateVersionedFingerprint rid + ridLen -> + Left + ( "invalid PKESK v6 recipient identifier length: " + ++ show ridLen + ++ " (expected 0, 20, 21, 32, or 33)" + ) + + validateVersionedFingerprint :: BL.ByteString -> Either String () + validateVersionedFingerprint rid = + let keyVersion = BL.head rid + fingerprintLen = BL.length (BL.tail rid) + in case keyVersion of + 4 -> + if fingerprintLen == 20 + then Right () + else + Left + ( "PKESK v6 recipient identifier length/version mismatch: key version 4 requires fingerprint length 20, got " + ++ show fingerprintLen + ) + 6 -> + if fingerprintLen == 32 + then Right () + else + Left + ( "PKESK v6 recipient identifier length/version mismatch: key version 6 requires fingerprint length 32, got " + ++ show fingerprintLen + ) + _ -> + Left + ( "invalid PKESK v6 recipient key version: " + ++ show keyVersion + ++ " (expected 4 or 6)" + ) + + getPkt' :: Word8 -> ByteOffset -> Get Pkt + getPkt' t len + | t == 1 = do + pv <- getWord8 + body <- getRemainingLazyByteString + if pv == 6 + then case parseV6PKESK body of + Right pkt -> return pkt + Left v6Err -> fail ("PKESK v6 parse failed: " ++ v6Err) + else case parseLegacyPKESK pv body of + Right pkt -> return pkt + Left legacyErr -> fail ("PKESK MPIs " ++ legacyErr) + | t == 2 = do + bs <- getRemainingLazyByteString + case runGetOrFail get bs of + Left (_, _, e) -> fail ("signature packet " ++ e) + Right (_, _, sp) -> return $ SignaturePkt sp + | t == 3 = do + pv <- getWord8 + let getV6SKESKParams = do + symalgoWord <- getWord8 + aeadWord <- getWord8 + s2kLen <- getWord8 + s2kBytes <- getLazyByteString (fromIntegral s2kLen) + s2k <- + case runGetOrFail getS2K s2kBytes of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> + fail "unexpected trailing bytes in v6 SKESK S2K specifier" + | otherwise -> pure parsed + let symalgo = toFVal symalgoWord + aead = toFVal aeadWord + ivLen = fromIntegral (aeadNonceSize aead) + iv <- getLazyByteString ivLen + pure (symalgo, aead, s2k, iv) + case pv of + 6 -> do + paramsLen <- getWord8 + params <- getLazyByteString (fromIntegral paramsLen) + (symalgo, aead, s2k, iv) <- + case runGetOrFail getV6SKESKParams params of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> + fail "unexpected trailing v6 SKESK parameters" + | otherwise -> pure parsed + payload <- getRemainingLazyByteString + when (BL.length payload < 16) $ + fail + "v6 SKESK payload must include encrypted session key and authentication tag" + let (esk, tag) = BL.splitAt (BL.length payload - 16) payload + return $ + SKESKPkt + ( SKESKPayloadV6Packet + ( SKESKPayloadV6 + symalgo + aead + s2k + iv + esk + tag + ) + ) + 4 -> do + symalgo <- getWord8 + s2k <- getS2K + esk <- getRemainingLazyByteString + let mesk = if BL.null esk then Nothing else Just esk + validateV4SKESKEncryptedSessionKeyS2K s2k mesk + return $ + SKESKPkt + ( SKESKPayloadV4Packet + ( SKESKPayloadV4 + (toFVal symalgo) + s2k + mesk + ) + ) + _ -> fail ("unsupported SKESK packet version " ++ show pv) + | t == 4 = do + pv <- getWord8 + sigtype <- toFVal <$> getWord8 + ha <- toFVal <$> getWord8 + pka <- toFVal <$> getWord8 + case pv of + 3 -> do + skeyid <- getLazyByteString 8 + nested <- getWord8 >>= parseOPSNestedFlag + return $ + OnePassSignaturePkt + ( OPSPayloadV3Packet + ( OPSPayloadV3 + pv + sigtype + ha + pka + (EightOctetKeyId skeyid) + nested + ) + ) + 6 -> do + saltSize <- getWord8 + expectedSaltSize <- + maybe + ( fail + ( "signature hash algorithm does not define a V6 salt size: " + ++ show ha + ) + ) + pure + (v6SaltSizeForHashAlgorithm ha) + when (saltSize /= expectedSaltSize) $ + fail + ( "OPS v6 salt size mismatch for " + ++ show ha + ++ ": expected " + ++ show expectedSaltSize + ++ ", got " + ++ show saltSize + ) + salt <- + SignatureSalt <$> getLazyByteString (fromIntegral saltSize) + signerFingerprint <- getLazyByteString 32 + nested <- getWord8 >>= parseOPSNestedFlag + return $ + OnePassSignaturePkt + ( OPSPayloadV6Packet + ( OPSPayloadV6 + sigtype + ha + pka + salt + signerFingerprint + nested + ) + ) + _ -> fail ("Unsupported OPS version: " ++ show pv) + | t == 5 = do + bs <- getLazyByteString len + let ps = + flip runGetOrFail bs $ do + pkp <- getPKPayload + ska <- getSKAddendum pkp + return $ SecretKeyPkt pkp ska + case ps of + Left (_, _, err) -> fail ("secret key " ++ err) + Right (_, _, pkt) -> return pkt + | t == 6 = do + pkp <- getPKPayload + return $ PublicKeyPkt pkp + | t == 7 = do + bs <- getLazyByteString len + let ps = + flip runGetOrFail bs $ do + pkp <- getPKPayload + ska <- getSKAddendum pkp + return $ SecretSubkeyPkt pkp ska + case ps of + Left (_, _, err) -> fail ("secret subkey " ++ err) + Right (_, _, pkt) -> return pkt + | t == 8 = do + ca <- getWord8 + cdata <- getLazyByteString (len - 1) + return $ CompressedDataPkt (toFVal ca) cdata + | t == 9 = do + sdata <- getLazyByteString len + return $ SymEncDataPkt sdata + | t == 10 = do + marker <- getLazyByteString len + return $ MarkerPkt marker + | t == 11 = do + dt <- getWord8 + flen <- getWord8 + fn <- getLazyByteString (fromIntegral flen) + ts <- fmap ThirtyTwoBitTimeStamp getWord32be + ldata <- getLazyByteString (len - (6 + fromIntegral flen)) + return $ LiteralDataPkt (toFVal dt) fn ts ldata + | t == 12 = do + tdata <- getLazyByteString len + return $ TrustPkt tdata + | t == 13 = do + udata <- getByteString (fromIntegral len) + return . UserIdPkt . decodeUtf8With lenientDecode $ udata + | t == 14 = do + bs <- getLazyByteString len + let ps = + flip runGetOrFail bs $ do + pkp <- getPKPayload + return $ PublicSubkeyPkt pkp + case ps of + Left (_, _, err) -> fail ("public subkey " ++ err) + Right (_, _, pkt) -> return pkt + | t == 17 = do + bs <- getLazyByteString len + case runGetOrFail (many getUserAttrSubPacket) bs of + Left (_, _, err) -> fail ("user attribute " ++ err) + Right (_, _, uas) -> return $ UserAttributePkt uas + | t == 18 = do + pv <- getWord8 + case pv of + 1 -> do + b <- getLazyByteString (len - 1) + return $ SymEncIntegrityProtectedDataPkt (SEIPD1 pv b) + 2 -> do + when (len < 36) $ + fail "SEIPD v2 packet too short" + symalgo <- toFVal <$> getWord8 + aeadalgo <- toFVal <$> getWord8 + chunkSize <- getWord8 + salt <- Salt <$> getByteString 32 + encrypted <- getLazyByteString (len - 36) + validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted + return $ + SymEncIntegrityProtectedDataPkt + ( SEIPD2 + symalgo + aeadalgo + chunkSize + salt + encrypted + ) + _ -> fail ("Unsupported SEIPD version: " ++ show pv) + | t == 19 = do + hash <- getLazyByteString 20 + return $ ModificationDetectionCodePkt hash + | t == 21 = do + payload <- getLazyByteString len + return $ PaddingPkt payload + | otherwise = do + payload <- getLazyByteString len + return $ OtherPacketPkt t payload + +getUserAttrSubPacket :: Get UserAttrSubPacket +getUserAttrSubPacket = do + l <- fmap fromIntegral getSubPacketLength + t <- getWord8 + getUserAttrSubPacket' t l + where + getUserAttrSubPacket' + :: Word8 -> ByteOffset -> Get UserAttrSubPacket + getUserAttrSubPacket' t l + | t == 1 = do + _ <- getWord16le -- ihlen + hver <- getWord8 -- should be 1 + iformat <- getWord8 + nuls <- getLazyByteString 12 -- should be NULs + bs <- getLazyByteString (l - 17) + if hver /= 1 || nuls /= BL.pack (replicate 12 0) + then fail "Corrupt UAt subpacket" + else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs + | otherwise = do + bs <- getLazyByteString (l - 1) + return $ OtherUASub t bs + +putUserAttrSubPacket :: UserAttrSubPacket -> Put +putUserAttrSubPacket ua = do + let sp = runPut $ putUserAttrSubPacket' ua + putSubPacketLength . fromIntegral . BL.length $ sp + putLazyByteString sp + where + putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do + putWord8 1 + putWord16le 16 + putWord8 1 + putWord8 (fromFVal iformat) + replicateM_ 12 $ putWord8 0 + putLazyByteString idata + putUserAttrSubPacket' (OtherUASub t bs) = do + putWord8 t + putLazyByteString bs + +{- | Serialize PKESKv3 session-key material. +For ECDH and X25519 the RFC 6637 §8 / RFC 9580 §5.1.6 wire format is used: +MPI(ephemeral_key) || 1-octet-count || wrapped_session_key_bytes. +All other algorithms use the standard MPI sequence. +-} +putPKESKv3SessionKeyMaterial + :: PubKeyAlgorithm -> NE.NonEmpty MPI -> Put +putPKESKv3SessionKeyMaterial pka mpis + | pka `elem` [ECDH, X25519] + , (ephMPI NE.:| [wrappedMPI]) <- mpis = do + put ephMPI + let rawWrapped = i2osp (unMPI wrappedMPI) + -- Left-pad to the nearest valid RFC 3394 wrapped-key length so that + -- leading-zero bytes stripped by i2osp are restored. + targetLen = + headDef + (B.length rawWrapped) + (filter (>= B.length rawWrapped) [32, 40, 48]) + paddedWrapped = leftPadTo targetLen rawWrapped + putWord8 (fromIntegral (B.length paddedWrapped)) + putByteString paddedWrapped + | otherwise = F.mapM_ put mpis + where + headDef d [] = d + headDef _ (x : _) = x + +putPkt :: Pkt -> Put +putPkt + ( PKESKPkt + (PKESKPayloadV3Packet (PKESKPayloadV3 pv eokeyid pka mpis)) + ) = do + putWord8 (0xc0 .|. 1) + let bsk = runPut $ putPKESKv3SessionKeyMaterial pka mpis + putPacketLength . fromIntegral $ 10 + BL.length bsk + putWord8 pv -- must be 3 + putLazyByteString (unEOKI eokeyid) -- must be 8 octets + putWord8 $ fromIntegral . fromFVal $ pka + putLazyByteString bsk +putPkt + ( PKESKPkt + ( PKESKPayloadV6Packet + (PKESKPayloadV6 recipientKeyIdentifier pka esk) + ) + ) = do + putWord8 (0xc0 .|. 1) + let keyIdentifierLen = BL.length recipientKeyIdentifier + when (keyIdentifierLen > 255) $ + error "PKESK v6 recipient key identifier must fit in one octet" + putPacketLength . fromIntegral $ + 3 + keyIdentifierLen + BL.length esk + putWord8 6 + putWord8 (fromIntegral keyIdentifierLen) + putLazyByteString recipientKeyIdentifier + putWord8 $ fromIntegral . fromFVal $ pka + putLazyByteString esk +putPkt (SignaturePkt sp) = do + putWord8 (0xc0 .|. 2) + let bs = runPut $ put sp + putLengthThenPayload bs +putPkt (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 symalgo s2k mesk))) = do + putWord8 (0xc0 .|. 3) + let bs2k = fromS2K s2k + let bsk = fromMaybe BL.empty mesk + putPacketLength . fromIntegral $ + 2 + BL.length bs2k + BL.length bsk + putWord8 4 + putWord8 $ fromIntegral . fromFVal $ symalgo + putLazyByteString bs2k + putLazyByteString bsk +putPkt + ( SKESKPkt + (SKESKPayloadV6Packet (SKESKPayloadV6 symalgo aead s2k iv esk tag)) + ) = do + putWord8 (0xc0 .|. 3) + let bs2k = fromS2K s2k + let params = + BL.pack + [ fromIntegral (fromFVal symalgo) + , fromIntegral (fromFVal aead) + , fromIntegral (BL.length bs2k) + ] + <> bs2k + <> iv + putPacketLength . fromIntegral $ + 2 + BL.length params + BL.length esk + BL.length tag + putWord8 6 + putWord8 (fromIntegral (BL.length params)) + putLazyByteString params + putLazyByteString esk + putLazyByteString tag +putPkt + ( OnePassSignaturePkt + (OPSPayloadV3Packet (OPSPayloadV3 pv sigtype ha pka skeyid nested)) + ) = do + putWord8 (0xc0 .|. 4) + let bs = + runPut $ do + putWord8 pv -- should be 3 + putWord8 $ fromIntegral . fromFVal $ sigtype + putWord8 $ fromIntegral . fromFVal $ ha + putWord8 $ fromIntegral . fromFVal $ pka + putLazyByteString (unEOKI skeyid) + putWord8 . fromIntegral . fromEnum $ not nested + putLengthThenPayload bs +putPkt + ( OnePassSignaturePkt + ( OPSPayloadV6Packet + (OPSPayloadV6 sigtype ha pka salt signerFingerprint nested) + ) + ) = do + putWord8 (0xc0 .|. 4) + let saltBytes = unSignatureSalt salt + saltSize = BL.length saltBytes + expectedSaltSize = + maybe + ( error + ( "signature hash algorithm does not define a V6 salt size: " + ++ show ha + ) + ) + id + (v6SaltSizeForHashAlgorithm ha) + when (fromIntegral saltSize /= expectedSaltSize) $ + error + ( "OPS v6 salt size mismatch for " + ++ show ha + ++ ": expected " + ++ show expectedSaltSize + ++ ", got " + ++ show saltSize + ) + when (BL.length signerFingerprint /= 32) $ + error "OPS v6 signer fingerprint must be exactly 32 octets" + let bs = + runPut $ do + putWord8 6 + putWord8 $ fromIntegral . fromFVal $ sigtype + putWord8 $ fromIntegral . fromFVal $ ha + putWord8 $ fromIntegral . fromFVal $ pka + putWord8 (fromIntegral saltSize) + putLazyByteString saltBytes + putLazyByteString signerFingerprint + putWord8 . fromIntegral . fromEnum $ not nested + putLengthThenPayload bs +putPkt (SecretKeyPkt pkp ska) = do + putWord8 (0xc0 .|. 5) + let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska) + putLengthThenPayload bs +putPkt (PublicKeyPkt pkp) = do + putWord8 (0xc0 .|. 6) + let bs = runPut $ putPKPayload pkp + putLengthThenPayload bs +putPkt (SecretSubkeyPkt pkp ska) = do + putWord8 (0xc0 .|. 7) + let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska) + putLengthThenPayload bs +putPkt (CompressedDataPkt ca cdata) = do + putWord8 (0xc0 .|. 8) + let bs = + runPut $ do + putWord8 $ fromIntegral . fromFVal $ ca + putLazyByteString cdata + putLengthThenPayload bs +putPkt (SymEncDataPkt b) = do + putWord8 (0xc0 .|. 9) + putLengthThenPayload b +putPkt (MarkerPkt b) = do + putWord8 (0xc0 .|. 10) + putLengthThenPayload b +putPkt (LiteralDataPkt dt fn ts b) = do + putWord8 (0xc0 .|. 11) + let bs = + runPut $ do + putWord8 $ fromIntegral . fromFVal $ dt + putWord8 $ fromIntegral . BL.length $ fn + putLazyByteString fn + putWord32be . unThirtyTwoBitTimeStamp $ ts + putLazyByteString b + putLengthThenPayload bs +putPkt (TrustPkt b) = do + putWord8 (0xc0 .|. 12) + putLengthThenPayload b +putPkt (UserIdPkt u) = do + putWord8 (0xc0 .|. 13) + let bs = encodeUtf8 u + putPacketLength . fromIntegral $ B.length bs + putByteString bs +putPkt (PublicSubkeyPkt pkp) = do + putWord8 (0xc0 .|. 14) + let bs = runPut $ putPKPayload pkp + putLengthThenPayload bs +putPkt (UserAttributePkt us) = do + putWord8 (0xc0 .|. 17) + let bs = runPut $ mapM_ put us + putLengthThenPayload bs +putPkt (SymEncIntegrityProtectedDataPkt (SEIPD1 pv b)) = do + putWord8 (0xc0 .|. 18) + putPacketLength . fromIntegral $ BL.length b + 1 + putWord8 pv -- should be 1 + putLazyByteString b +putPkt + ( SymEncIntegrityProtectedDataPkt + (SEIPD2 symalgo aeadalgo chunkSize salt b) + ) = do + when (B.length (unSalt salt) /= 32) $ + error "SEIPD v2 salt must be exactly 32 octets" + when (chunkSize > 16) $ + error "SEIPD v2 chunk size octet must be between 0 and 16" + case symalgo of + OtherSA _ -> error "SEIPD v2 requires a known symmetric algorithm" + Plaintext -> error "SEIPD v2 cannot use plaintext cipher" + _ -> return () + case aeadalgo of + OtherAEADAlgo _ -> error "SEIPD v2 requires a known AEAD algorithm" + _ -> return () + putWord8 (0xc0 .|. 18) + putPacketLength . fromIntegral $ BL.length b + 36 + putWord8 2 + putWord8 (fromFVal symalgo) + putWord8 (fromFVal aeadalgo) + putWord8 chunkSize + putByteString (unSalt salt) + putLazyByteString b +putPkt (ModificationDetectionCodePkt hash) = do + putWord8 (0xc0 .|. 19) + putLengthThenPayload hash +putPkt (PaddingPkt padding) = do + putWord8 (0xc0 .|. 21) + putLengthThenPayload padding +putPkt (OtherPacketPkt t payload) = do + when (t > 63) $ + error + ("cannot serialize OtherPacket packet tag > 63: " ++ show t) + putWord8 (0xc0 .|. t) + putLengthThenPayload payload +putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload) + +{- | Validate a packet before serialization to catch constraint violations early. +Returns Left with descriptive error if validation fails. +-} +validatePkt :: Pkt -> Either String () +validatePkt + ( PKESKPkt + (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier _ _)) + ) = do + let keyIdentifierLen = BL.length recipientKeyIdentifier + when (keyIdentifierLen > 255) $ + Left + "PKESK v6 recipient key identifier must fit in one octet (max 255 bytes)" + Right () +validatePkt + ( OnePassSignaturePkt + (OPSPayloadV6Packet (OPSPayloadV6 _ ha _ salt signerFingerprint _)) + ) = do + let saltBytes = unSignatureSalt salt + saltSize = BL.length saltBytes + expectedSaltSize <- + case v6SaltSizeForHashAlgorithm ha of + Nothing -> + Left $ + "signature hash algorithm does not define a V6 salt size: " + ++ show ha + Just sz -> Right sz + when (fromIntegral saltSize /= expectedSaltSize) $ + Left + ( "OPS v6 salt size mismatch for " + ++ show ha + ++ ": expected " + ++ show expectedSaltSize + ++ ", got " + ++ show saltSize + ) + when (BL.length signerFingerprint /= 32) $ + Left "OPS v6 signer fingerprint must be exactly 32 octets" + Right () +validatePkt + ( SymEncIntegrityProtectedDataPkt + (SEIPD2 symalgo aeadalgo chunkSize salt _) + ) = do + when (B.length (unSalt salt) /= 32) $ + Left "SEIPD v2 salt must be exactly 32 octets" + when (chunkSize > 16) $ + Left "SEIPD v2 chunk size octet must be between 0 and 16" + case symalgo of + OtherSA _ -> Left "SEIPD v2 requires a known symmetric algorithm" + Plaintext -> Left "SEIPD v2 cannot use plaintext cipher" + _ -> Right () + case aeadalgo of + OtherAEADAlgo _ -> Left "SEIPD v2 requires a known AEAD algorithm" + _ -> Right () +validatePkt (OtherPacketPkt t _) = do + when (t > 63) $ + Left ("cannot serialize OtherPacket packet tag > 63: " ++ show t) + Right () +validatePkt _ = Right () + +{- | Serialize a packet with explicit validation and error handling. +Validates constraints before calling putPkt to ensure errors are caught early. +-} +putPktEither :: Pkt -> Either String Put +putPktEither pkt = case validatePkt pkt of + Left err -> Left err + Right () -> Right (putPkt pkt) + +putLengthThenPayload :: ByteString -> Put +putLengthThenPayload bs = do + let len = BL.length bs + if len < fromIntegral (0x100000000 :: Integer) + then do + putPacketLength (fromIntegral len) + putLazyByteString bs + else putPartialLengthPayload bs + where + maxPartialChunkSize :: Int64 + maxPartialChunkSize = 1 `shiftL` (30 :: Int) + putPartialLengthPayload :: ByteString -> Put + putPartialLengthPayload payload + | BL.length payload > maxPartialChunkSize = do + let (chunk, rest) = BL.splitAt maxPartialChunkSize payload + putPartialLength 30 + putLazyByteString chunk + putPartialLengthPayload rest + | otherwise = do + putPacketLength (fromIntegral (BL.length payload)) + putLazyByteString payload + +validateSEIPDv2Header + :: SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> ByteString + -> Get () +validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted = do + when (chunkSize > 16) $ + fail "SEIPD v2 chunk size octet must be between 0 and 16" + when (BL.null encrypted) $ + fail + "SEIPD v2 payload is missing encrypted data and final authentication tag" + case symalgo of + OtherSA _ -> fail "SEIPD v2 requires a known symmetric algorithm" + Plaintext -> fail "SEIPD v2 cannot use plaintext cipher" + _ -> return () + case aeadalgo of + OtherAEADAlgo _ -> fail "SEIPD v2 requires a known AEAD algorithm" + _ -> return () + +getMPI :: Get MPI +getMPI = do + mpilen <- getWord16be + bs <- getByteString (fromIntegral (mpilen + 7) `div` 8) + return $ MPI (os2ip bs) + +getPubkey :: PubKeyAlgorithm -> Get PKey +getPubkey RSA = do + MPI n <- get + MPI e <- get + return $ + RSAPubKey + ( RSA_PublicKey + (R.PublicKey (fromIntegral . B.length . i2osp $ n) n e) + ) +getPubkey DeprecatedRSAEncryptOnly = getPubkey RSA +getPubkey DeprecatedRSASignOnly = getPubkey RSA +getPubkey DSA = do + MPI p <- get + MPI q <- get + MPI g <- get + MPI y <- get + return $ + DSAPubKey (DSA_PublicKey (D.PublicKey (D.Params p g q) y)) +getPubkey ElgamalEncryptOnly = getPubkey ForbiddenElgamal +getPubkey ForbiddenElgamal = do + MPI p <- get + MPI g <- get + MPI y <- get + return $ ElGamalPubKey p g y +getPubkey ECDSA = do + curvelength <- getWord8 + when (curvelength == 0 || curvelength == 0xff) $ + fail "invalid ECC curve OID length octet (reserved value)" + curveoid <- getByteString (fromIntegral curvelength) + MPI mpi <- getMPI + case curveoidBSToCurve curveoid of + Left e -> fail e + Right Curve25519 -> + EdDSAPubKey P.EdSigningCurve25519 + <$> ( PrefixedNativeEPoint + <$> validatePrefixedNativePoint 32 "Curve25519Legacy" mpi + ) + Right curve -> + case bs2Point (i2osp mpi) of + Left e -> fail e + Right point -> + return + . ECDSAPubKey + . ECDSA_PublicKey + . ECDSA.PublicKey (curve2Curve curve) + $ point +getPubkey ECDH = do + ed <- getPubkey ECDSA -- could be an ECDSA or an EdDSA + kdflen <- getWord8 + when (kdflen == 0 || kdflen == 0xff) $ + fail "invalid ECDH KDF field length octet (reserved value)" + when (kdflen /= 3) $ + fail ("invalid ECDH KDF field length: " ++ show kdflen) + one <- getWord8 + when (one /= 1) $ + fail ("invalid ECDH KDF reserved octet: " ++ show one) + kdfHA <- get + kdfSA <- get + return $ ECDHPubKey ed kdfHA kdfSA +getPubkey EdDSA = do + curvelength <- getWord8 + when (curvelength == 0 || curvelength == 0xff) $ + fail "invalid EdDSA curve OID length octet (reserved value)" + curveoid <- getByteString (fromIntegral curvelength) + MPI mpi <- getMPI + case curveoidBSToEdSigningCurve curveoid of + Left e -> fail e + Right P.EdSigningCurve25519 -> + EdDSAPubKey P.EdSigningCurve25519 + <$> ( PrefixedNativeEPoint + <$> validatePrefixedNativePoint 32 "Ed25519Legacy" mpi + ) + Right P.EdSigningCurve448 -> + EdDSAPubKey P.EdSigningCurve448 + <$> ( PrefixedNativeEPoint + <$> validatePrefixedNativePoint 57 "Ed448Legacy" mpi + ) +getPubkey pka + | pka == BTypes.Ed25519 = + parseFixedLengthOrLegacyPubkey + 32 + ( EdDSAPubKey P.EdSigningCurve25519 + . NativeEPoint + . EPoint + . os2ip + . BL.toStrict + ) + (getPubkey EdDSA) +getPubkey pka + | pka == BTypes.Ed448 = + parseFixedLengthOrLegacyPubkey + 57 + ( EdDSAPubKey P.EdSigningCurve448 + . NativeEPoint + . EPoint + . os2ip + . BL.toStrict + ) + (getPubkey EdDSA) +getPubkey X25519 = + parseFixedLengthOrLegacyPubkey + 32 + ( EdDSAPubKey P.EdSigningCurve25519 + . NativeEPoint + . EPoint + . os2ip + . BL.toStrict + ) + (getPubkey ECDH) +getPubkey X448 = + parseFixedLengthOrLegacyPubkey + 56 + ( EdDSAPubKey P.EdSigningCurve448 + . NativeEPoint + . EPoint + . os2ip + . BL.toStrict + ) + (getPubkey ECDH) +getPubkey MLKEM768X25519 = MLKEMPubKey . BL.toStrict <$> getRemainingLazyByteString +getPubkey MLKEM1024X448 = MLKEMPubKey . BL.toStrict <$> getRemainingLazyByteString +getPubkey MLDSA65Ed25519 = MLDSAPubKey . BL.toStrict <$> getRemainingLazyByteString +getPubkey MLDSA87Ed448 = MLDSAPubKey . BL.toStrict <$> getRemainingLazyByteString +getPubkey SLHDSASHAKE128s = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString +getPubkey SLHDSASHAKE128f = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString +getPubkey SLHDSASHAKE256s = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString +getPubkey _ = UnknownPKey <$> getRemainingLazyByteString + +parseFixedLengthOrLegacyPubkey + :: Int64 -> (BL.ByteString -> PKey) -> Get PKey -> Get PKey +parseFixedLengthOrLegacyPubkey expectedLen decodeFixed legacyParser = do + remaining <- lookAhead getRemainingLazyByteString + if BL.length remaining == expectedLen + then decodeFixed <$> getLazyByteString expectedLen + else legacyParser + +getPubkeyV6 :: PubKeyAlgorithm -> Get PKey +getPubkeyV6 pka + | pka == BTypes.Ed25519 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + when (B.length bs /= 32) $ + fail "invalid v6 Ed25519 public key length" + return $ + EdDSAPubKey + P.EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip bs))) + | pka == BTypes.Ed448 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + when (B.length bs /= 57) $ + fail "invalid v6 Ed448 public key length" + return $ + EdDSAPubKey + P.EdSigningCurve448 + (NativeEPoint (EPoint (os2ip bs))) + | pka == BTypes.X25519 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + when (B.length bs /= 32) $ + fail "invalid v6 X25519 public key length" + return $ + EdDSAPubKey + P.EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip bs))) + | pka == BTypes.X448 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + when (B.length bs /= 56) $ + fail "invalid v6 X448 public key length" + return $ + EdDSAPubKey + P.EdSigningCurve448 + (NativeEPoint (EPoint (os2ip bs))) + | pka == MLKEM768X25519 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + return $ MLKEMPubKey bs + | pka == MLKEM1024X448 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + return $ MLKEMPubKey bs + | pka == MLDSA65Ed25519 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + return $ MLDSAPubKey bs + | pka == MLDSA87Ed448 = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + return $ MLDSAPubKey bs + | pka == SLHDSASHAKE128s = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + return $ SLHDSAPubKey bs + | pka == SLHDSASHAKE128f = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + return $ SLHDSAPubKey bs + | pka == SLHDSASHAKE256s = do + len <- getWord32be + bs <- getByteString (fromIntegral len) + return $ SLHDSAPubKey bs + | otherwise = getPubkey pka + +bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint +bs2Point bs = + if B.null bs + then Left "empty EC point encoding" + else + let xy = B.drop 1 bs + l = B.length xy + in if B.head bs /= 0x04 + then Left $ "unknown type of point: " ++ show (B.unpack bs) + else + if odd l + then + Left "malformed EC point encoding: odd coordinate payload length" + else + return + ( uncurry + ECCT.Point + ((os2ip *** os2ip) (B.splitAt (div l 2) xy)) + ) + +putPubkey :: PKey -> Put +putPubkey (UnknownPKey bs) = putLazyByteString bs +putPubkey (MLKEMPubKey bs) = putLazyByteString (BL.fromStrict bs) +putPubkey (MLDSAPubKey bs) = putLazyByteString (BL.fromStrict bs) +putPubkey (SLHDSAPubKey bs) = putLazyByteString (BL.fromStrict bs) +putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) = + let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) + in putCurveOID curveoidbs + >> mapM_ put (pubkeyToMPIs p) +putPubkey + p@( ECDHPubKey + (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) + kha + ksa + ) = + let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) + in putCurveOID curveoidbs + >> mapM_ put (pubkeyToMPIs p) + >> putECDHKDFParams kha ksa +putPubkey p@(ECDHPubKey (EdDSAPubKey curve (PrefixedNativeEPoint _)) kha ksa) = + let Right curveoidbs = curveToCurveoidBS (ed2ec curve) + in putCurveOID curveoidbs + >> mapM_ put (pubkeyToMPIs p) + >> putECDHKDFParams kha ksa + where + ed2ec P.EdSigningCurve25519 = Curve25519 + ed2ec P.EdSigningCurve448 = Curve448 +putPubkey p@(EdDSAPubKey curve (PrefixedNativeEPoint _)) = + let Right curveoidbs = edSigningCurveToCurveoidBS curve + in putCurveOID curveoidbs + >> mapM_ put (pubkeyToMPIs p) +putPubkey (ECDHPubKey (EdDSAPubKey curve (NativeEPoint _)) _ _) = + error + ( "legacy ECDH serialization requires a prefixed-native " + ++ show curve + ++ " point" + ) +putPubkey (EdDSAPubKey curve (NativeEPoint _)) = + error + ( "legacy EdDSA serialization requires a prefixed-native " + ++ show curve + ++ " point" + ) +putPubkey p = mapM_ put (pubkeyToMPIs p) + +putPubkeyV6 :: PKey -> Put +putPubkeyV6 (EdDSAPubKey P.EdSigningCurve25519 (NativeEPoint (EPoint x))) = do + let bs = fixedLengthOctets 32 x + putWord32be . fromIntegral . B.length $ bs + putByteString bs +putPubkeyV6 (EdDSAPubKey P.EdSigningCurve448 (NativeEPoint (EPoint x))) = do + let bs = fixedLengthOctets 57 x + putWord32be . fromIntegral . B.length $ bs + putByteString bs +putPubkeyV6 + ( ECDHPubKey + (EdDSAPubKey P.EdSigningCurve25519 (NativeEPoint (EPoint x))) + kha + ksa + ) = do + let bs = fixedLengthOctets 32 x + putWord32be . fromIntegral . B.length $ bs + putByteString bs + put kha + put ksa +putPubkeyV6 + ( ECDHPubKey + (EdDSAPubKey P.EdSigningCurve448 (NativeEPoint (EPoint x))) + kha + ksa + ) = do + let bs = fixedLengthOctets 56 x + putWord32be . fromIntegral . B.length $ bs + putByteString bs + put kha + put ksa +putPubkeyV6 (MLKEMPubKey bs) = do + putWord32be . fromIntegral . B.length $ bs + putByteString bs +putPubkeyV6 (MLDSAPubKey bs) = do + putWord32be . fromIntegral . B.length $ bs + putByteString bs +putPubkeyV6 (SLHDSAPubKey bs) = do + putWord32be . fromIntegral . B.length $ bs + putByteString bs +putPubkeyV6 p = putPubkey p + +fixedLengthOctets :: Int -> Integer -> B.ByteString +fixedLengthOctets targetLen x = + let bs = i2osp x + in if B.length bs > targetLen + then + error + ( "public key element does not fit in " + ++ show targetLen + ++ " octets" + ) + else B.replicate (targetLen - B.length bs) 0 <> bs + +validatePrefixedNativePoint + :: Int -> String -> Integer -> Get EPoint +validatePrefixedNativePoint targetLen label i = + let bs = i2osp i + in if B.length bs /= targetLen + 1 + then + fail + ( "invalid " + ++ label + ++ " public key length: expected " + ++ show (targetLen + 1) + ++ " octets with 0x40 prefix, got " + ++ show (B.length bs) + ) + else + if B.head bs /= 0x40 + then + fail ("invalid " ++ label ++ " public key: missing 0x40 prefix") + else pure (EPoint i) + +putCurveOID :: B.ByteString -> Put +putCurveOID oid = do + let oidLength = B.length oid + when (oidLength == 0 || oidLength == 0xff) $ + error "curve OID length cannot use reserved values 0 or 255" + putWord8 (fromIntegral oidLength) + putByteString oid + +putECDHKDFParams :: HashAlgorithm -> SymmetricAlgorithm -> Put +putECDHKDFParams kdfHA kdfSA = do + let kdfLengthOctet = 0x03 + when (kdfLengthOctet == 0 || kdfLengthOctet == 0xff) $ + error "ECDH KDF field length cannot use reserved values 0 or 255" + putWord8 kdfLengthOctet + putWord8 0x01 + put kdfHA + put kdfSA + +parseOPSNestedFlag :: Word8 -> Get NestedFlag +parseOPSNestedFlag 0 = pure True +parseOPSNestedFlag 1 = pure False +parseOPSNestedFlag other = + fail ("invalid OPS nested flag octet: " ++ show other) + +getSecretKey :: SomePKPayload -> Get SKey +getSecretKey pkp + | _pkalgo pkp + `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do + MPI d <- get + MPI p <- get + MPI q <- get + MPI _ <- get -- u + case inverse q p of + Nothing -> fail "invalid RSA secret key: q has no inverse modulo p" + Just qinv -> do + let dP = d `mod` (p - 1) + dQ = d `mod` (q - 1) + pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (_pubkey pkp) + return $ + RSAPrivateKey + (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv)) + | _pkalgo pkp == DSA = do + MPI x <- get + return $ + DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x)) + | _pkalgo pkp `elem` [ElgamalEncryptOnly, ForbiddenElgamal] = do + MPI x <- get + return $ ElGamalPrivateKey x + | _pkalgo pkp == ECDSA = do + let pubcurve = + (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p) + (_pubkey pkp) + getECDSAScalarPrivateKey pubcurve + | _pkalgo pkp == ECDH = + do + pubcurve <- ecdhPrivateCurveFromPKPayload pkp + getECDHScalarPrivateKey pubcurve + | _pkalgo pkp == X25519 = do + if _keyVersion pkp == V6 + then do + sk <- getByteString 32 + return $ X25519PrivateKey sk + else do + pubcurve <- ecdhPrivateCurveFromPKPayload pkp + getECDHScalarPrivateKey pubcurve + | _pkalgo pkp == X448 = do + if _keyVersion pkp == V6 + then do + sk <- getByteString 56 + return $ X448PrivateKey sk + else UnknownSKey <$> getRemainingLazyByteString + | _pkalgo pkp == EdDSA = do + if _keyVersion pkp == V6 + then do + case _pubkey pkp of + EdDSAPubKey P.EdSigningCurve25519 _ -> EdDSAPrivateKey P.EdSigningCurve25519 <$> getByteString 32 + EdDSAPubKey P.EdSigningCurve448 _ -> EdDSAPrivateKey P.EdSigningCurve448 <$> getByteString 57 + _ -> UnknownSKey <$> getRemainingLazyByteString + else do + MPI x <- get + case _pubkey pkp of + EdDSAPubKey P.EdSigningCurve25519 _ -> + return $ + EdDSAPrivateKey P.EdSigningCurve25519 (leftPadTo 32 (i2osp x)) + EdDSAPubKey P.EdSigningCurve448 _ -> + return $ + EdDSAPrivateKey P.EdSigningCurve448 (leftPadTo 57 (i2osp x)) + _ -> return $ UnknownSKey (BL.fromStrict (i2osp x)) + | _pkalgo pkp `elem` [MLKEM768X25519, MLKEM1024X448] = do + if _keyVersion pkp == V6 + then do + len <- getWord32be + bs <- getByteString (fromIntegral len) + return $ MLKEMPrivateKey bs + else UnknownSKey <$> getRemainingLazyByteString + | _pkalgo pkp `elem` [MLDSA65Ed25519, MLDSA87Ed448] = do + if _keyVersion pkp == V6 + then do + len <- getWord32be + bs <- getByteString (fromIntegral len) + return $ MLDSAPrivateKey bs + else UnknownSKey <$> getRemainingLazyByteString + | _pkalgo pkp + `elem` [SLHDSASHAKE128s, SLHDSASHAKE128f, SLHDSASHAKE256s] = do + if _keyVersion pkp == V6 + then do + len <- getWord32be + bs <- getByteString (fromIntegral len) + return $ SLHDSAPrivateKey bs + else UnknownSKey <$> getRemainingLazyByteString + | otherwise = UnknownSKey <$> getRemainingLazyByteString + +getECDSAScalarPrivateKey :: ECCT.Curve -> Get SKey +getECDSAScalarPrivateKey curve = do + MPI pn <- get + pure $ + ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn)) + +getECDHScalarPrivateKey :: ECCT.Curve -> Get SKey +getECDHScalarPrivateKey curve = do + MPI pn <- get + pure $ + ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn)) + +ecdhPrivateCurveFromPKPayload :: SomePKPayload -> Get ECCT.Curve +ecdhPrivateCurveFromPKPayload pkp = + case _pubkey pkp of + ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey p)) _ _ -> + pure (ECDSA.public_curve p) + ECDHPubKey (EdDSAPubKey P.EdSigningCurve25519 _) _ _ -> + pure (curve2Curve Curve25519) + ECDHPubKey (EdDSAPubKey P.EdSigningCurve448 _) _ _ -> + pure (curve2Curve Curve448) + other -> + fail + ( "ECDH/X25519 secret key requires an ECDH public key packet, got " + ++ show other + ) + +putSKey :: SKey -> Either String Put +putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) = + case inverse q p of + Just u -> + Right (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)) + Nothing -> + Left + "putSKey: invalid RSA key — q has no multiplicative inverse mod p (key is mathematically broken)" +putSKey (DSAPrivateKey (DSA_PrivateKey (D.PrivateKey _ x))) = + Right (put (MPI x)) +putSKey (ElGamalPrivateKey x) = + Right (put (MPI x)) +putSKey (ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) = + Right (put (MPI d)) +putSKey (ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) = + Right (put (MPI d)) +putSKey (EdDSAPrivateKey P.EdSigningCurve25519 sk) = Right (putByteString sk) +putSKey (EdDSAPrivateKey P.EdSigningCurve448 sk) = Right (putByteString sk) +putSKey (X25519PrivateKey sk) = Right (putByteString sk) +putSKey (X448PrivateKey sk) = Right (putByteString sk) +putSKey (MLKEMPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk)) +putSKey (MLDSAPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk)) +putSKey (SLHDSAPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk)) +putSKey (UnknownSKey bs) = Right (putLazyByteString bs) + +putSKeyForPKPayload :: SomePKPayload -> SKey -> Either String Put +putSKeyForPKPayload pkp sk@(EdDSAPrivateKey _ bs) + | _keyVersion pkp == V6 = putSKey sk + | otherwise = Right (put (MPI (os2ip bs))) +putSKeyForPKPayload _ sk = putSKey sk + +putMPI :: MPI -> Put +putMPI (MPI i) = do + let bs = i2osp i + putWord16be . fromIntegral . numBits $ i + putByteString bs + +data PKPayloadReadCase where + PKPayloadReadCaseV3 + :: V3Expiration -> PubKeyAlgorithm -> PKPayloadReadCase + PKPayloadReadCaseV4 :: PubKeyAlgorithm -> PKPayloadReadCase + PKPayloadReadCaseV6 :: PubKeyAlgorithm -> PKPayloadReadCase + +pkPayloadReadCase :: Word8 -> Get PKPayloadReadCase +pkPayloadReadCase version = + case version of + 2 -> do + v3e <- getWord16be + pka <- get + pure (PKPayloadReadCaseV3 v3e pka) + 3 -> do + v3e <- getWord16be + pka <- get + pure (PKPayloadReadCaseV3 v3e pka) + 4 -> PKPayloadReadCaseV4 <$> get + 6 -> PKPayloadReadCaseV6 <$> get + _ -> fail ("unsupported key packet version " ++ show version) + +getPKPayload :: Get SomePKPayload +getPKPayload = do + version <- getWord8 + ctime <- fmap ThirtyTwoBitTimeStamp getWord32be + readCase <- pkPayloadReadCase version + case readCase of + PKPayloadReadCaseV3 v3e pka -> do + pk <- getPubkey pka + pure $! PKPayload DeprecatedV3 ctime v3e pka pk + PKPayloadReadCaseV4 pka -> do + pk <- getPubkey pka + pure $! PKPayload V4 ctime 0 pka pk + PKPayloadReadCaseV6 pka -> do + pk <- getPubkeyV6 pka + pure $! PKPayload V6 ctime 0 pka pk + +data PKPayloadWriteCase where + PKPayloadWriteCaseV3 + :: PKPayload 'DeprecatedV3 -> PKPayloadWriteCase + PKPayloadWriteCaseV4 :: PKPayload 'V4 -> PKPayloadWriteCase + PKPayloadWriteCaseV6 :: PKPayload 'V6 -> PKPayloadWriteCase + +pkPayloadWriteCase :: SomePKPayload -> PKPayloadWriteCase +pkPayloadWriteCase (SomePKPayload pkp) = + case pkp of + PKPayloadV3 {} -> PKPayloadWriteCaseV3 pkp + PKPayloadV4 {} -> PKPayloadWriteCaseV4 pkp + PKPayloadV6 {} -> PKPayloadWriteCaseV6 pkp + +putPKPayload :: SomePKPayload -> Put +putPKPayload pkpSome = + case pkPayloadWriteCase pkpSome of + PKPayloadWriteCaseV3 (PKPayloadV3 ctime v3e pka pk) -> do + putWord8 3 + putWord32be . unThirtyTwoBitTimeStamp $ ctime + putWord16be v3e + put pka + putPubkey pk + PKPayloadWriteCaseV4 (PKPayloadV4 ctime pka pk) -> do + putWord8 4 + putWord32be . unThirtyTwoBitTimeStamp $ ctime + put pka + putPubkeyV4ForAlgorithm pka pk + PKPayloadWriteCaseV6 (PKPayloadV6 ctime pka pk) -> do + putWord8 6 + putWord32be . unThirtyTwoBitTimeStamp $ ctime + put pka + putPubkeyV6 pk + +putPubkeyV4ForAlgorithm :: PubKeyAlgorithm -> PKey -> Put +putPubkeyV4ForAlgorithm pka pk + | pka == BTypes.Ed25519 = + putPubkeyV4Fixed 32 P.EdSigningCurve25519 pk + | pka == BTypes.Ed448 = + putPubkeyV4Fixed 57 P.EdSigningCurve448 pk + | pka == BTypes.X25519 = + putPubkeyV4Fixed 32 P.EdSigningCurve25519 pk + | pka == BTypes.X448 = putPubkeyV4Fixed 56 P.EdSigningCurve448 pk + | otherwise = putPubkey pk + +putPubkeyV4Fixed :: Int -> P.EdSigningCurve -> PKey -> Put +putPubkeyV4Fixed targetLen expectedCurve (EdDSAPubKey curve (NativeEPoint (EPoint x))) + | curve == expectedCurve = + putByteString (fixedLengthOctets targetLen x) +putPubkeyV4Fixed _ _ pk = putPubkey pk + +getSKAddendum :: SomePKPayload -> Get SKAddendum +getSKAddendum (SomePKPayload pkp) = + toSKAddendum <$> getSKAddendumTyped pkp + +getSKAddendumTyped :: PKPayload v -> Get (SKAddendumV v) +getSKAddendumTyped pkp = do + s2kusage <- getWord8 + let pkpSome = SomePKPayload pkp + getLegacyS2KProtected constructor = do + symencWord <- getWord8 + s2k <- getS2K + let symenc = toFVal symencWord + case s2k of + OtherS2K _ _ -> return $ constructor symenc s2k mempty BL.empty + _ -> do + blockSize <- either fail pure (symEncBlockSize symenc) + iv <- IV <$> getByteString blockSize + encryptedblock <- getRemainingLazyByteString + return $ constructor symenc s2k iv encryptedblock + case s2kusage of + 0 -> + case pkp of + PKPayloadV6 {} -> do + sk <- getSecretKey pkpSome + return (SKAUnencryptedV6 sk) + PKPayloadV3 {} -> do + rest <- lookAhead getRemainingLazyByteString + secretLen <- + case runGetOrFail + ( do + start <- bytesRead + _ <- getSecretKey pkpSome + end <- bytesRead + pure (end - start) + ) + rest of + Left (_, _, err) -> fail err + Right (_, _, len) -> pure len + sk <- getSecretKey pkpSome + checksum <- getWord16be + let expectedChecksum = + checksum16Bytes (BL.toStrict (BL.take secretLen rest)) + when (checksum /= expectedChecksum) $ + fail + ( "legacy unencrypted secret-key checksum mismatch: expected " + ++ show expectedChecksum + ++ ", got " + ++ show checksum + ) + return (SKAUnencryptedLegacy sk checksum) + PKPayloadV4 {} -> do + rest <- lookAhead getRemainingLazyByteString + secretLen <- + case runGetOrFail + ( do + start <- bytesRead + _ <- getSecretKey pkpSome + end <- bytesRead + pure (end - start) + ) + rest of + Left (_, _, err) -> fail err + Right (_, _, len) -> pure len + sk <- getSecretKey pkpSome + checksum <- getWord16be + let expectedChecksum = + checksum16Bytes (BL.toStrict (BL.take secretLen rest)) + when (checksum /= expectedChecksum) $ + fail + ( "legacy unencrypted secret-key checksum mismatch: expected " + ++ show expectedChecksum + ++ ", got " + ++ show checksum + ) + return (SKAUnencryptedLegacy sk checksum) + 255 -> + case pkp of + PKPayloadV6 {} -> + fail "v6 secret key packets MUST NOT use s2k usage 255" + PKPayloadV3 {} -> + getLegacyS2KProtected SKA16bit + PKPayloadV4 {} -> + getLegacyS2KProtected SKA16bit + 254 -> + case pkp of + PKPayloadV6 {} -> do + paramsLen <- getWord8 + params <- getLazyByteString (fromIntegral paramsLen) + (symenc, s2k, iv) <- + case runGetOrFail getV6CFBParams params of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> + fail "unexpected trailing v6 CFB parameters" + | otherwise -> pure parsed + encryptedblock <- getRemainingLazyByteString + return (SKASHA1V6 symenc s2k (IV iv) encryptedblock) + PKPayloadV3 {} -> + getLegacyS2KProtected SKASHA1Legacy + PKPayloadV4 {} -> + getLegacyS2KProtected SKASHA1Legacy + where + getV6CFBParams = do + symencWord <- getWord8 + s2kLen <- getWord8 + s2kBytes <- getLazyByteString (fromIntegral s2kLen) + s2k <- + case runGetOrFail getS2K s2kBytes of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> + fail "unexpected trailing bytes in v6 S2K specifier" + | otherwise -> pure parsed + iv <- getRemainingLazyByteString + let symenc = toFVal symencWord + blockSize <- either fail pure (symEncBlockSize symenc) + when (BL.length iv /= fromIntegral blockSize) $ + fail "invalid v6 CFB IV length" + pure (symenc, s2k, BL.toStrict iv) + 253 -> + case pkp of + PKPayloadV6 {} -> do + paramsLen <- getWord8 + params <- getLazyByteString (fromIntegral paramsLen) + (symenc, aead, s2k, iv) <- + case runGetOrFail getV6AEADParams params of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> + fail "unexpected trailing v6 AEAD parameters" + | otherwise -> pure parsed + encryptedblock <- getRemainingLazyByteString + return (SKAAEADV6 symenc aead s2k (IV iv) encryptedblock) + PKPayloadV3 {} -> do + (symenc, aead, s2k, iv) <- getLegacyAEADParams + encryptedblock <- getRemainingLazyByteString + return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock) + PKPayloadV4 {} -> do + (symenc, aead, s2k, iv) <- getLegacyAEADParams + encryptedblock <- getRemainingLazyByteString + return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock) + where + getV6AEADParams + :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString) + getV6AEADParams = do + symencWord <- getWord8 + aeadWord <- getWord8 + s2kLen <- getWord8 + s2kBytes <- getLazyByteString (fromIntegral s2kLen) + s2k <- + case runGetOrFail getS2K s2kBytes of + Left (_, _, err) -> fail err + Right (rest, _, parsed) + | not (BL.null rest) -> + fail "unexpected trailing bytes in v6 S2K specifier" + | otherwise -> pure parsed + iv <- getRemainingLazyByteString + let symenc = toFVal symencWord + aead = toFVal aeadWord + when (BL.length iv /= fromIntegral (aeadNonceSize aead)) $ + fail "invalid v6 AEAD IV length" + pure (symenc, aead, s2k, BL.toStrict iv) + -- v3/v4: no cumulative-params-length octet, no S2K-size octet + getLegacyAEADParams + :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString) + getLegacyAEADParams = do + symencWord <- getWord8 + aeadWord <- getWord8 + s2k <- getS2K + let aead = toFVal aeadWord + iv <- + BL.toStrict + <$> getLazyByteString (fromIntegral (aeadNonceSize aead)) + pure (toFVal symencWord, aead, s2k, iv) + symenc -> + case pkp of + PKPayloadV6 {} -> do + paramsLen <- getWord8 + iv <- getByteString (fromIntegral paramsLen) + let symencAlg = toFVal symenc + blockSize <- either fail pure (symEncBlockSize symencAlg) + when (B.length iv /= blockSize) $ + fail "invalid v6 CFB IV length" + encryptedblock <- getRemainingLazyByteString + return (SKASymV6 symencAlg (IV iv) encryptedblock) + PKPayloadV3 {} -> do + blockSize <- either fail pure (symEncBlockSize (toFVal symenc)) + iv <- getByteString blockSize + encryptedblock <- getRemainingLazyByteString + return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock) + PKPayloadV4 {} -> do + blockSize <- either fail pure (symEncBlockSize (toFVal symenc)) + iv <- getByteString blockSize + encryptedblock <- getRemainingLazyByteString + return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock) + +putSKAddendum :: SKAddendum -> Either String Put +putSKAddendum (SUS16bit symenc s2k iv encryptedblock) = + Right $ do + putWord8 255 + put symenc + put s2k + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = + Right $ do + putWord8 254 + put symenc + put s2k + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendum (SUSAEAD symenc aead s2k iv encryptedblock) = + Right $ do + putWord8 253 + put symenc + putWord8 (fromFVal aead) + put s2k + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendum (SUSym symenc iv encryptedblock) = + Right $ do + put symenc + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendum (SUUnencrypted sk checksum) = + do + putSecret <- putSKey sk + Right $ do + putWord8 0 + let skb = runPut putSecret + putLazyByteString skb + putWord16be + ( if checksum == 0 + then checksum16Bytes (BL.toStrict skb) + else checksum + ) + +checksum16Bytes :: B.ByteString -> Word16 +checksum16Bytes = + B.foldl' + ( \a b -> + fromIntegral + ((fromIntegral a + fromIntegral b) `mod` (65536 :: Integer)) + ) + 0 + +putSKAddendumForPKPayload :: SomePKPayload -> SKAddendum -> Put +putSKAddendumForPKPayload pkp ska = + case fromSKAddendumForPKPayload pkp ska of + Left e -> error e + Right (SomeSKAddendumV skaV) -> + putSKAddendumForPKPayloadTyped pkp skaV + +putSKAddendumForPKPayloadTyped + :: SomePKPayload + -> SKAddendumV v + -> Put +putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedLegacy sk checksum) = do + putWord8 0 + let putSecret = + case putSKeyForPKPayload pkp sk of + Left err -> error err + Right p -> p + skb = runPut putSecret + putLazyByteString skb + putWord16be + ( if checksum == 0 + then + BL.foldl + (\a b -> mod (a + fromIntegral b) 0xffff) + (0 :: Word16) + skb + else checksum + ) +putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedV6 sk) = do + putWord8 0 + let putSecret = + case putSKeyForPKPayload pkp sk of + Left err -> error err + Right p -> p + skb = runPut putSecret + putLazyByteString skb +putSKAddendumForPKPayloadTyped _ (SKASHA1V6 symenc s2k iv encryptedblock) = do + let s2kbs = runPut (put s2k) + paramsLen = 1 + 1 + BL.length s2kbs + fromIntegral (B.length (unIV iv)) + putWord8 254 + putWord8 (fromIntegral paramsLen) + put symenc + putWord8 (fromIntegral (BL.length s2kbs)) + putLazyByteString s2kbs + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendumForPKPayloadTyped _ (SKAAEADV6 symenc aead s2k iv encryptedblock) = do + let s2kbs = runPut (put s2k) + paramsLen = + 1 + 1 + 1 + BL.length s2kbs + fromIntegral (B.length (unIV iv)) + putWord8 253 + putWord8 (fromIntegral paramsLen) + put symenc + putWord8 (fromFVal aead) + putWord8 (fromIntegral (BL.length s2kbs)) + putLazyByteString s2kbs + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendumForPKPayloadTyped _ (SKAAEADLegacy symenc aead s2k iv encryptedblock) = do + putWord8 253 + put symenc + putWord8 (fromFVal aead) + put s2k + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendumForPKPayloadTyped _ (SKASymV6 symenc iv encryptedblock) = do + putWord8 (fromFVal symenc) + putWord8 (fromIntegral (B.length (unIV iv))) + putByteString (unIV iv) + putLazyByteString encryptedblock +putSKAddendumForPKPayloadTyped _ skaV = + case putSKAddendum (toSKAddendum skaV) of + Left e -> error e + Right p -> p + +aeadNonceSize :: AEADAlgorithm -> Int +aeadNonceSize EAX = 16 +aeadNonceSize OCB = 15 +aeadNonceSize GCM = 12 +aeadNonceSize (OtherAEADAlgo _) = 0 + +symEncBlockSize :: SymmetricAlgorithm -> Either String Int +symEncBlockSize Plaintext = Right 0 +symEncBlockSize IDEA = Right 8 +symEncBlockSize TripleDES = Right 8 +symEncBlockSize CAST5 = Right 8 +symEncBlockSize Blowfish = Right 8 +symEncBlockSize AES128 = Right 16 +symEncBlockSize AES192 = Right 16 +symEncBlockSize AES256 = Right 16 +symEncBlockSize Twofish = Right 16 +symEncBlockSize Camellia128 = Right 16 +symEncBlockSize Camellia192 = Right 16 +symEncBlockSize Camellia256 = Right 16 +symEncBlockSize sa = + Left + ( "unsupported symmetric algorithm for secret-key IV sizing: " + ++ show sa + ) + +decodeIterationCount :: Word8 -> IterationCount +decodeIterationCount c = + IterationCount + ( (16 + (fromIntegral c .&. 15)) + `shiftL` ((fromIntegral c `shiftR` 4) + 6) + ) + +encodeIterationCount :: IterationCount -> Word8 -- should this really be a lookup table? +encodeIterationCount 1024 = 0 +encodeIterationCount 1088 = 1 +encodeIterationCount 1152 = 2 +encodeIterationCount 1216 = 3 +encodeIterationCount 1280 = 4 +encodeIterationCount 1344 = 5 +encodeIterationCount 1408 = 6 +encodeIterationCount 1472 = 7 +encodeIterationCount 1536 = 8 +encodeIterationCount 1600 = 9 +encodeIterationCount 1664 = 10 +encodeIterationCount 1728 = 11 +encodeIterationCount 1792 = 12 +encodeIterationCount 1856 = 13 +encodeIterationCount 1920 = 14 +encodeIterationCount 1984 = 15 +encodeIterationCount 2048 = 16 +encodeIterationCount 2176 = 17 +encodeIterationCount 2304 = 18 +encodeIterationCount 2432 = 19 +encodeIterationCount 2560 = 20 +encodeIterationCount 2688 = 21 +encodeIterationCount 2816 = 22 +encodeIterationCount 2944 = 23 +encodeIterationCount 3072 = 24 +encodeIterationCount 3200 = 25 +encodeIterationCount 3328 = 26 +encodeIterationCount 3456 = 27 +encodeIterationCount 3584 = 28 +encodeIterationCount 3712 = 29 +encodeIterationCount 3840 = 30 +encodeIterationCount 3968 = 31 +encodeIterationCount 4096 = 32 +encodeIterationCount 4352 = 33 +encodeIterationCount 4608 = 34 +encodeIterationCount 4864 = 35 +encodeIterationCount 5120 = 36 +encodeIterationCount 5376 = 37 +encodeIterationCount 5632 = 38 +encodeIterationCount 5888 = 39 +encodeIterationCount 6144 = 40 +encodeIterationCount 6400 = 41 +encodeIterationCount 6656 = 42 +encodeIterationCount 6912 = 43 +encodeIterationCount 7168 = 44 +encodeIterationCount 7424 = 45 +encodeIterationCount 7680 = 46 +encodeIterationCount 7936 = 47 +encodeIterationCount 8192 = 48 +encodeIterationCount 8704 = 49 +encodeIterationCount 9216 = 50 +encodeIterationCount 9728 = 51 +encodeIterationCount 10240 = 52 +encodeIterationCount 10752 = 53 +encodeIterationCount 11264 = 54 +encodeIterationCount 11776 = 55 +encodeIterationCount 12288 = 56 +encodeIterationCount 12800 = 57 +encodeIterationCount 13312 = 58 +encodeIterationCount 13824 = 59 +encodeIterationCount 14336 = 60 +encodeIterationCount 14848 = 61 +encodeIterationCount 15360 = 62 +encodeIterationCount 15872 = 63 +encodeIterationCount 16384 = 64 +encodeIterationCount 17408 = 65 +encodeIterationCount 18432 = 66 +encodeIterationCount 19456 = 67 +encodeIterationCount 20480 = 68 +encodeIterationCount 21504 = 69 +encodeIterationCount 22528 = 70 +encodeIterationCount 23552 = 71 +encodeIterationCount 24576 = 72 +encodeIterationCount 25600 = 73 +encodeIterationCount 26624 = 74 +encodeIterationCount 27648 = 75 +encodeIterationCount 28672 = 76 +encodeIterationCount 29696 = 77 +encodeIterationCount 30720 = 78 +encodeIterationCount 31744 = 79 +encodeIterationCount 32768 = 80 +encodeIterationCount 34816 = 81 +encodeIterationCount 36864 = 82 +encodeIterationCount 38912 = 83 +encodeIterationCount 40960 = 84 +encodeIterationCount 43008 = 85 +encodeIterationCount 45056 = 86 +encodeIterationCount 47104 = 87 +encodeIterationCount 49152 = 88 +encodeIterationCount 51200 = 89 +encodeIterationCount 53248 = 90 +encodeIterationCount 55296 = 91 +encodeIterationCount 57344 = 92 +encodeIterationCount 59392 = 93 +encodeIterationCount 61440 = 94 +encodeIterationCount 63488 = 95 +encodeIterationCount 65536 = 96 +encodeIterationCount 69632 = 97 +encodeIterationCount 73728 = 98 +encodeIterationCount 77824 = 99 +encodeIterationCount 81920 = 100 +encodeIterationCount 86016 = 101 +encodeIterationCount 90112 = 102 +encodeIterationCount 94208 = 103 +encodeIterationCount 98304 = 104 +encodeIterationCount 102400 = 105 +encodeIterationCount 106496 = 106 +encodeIterationCount 110592 = 107 +encodeIterationCount 114688 = 108 +encodeIterationCount 118784 = 109 +encodeIterationCount 122880 = 110 +encodeIterationCount 126976 = 111 +encodeIterationCount 131072 = 112 +encodeIterationCount 139264 = 113 +encodeIterationCount 147456 = 114 +encodeIterationCount 155648 = 115 +encodeIterationCount 163840 = 116 +encodeIterationCount 172032 = 117 +encodeIterationCount 180224 = 118 +encodeIterationCount 188416 = 119 +encodeIterationCount 196608 = 120 +encodeIterationCount 204800 = 121 +encodeIterationCount 212992 = 122 +encodeIterationCount 221184 = 123 +encodeIterationCount 229376 = 124 +encodeIterationCount 237568 = 125 +encodeIterationCount 245760 = 126 +encodeIterationCount 253952 = 127 +encodeIterationCount 262144 = 128 +encodeIterationCount 278528 = 129 +encodeIterationCount 294912 = 130 +encodeIterationCount 311296 = 131 +encodeIterationCount 327680 = 132 +encodeIterationCount 344064 = 133 +encodeIterationCount 360448 = 134 +encodeIterationCount 376832 = 135 +encodeIterationCount 393216 = 136 +encodeIterationCount 409600 = 137 +encodeIterationCount 425984 = 138 +encodeIterationCount 442368 = 139 +encodeIterationCount 458752 = 140 +encodeIterationCount 475136 = 141 +encodeIterationCount 491520 = 142 +encodeIterationCount 507904 = 143 +encodeIterationCount 524288 = 144 +encodeIterationCount 557056 = 145 +encodeIterationCount 589824 = 146 +encodeIterationCount 622592 = 147 +encodeIterationCount 655360 = 148 +encodeIterationCount 688128 = 149 +encodeIterationCount 720896 = 150 +encodeIterationCount 753664 = 151 +encodeIterationCount 786432 = 152 +encodeIterationCount 819200 = 153 +encodeIterationCount 851968 = 154 +encodeIterationCount 884736 = 155 +encodeIterationCount 917504 = 156 +encodeIterationCount 950272 = 157 +encodeIterationCount 983040 = 158 +encodeIterationCount 1015808 = 159 +encodeIterationCount 1048576 = 160 +encodeIterationCount 1114112 = 161 +encodeIterationCount 1179648 = 162 +encodeIterationCount 1245184 = 163 +encodeIterationCount 1310720 = 164 +encodeIterationCount 1376256 = 165 +encodeIterationCount 1441792 = 166 +encodeIterationCount 1507328 = 167 +encodeIterationCount 1572864 = 168 +encodeIterationCount 1638400 = 169 +encodeIterationCount 1703936 = 170 +encodeIterationCount 1769472 = 171 +encodeIterationCount 1835008 = 172 +encodeIterationCount 1900544 = 173 +encodeIterationCount 1966080 = 174 +encodeIterationCount 2031616 = 175 +encodeIterationCount 2097152 = 176 +encodeIterationCount 2228224 = 177 +encodeIterationCount 2359296 = 178 +encodeIterationCount 2490368 = 179 +encodeIterationCount 2621440 = 180 +encodeIterationCount 2752512 = 181 +encodeIterationCount 2883584 = 182 +encodeIterationCount 3014656 = 183 +encodeIterationCount 3145728 = 184 +encodeIterationCount 3276800 = 185 +encodeIterationCount 3407872 = 186 +encodeIterationCount 3538944 = 187 +encodeIterationCount 3670016 = 188 +encodeIterationCount 3801088 = 189 +encodeIterationCount 3932160 = 190 +encodeIterationCount 4063232 = 191 +encodeIterationCount 4194304 = 192 +encodeIterationCount 4456448 = 193 +encodeIterationCount 4718592 = 194 +encodeIterationCount 4980736 = 195 +encodeIterationCount 5242880 = 196 +encodeIterationCount 5505024 = 197 +encodeIterationCount 5767168 = 198 +encodeIterationCount 6029312 = 199 +encodeIterationCount 6291456 = 200 +encodeIterationCount 6553600 = 201 +encodeIterationCount 6815744 = 202 +encodeIterationCount 7077888 = 203 +encodeIterationCount 7340032 = 204 +encodeIterationCount 7602176 = 205 +encodeIterationCount 7864320 = 206 +encodeIterationCount 8126464 = 207 +encodeIterationCount 8388608 = 208 +encodeIterationCount 8912896 = 209 +encodeIterationCount 9437184 = 210 +encodeIterationCount 9961472 = 211 +encodeIterationCount 10485760 = 212 +encodeIterationCount 11010048 = 213 +encodeIterationCount 11534336 = 214 +encodeIterationCount 12058624 = 215 +encodeIterationCount 12582912 = 216 +encodeIterationCount 13107200 = 217 +encodeIterationCount 13631488 = 218 +encodeIterationCount 14155776 = 219 +encodeIterationCount 14680064 = 220 +encodeIterationCount 15204352 = 221 +encodeIterationCount 15728640 = 222 +encodeIterationCount 16252928 = 223 +encodeIterationCount 16777216 = 224 +encodeIterationCount 17825792 = 225 +encodeIterationCount 18874368 = 226 +encodeIterationCount 19922944 = 227 +encodeIterationCount 20971520 = 228 +encodeIterationCount 22020096 = 229 +encodeIterationCount 23068672 = 230 +encodeIterationCount 24117248 = 231 +encodeIterationCount 25165824 = 232 +encodeIterationCount 26214400 = 233 +encodeIterationCount 27262976 = 234 +encodeIterationCount 28311552 = 235 +encodeIterationCount 29360128 = 236 +encodeIterationCount 30408704 = 237 +encodeIterationCount 31457280 = 238 +encodeIterationCount 32505856 = 239 +encodeIterationCount 33554432 = 240 +encodeIterationCount 35651584 = 241 +encodeIterationCount 37748736 = 242 +encodeIterationCount 39845888 = 243 +encodeIterationCount 41943040 = 244 +encodeIterationCount 44040192 = 245 +encodeIterationCount 46137344 = 246 +encodeIterationCount 48234496 = 247 +encodeIterationCount 50331648 = 248 +encodeIterationCount 52428800 = 249 +encodeIterationCount 54525952 = 250 +encodeIterationCount 56623104 = 251 +encodeIterationCount 58720256 = 252 +encodeIterationCount 60817408 = 253 +encodeIterationCount 62914560 = 254 +encodeIterationCount 65011712 = 255 +encodeIterationCount n = error ("invalid iteration count" ++ show n) + +getSignaturePayload :: Get SignaturePayload +getSignaturePayload = do + pv <- getWord8 + case pv of + 3 -> do + hashlen <- getWord8 + guard (hashlen == 5) + st <- getWord8 + ctime <- fmap ThirtyTwoBitTimeStamp getWord32be + eok <- getLazyByteString 8 + pka <- get + ha <- get + left16 <- getWord16be + mpib <- getRemainingLazyByteString + case runGetOrFail (some getMPI) mpib of + Left (_, _, e) -> fail ("v3 sig MPIs " ++ e) + Right (_, _, mpis) -> + return $ + SigV3 + (toFVal st) + ctime + (EightOctetKeyId eok) + (toFVal pka) + (toFVal ha) + left16 + (NE.fromList mpis) + 4 -> do + st <- getWord8 + pkaOctet <- get + ha <- get + let pka = toFVal pkaOctet :: PubKeyAlgorithm + hlen <- getWord16be + hb <- getLazyByteString (fromIntegral hlen) + let hashed = + case runGetOrFail (many getSigSubPacket) hb of + Left (_, _, err) -> fail ("v4 sig hasheds " ++ err) + Right (_, _, h) -> h + ulen <- getWord16be + ub <- getLazyByteString (fromIntegral ulen) + let unhashed = + case runGetOrFail (many getSigSubPacket) ub of + Left (_, _, err) -> fail ("v4 sig unhasheds " ++ err) + Right (_, _, u) -> u + left16 <- getWord16be + mpib <- getRemainingLazyByteString + let parseV4MPIs parseErrPrefix = + case runGetOrFail (some getMPI) mpib of + Left (_, _, e) -> fail (parseErrPrefix ++ e) + Right (_, _, mpis) -> + return $ + SigV4 + (toFVal st) + pka + (toFVal ha) + hashed + unhashed + left16 + (NE.fromList mpis) + if pka == BTypes.Ed25519 + then + if BL.length mpib == 64 + then do + let sig = BL.toStrict mpib + (rbs, sbs) = B.splitAt 32 sig + return $ + SigV4 + (toFVal st) + pka + (toFVal ha) + hashed + unhashed + left16 + (NE.fromList [MPI (os2ip rbs), MPI (os2ip sbs)]) + else parseV4MPIs "v4 Ed25519 legacy MPIs " + else + if pka == BTypes.Ed448 + then + if BL.length mpib == 114 + then do + let sig = BL.toStrict mpib + (rbs, sbs) = B.splitAt 57 sig + return $ + SigV4 + (toFVal st) + pka + (toFVal ha) + hashed + unhashed + left16 + (NE.fromList [MPI (os2ip rbs), MPI (os2ip sbs)]) + else parseV4MPIs "v4 Ed448 legacy MPIs " + else parseV4MPIs "v4 sig MPIs " + 6 -> do + st <- getWord8 + pka <- get + ha <- get + hlen <- getWord32be + hb <- getLazyByteString (fromIntegral hlen) + let hashed = + case runGetOrFail (many getSigSubPacket) hb of + Left (_, _, err) -> fail ("v6 sig hasheds " ++ err) + Right (_, _, h) -> h + ulen <- getWord32be + ub <- getLazyByteString (fromIntegral ulen) + let unhashed = + case runGetOrFail (many getSigSubPacket) ub of + Left (_, _, err) -> fail ("v6 sig unhasheds " ++ err) + Right (_, _, u) -> u + left16 <- getWord16be + saltSize <- getWord8 + let haVal = (toFVal ha :: HashAlgorithm) + expectedSaltSize <- + maybe + ( fail + ( "signature hash algorithm does not define a V6 salt size: " + ++ show haVal + ) + ) + pure + (v6SaltSizeForHashAlgorithm haVal) + when (saltSize /= expectedSaltSize) $ + fail + ( "v6 signature salt size mismatch for " + ++ show haVal + ++ ": expected " + ++ show expectedSaltSize + ++ ", got " + ++ show saltSize + ) + saltbs <- getByteString (fromIntegral saltSize) + let salt = SignatureSalt (BL.fromStrict saltbs) + if pka == BTypes.Ed25519 + then do + sig <- getByteString 64 + let (rbs, sbs) = B.splitAt 32 sig + mpis = [MPI (os2ip rbs), MPI (os2ip sbs)] + return $ + SigV6 + (toFVal st) + pka + (toFVal ha) + salt + hashed + unhashed + left16 + (NE.fromList mpis) + else + if pka == BTypes.Ed448 + then do + sig <- getByteString 114 + let (rbs, sbs) = B.splitAt 57 sig + mpis = [MPI (os2ip rbs), MPI (os2ip sbs)] + return $ + SigV6 + (toFVal st) + pka + (toFVal ha) + salt + hashed + unhashed + left16 + (NE.fromList mpis) + else do + mpib <- getRemainingLazyByteString + case runGetOrFail (some getMPI) mpib of + Left (_, _, e) -> fail ("v6 sig MPIs " ++ e) + Right (_, _, mpis) -> + return $ + SigV6 + (toFVal st) + pka + (toFVal ha) + salt + hashed + unhashed + left16 + (NE.fromList mpis) + _ -> do + bs <- getRemainingLazyByteString + return $ SigVOther pv bs + +putSignaturePayload :: SignaturePayload -> Put +putSignaturePayload (SigV3 st ctime eok pka ha left16 mpis) = do + putWord8 3 + putWord8 5 -- hashlen + put st + putWord32be . unThirtyTwoBitTimeStamp $ ctime + putLazyByteString (unEOKI eok) + put pka + put ha + putWord16be left16 + F.mapM_ put mpis +putSignaturePayload (SigV4 st pka ha hashed unhashed left16 mpis) = do + putWord8 4 + put st + put pka + put ha + let hb = runPut $ mapM_ put hashed + putWord16be . fromIntegral . BL.length $ hb + putLazyByteString hb + let ub = runPut $ mapM_ put unhashed + putWord16be . fromIntegral . BL.length $ ub + putLazyByteString ub + putWord16be left16 + if pka == BTypes.Ed25519 + then case NE.toList mpis of + [MPI r, MPI s] -> do + putByteString (padN 32 r) + putByteString (padN 32 s) + _ -> error "Ed25519 v4 signatures must have two MPIs" + else + if pka == BTypes.Ed448 + then case NE.toList mpis of + [MPI r, MPI s] -> do + putByteString (padN 57 r) + putByteString (padN 57 s) + _ -> error "Ed448 v4 signatures must have two MPIs" + else F.mapM_ put mpis + where + padN n i = + let bs = i2osp i + in B.replicate (max 0 (n - B.length bs)) 0 <> bs +putSignaturePayload (SigV6 st pka ha salt hashed unhashed left16 mpis) = do + let expectedSaltSize = + maybe + ( error + ( "signature hash algorithm does not define a V6 salt size: " + ++ show ha + ) + ) + id + (v6SaltSizeForHashAlgorithm ha) + actualSaltSize = fromIntegral (BL.length (unSignatureSalt salt)) + when (actualSaltSize /= expectedSaltSize) $ + error + ( "v6 signature salt size mismatch for " + ++ show ha + ++ ": expected " + ++ show expectedSaltSize + ++ ", got " + ++ show actualSaltSize + ) + putWord8 6 + put st + put pka + put ha + let hb = runPut $ mapM_ put hashed + putWord32be . fromIntegral . BL.length $ hb + putLazyByteString hb + let ub = runPut $ mapM_ put unhashed + putWord32be . fromIntegral . BL.length $ ub + putLazyByteString ub + putWord16be left16 + putWord8 . fromIntegral . BL.length . unSignatureSalt $ salt + putByteString (BL.toStrict (unSignatureSalt salt)) + if pka == BTypes.Ed25519 + then case NE.toList mpis of + [MPI r, MPI s] -> do + putByteString (padN 32 r) + putByteString (padN 32 s) + _ -> error "Ed25519 v6 signatures must have two MPIs" + else + if pka == BTypes.Ed448 + then case NE.toList mpis of + [MPI r, MPI s] -> do + putByteString (padN 57 r) + putByteString (padN 57 s) + _ -> error "Ed448 v6 signatures must have two MPIs" + else F.mapM_ put mpis + where + padN n i = + let bs = i2osp i + in B.replicate (max 0 (n - B.length bs)) 0 <> bs +putSignaturePayload (SigVOther pv bs) = do + putWord8 pv + putLazyByteString bs + +putTK :: TKUnknown -> Put +putTK tk = do + let pkp = tk ^. tkuKey . _1 + maybe + (put (PublicKey pkp)) + (\ska -> put (SecretKey pkp ska)) + (snd (tk ^. tkuKey)) + mapM_ (put . Signature) (_tkuRevs tk) + mapM_ putUid' (_tkuUIDs tk) + mapM_ putUat' (_tkuUAts tk) + mapM_ putSub' (_tkuSubs tk) + where + putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps + putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps + putSub' (p, sps) = put p >> mapM_ (put . Signature) sps + +-- | Parse the packets from a ByteString, with no error reporting +parsePkts :: ByteString -> [Pkt] +parsePkts = reverse . fst . parsePktsAccum 0 [] + +-- | Parse packets from a ByteString and report the first parse failure. +parsePktsEither :: ByteString -> Either PktParseError [Pkt] +parsePktsEither lbs = + case parsePktsAccum 0 [] lbs of + (pkts, Nothing) -> Right (reverse pkts) + (_, Just err) -> Left err + +data PktParseError + = PktParseError + { pktParseErrorOffset :: Int64 + , pktParseErrorMessage :: String + } + deriving (Eq, Show) + +parsePktsAccum + :: Int64 -> [Pkt] -> ByteString -> ([Pkt], Maybe PktParseError) +parsePktsAccum offset acc lbs + | BL.null lbs = (acc, Nothing) + | otherwise = + case runGetOrFail getPkt lbs of + Left (_, parseOffset, msg) -> (acc, err parseOffset msg) + Right (rest, consumed, pkt) -> + parsePktsAccum (offset + consumed) (pkt : acc) rest + where + err parseOffset msg = + Just + PktParseError + { pktParseErrorOffset = offset + parseOffset + , pktParseErrorMessage = msg + } + +armorPayloads :: [Armor] -> [ByteString] +armorPayloads = + foldr collect [] + where + collect (Armor _ _ payload) = (BL.fromStrict (BLC8.toStrict payload) :) + collect (ClearSigned _ _ inner) = (armorPayloads [inner] ++) + +looksLikeAsciiArmor :: ByteString -> Bool +looksLikeAsciiArmor = + (armorHeaderLazy `BL.isPrefixOf`) + . BL.dropWhile isLeadingArmorWhitespace + +looksLikeAsciiArmorLenient :: ByteString -> Bool +looksLikeAsciiArmorLenient = looksLikeAsciiArmor . stripUtf8Bom + +armorPayloadsOfType :: ArmorType -> [Armor] -> [ByteString] +armorPayloadsOfType atype = + foldr collect [] + where + collect (Armor innerType _ payload) + | innerType == atype = (BL.fromStrict (BLC8.toStrict payload) :) + | otherwise = id + collect (ClearSigned _ _ inner) = (armorPayloadsOfType atype [inner] ++) + +singleArmorPayloadOfType + :: ArmorType -> [Armor] -> Either String ByteString +singleArmorPayloadOfType atype armors = + case armorPayloadsOfType atype armors of + [payload] -> Right payload + [] -> + Left + ("ASCII armor decode returned no " ++ show atype ++ " blocks") + payloads -> + Left + ( "ASCII armor decode returned " + ++ show (length payloads) + ++ " " + ++ show atype + ++ " blocks (expected exactly one)" + ) + +singleClearSignedBlock + :: [Armor] + -> Either String ([(String, String)], ByteString, ByteString) +singleClearSignedBlock armors = + case [ clearSignedBlockFromArmor armor | armor@ClearSigned {} <- armors + ] of + [Right clearSigned] -> Right clearSigned + [Left err] -> Left err + [] -> Left "ASCII armor decode returned no clear-signed blocks" + clearSigneds -> + Left + ( "ASCII armor decode returned " + ++ show (length clearSigneds) + ++ " clear-signed blocks (expected exactly one)" + ) + where + clearSignedBlockFromArmor (ClearSigned hs cleartext inner) = + case inner of + Armor ArmorSignature _ sig -> + Right + ( hs + , BL.fromStrict (BLC8.toStrict cleartext) + , BL.fromStrict (BLC8.toStrict sig) + ) + Armor atype _ _ -> + Left + ( "clear-signed block contained inner armor type " + ++ show atype + ++ " (expected ArmorSignature)" + ) + ClearSigned {} -> + Left "clear-signed block contained nested clear-signed payload" + clearSignedBlockFromArmor _ = + Left "internal error: expected ClearSigned armor block" + +recommendedArmorType :: [Pkt] -> Maybe ArmorType +recommendedArmorType [] = Nothing +recommendedArmorType (pkt : _) + | isPrivateKeyPacket pkt = Just ArmorPrivateKeyBlock + | isPublicKeyPacket pkt = Just ArmorPublicKeyBlock + | isSignaturePacket pkt = Just ArmorSignature + | otherwise = Just ArmorMessage + where + isPrivateKeyPacket SecretKeyPkt {} = True + isPrivateKeyPacket SecretSubkeyPkt {} = True + isPrivateKeyPacket _ = False + + isPublicKeyPacket PublicKeyPkt {} = True + isPublicKeyPacket PublicSubkeyPkt {} = True + isPublicKeyPacket _ = False + + isSignaturePacket SignaturePkt {} = True + isSignaturePacket _ = False + +dearmorIfAsciiArmored + :: ByteString -> Either String (Bool, ByteString) +dearmorIfAsciiArmored bs + | looksLikeAsciiArmor bs = + (\payload -> (True, payload)) <$> decodeSingleArmorPayload bs + | otherwise = Right (False, bs) + +dearmorIfAsciiArmoredLenient + :: ByteString -> Either String (Bool, ByteString) +dearmorIfAsciiArmoredLenient bs + | looksLikeAsciiArmorLenient bs = + (\payload -> (True, payload)) + <$> decodeSingleArmorPayloadLenient (stripUtf8Bom bs) + | otherwise = Right (False, bs) + +decodeSingleArmorPayload + :: ByteString -> Either String ByteString +decodeSingleArmorPayload bs = + case AA.decodeLazy bs of + Left err -> Left err + Right armors -> singleArmorPayload armors + +decodeSingleArmorPayloadLenient + :: ByteString -> Either String ByteString +decodeSingleArmorPayloadLenient bs = + case decodeSingleArmorPayload bs of + Right payload -> Right payload + Left strictErr -> + let normalized = normalizeAsciiArmorForLenientDecode bs + in if normalized == bs + then Left strictErr + else case decodeSingleArmorPayload normalized of + Left lenientErr -> + Left + ( strictErr + ++ " (lenient normalization retry failed: " + ++ lenientErr + ++ ")" + ) + Right payload -> Right payload + +singleArmorPayload :: [Armor] -> Either String ByteString +singleArmorPayload armors = + case armorPayloads armors of + [payload] -> Right payload + [] -> Left "ASCII armor decode succeeded but returned no blocks" + payloads -> + Left + ( "ASCII armor decode returned " + ++ show (length payloads) + ++ " blocks (expected exactly one)" + ) + +data WireRepInput + = WireRepInput + { wireRepInputRef :: WireRepRef + , wireRepInputPayload :: ByteString + } + +wireRepRefFromInput + :: Maybe T.Text -> ByteString -> Either String WireRepInput +wireRepRefFromInput mname bs = + ( \(wasArmored, payload) -> + WireRepInput + { wireRepInputRef = BTypes.mkWireRepRef mname wasArmored payload + , wireRepInputPayload = payload + } + ) + <$> dearmorIfAsciiArmored bs + +data ParseState + = ParseState + { psOffset :: Int64 + , psIndex :: Int + , psSource :: WireRepRef + , psRemaining :: BL.ByteString + } + +-- | Parse packets from a source bytestream, preserving packet provenance. +parsePktsWithWireRep + :: WireRepRef -> ByteString -> [PktWithWireRep] +parsePktsWithWireRep src input = go initialState + where + initialState = + ParseState + { psOffset = 0 + , psIndex = 0 + , psSource = src + , psRemaining = input + } + go state + | BL.null (psRemaining state) = [] + | otherwise = + case runGetOrFail getPkt (psRemaining state) of + Left (_, _, _) -> [] + Right (rest, consumed, pkt) -> + let raw = BL.take consumed (psRemaining state) + newState = + state + { psOffset = psOffset state + consumed + , psIndex = psIndex state + 1 + , psRemaining = rest + } + pktWithSource = + PktWithWireRep + (psSource state) + (ByteRange (psOffset state) consumed) + raw + (psIndex state) + pkt + in pktWithSource : go newState + +conduitParsePktsWithWireRep + :: (Monad m) + => Maybe T.Text -> ConduitT B.ByteString PktWithWireRep m () +conduitParsePktsWithWireRep mname = go (UndecidedInput []) + where + go !state = do + mchunk <- await + case mchunk of + Nothing -> mapM_ yield (finishConduitState mname state) + Just chunk -> + let !nextState = consumeConduitChunk chunk state + in go nextState + +data ConduitParseState + = UndecidedInput ![B.ByteString] + | ArmoredInput ![B.ByteString] + | BinaryInput !BinaryParseState + +data BinaryParseState + = BinaryParseState + { bpsLength :: !Int64 + , bpsOffset :: !Int64 + , bpsIndex :: !Int + , bpsBuffer :: !B.ByteString + , bpsParsedRev :: [ParsedPacketChunk] + } + +data ArmorPrefixDecision + = PrefixNeedsMore + | PrefixIsArmored + | PrefixIsBinary + +consumeConduitChunk + :: B.ByteString -> ConduitParseState -> ConduitParseState +consumeConduitChunk chunk (UndecidedInput chunksRev) = + let prefixChunksRev = chunk : chunksRev + prefix = B.concat (reverse prefixChunksRev) + in case classifyArmorPrefix prefix of + PrefixNeedsMore -> UndecidedInput prefixChunksRev + PrefixIsArmored -> ArmoredInput prefixChunksRev + PrefixIsBinary -> feedBinaryChunk prefix initialBinaryParseState +consumeConduitChunk chunk (ArmoredInput chunksRev) = ArmoredInput (chunk : chunksRev) +consumeConduitChunk chunk (BinaryInput state) = BinaryInput (advanceBinaryParseState chunk state) + +finishConduitState + :: Maybe T.Text -> ConduitParseState -> [PktWithWireRep] +finishConduitState mname (UndecidedInput chunksRev) = + finalizeBinaryParseState + mname + ( advanceBinaryParseState + (B.concat (reverse chunksRev)) + initialBinaryParseState + ) +finishConduitState mname (ArmoredInput chunksRev) = + let input = BL.fromChunks (reverse chunksRev) + in case wireRepRefFromInput mname input of + Left _ -> [] + Right + WireRepInput + { wireRepInputRef = src + , wireRepInputPayload = payload + } -> + parsePktsWithWireRep src payload +finishConduitState mname (BinaryInput state) = finalizeBinaryParseState mname state + +initialBinaryParseState :: BinaryParseState +initialBinaryParseState = + BinaryParseState + { bpsLength = 0 + , bpsOffset = 0 + , bpsIndex = 0 + , bpsBuffer = B.empty + , bpsParsedRev = [] + } + +feedBinaryChunk + :: B.ByteString -> BinaryParseState -> ConduitParseState +feedBinaryChunk chunk = BinaryInput . advanceBinaryParseState chunk + +advanceBinaryParseState + :: B.ByteString -> BinaryParseState -> BinaryParseState +advanceBinaryParseState chunk state = + let !nextLength = bpsLength state + fromIntegral (B.length chunk) + !(nextOffset, nextIndex, nextBuffer, nextParsedRev) = + drainParsedPackets + (bpsOffset state) + (bpsIndex state) + (bpsBuffer state <> chunk) + (bpsParsedRev state) + in BinaryParseState + { bpsLength = nextLength + , bpsOffset = nextOffset + , bpsIndex = nextIndex + , bpsBuffer = nextBuffer + , bpsParsedRev = nextParsedRev + } + +finalizeBinaryParseState + :: Maybe T.Text -> BinaryParseState -> [PktWithWireRep] +finalizeBinaryParseState mname state = + let src = BTypes.mkWireRepRefWithLength mname False (bpsLength state) + in map (toPktWithWireRep src) (reverse (bpsParsedRev state)) + +classifyArmorPrefix :: B.ByteString -> ArmorPrefixDecision +classifyArmorPrefix prefix = + case B.dropWhile isLeadingArmorWhitespace prefix of + rest + | B.null rest -> PrefixNeedsMore + | armorHeader `B.isPrefixOf` rest -> PrefixIsArmored + | rest `B.isPrefixOf` armorHeader -> PrefixNeedsMore + | otherwise -> PrefixIsBinary + +armorHeader :: B.ByteString +armorHeader = B.pack (map (fromIntegral . fromEnum) "-----BEGIN PGP ") + +armorHeaderLazy :: ByteString +armorHeaderLazy = BL.fromStrict armorHeader + +utf8Bom :: ByteString +utf8Bom = BL.pack [0xef, 0xbb, 0xbf] + +isLeadingArmorWhitespace :: Word8 -> Bool +isLeadingArmorWhitespace w = w == 0x20 || w == 0x09 || w == 0x0d || w == 0x0a + +stripUtf8Bom :: ByteString -> ByteString +stripUtf8Bom bs + | utf8Bom `BL.isPrefixOf` bs = + BL.drop (fromIntegral (BL.length utf8Bom)) bs + | otherwise = bs + +normalizeAsciiArmorForLenientDecode :: ByteString -> ByteString +normalizeAsciiArmorForLenientDecode = + ensureTrailingLf . normalizeLineEndings + where + ensureTrailingLf lbs + | BL.null lbs = lbs + | BL.last lbs == 0x0a = lbs + | otherwise = lbs <> BL.singleton 0x0a + normalizeLineEndings lbs = + case BL.uncons lbs of + Nothing -> BL.empty + Just (0x0d, rest) -> + case BL.uncons rest of + Just (0x0a, rest') -> BL.cons 0x0a (normalizeLineEndings rest') + _ -> BL.cons 0x0a (normalizeLineEndings rest) + Just (w, rest) -> BL.cons w (normalizeLineEndings rest) + +data ParsedPacketChunk + = ParsedPacketChunk + { ppcRange :: ByteRange + , ppcRaw :: ByteString + , ppcIndex :: Int + , ppcValue :: Pkt + } + +toPktWithWireRep + :: WireRepRef -> ParsedPacketChunk -> PktWithWireRep +toPktWithWireRep src ppc = + PktWithWireRep + src + (ppcRange ppc) + (ppcRaw ppc) + (ppcIndex ppc) + (ppcValue ppc) + +drainParsedPackets + :: Int64 + -> Int + -> B.ByteString + -> [ParsedPacketChunk] + -> (Int64, Int, B.ByteString, [ParsedPacketChunk]) +drainParsedPackets !offset !idx !buffer acc + | B.null buffer = (offset, idx, B.empty, acc) + | otherwise = + case runGetOrFail getPkt (BL.fromStrict buffer) of + Left _ -> (offset, idx, buffer, acc) + Right (rest, consumed, pkt) -> + let !consumedLen = fromIntegral consumed + !nextOffset = offset + consumed + !nextIdx = idx + 1 + !nextBuffer = BL.toStrict rest + parsedPacket = + ParsedPacketChunk + { ppcRange = ByteRange offset consumed + , ppcRaw = BL.fromStrict (B.take consumedLen buffer) + , ppcIndex = idx + , ppcValue = pkt + } + in drainParsedPackets + nextOffset + nextIdx + nextBuffer + (parsedPacket : acc) diff --git a/Codec/Encryption/OpenPGP/Signatures.hs b/Codec/Encryption/OpenPGP/Signatures.hs --- a/Codec/Encryption/OpenPGP/Signatures.hs +++ b/Codec/Encryption/OpenPGP/Signatures.hs @@ -1,1766 +1,2404 @@ --- Signatures.hs: OpenPGP (RFC9580) signature verification --- Copyright © 2012-2026 Clint Adams --- This software is released under the terms of the Expat license. --- (See the LICENSE file). - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Codec.Encryption.OpenPGP.Signatures - ( SignError(..) - , renderSignError - , CertificationState(..) - , certificationStateAt - , VerificationError(..) - , renderVerificationError - , verifySigWith - , verifyAgainstKeyring - , verifyAgainstKeys - , verifyTKWith - , verifyUnknownTKWith - , signCertificationWithRSA - , signDirectKeyWithRSA - , signKeyRevocationWithRSA - , signSubkeyRevocationWithRSA - , signCertRevocationWithRSA - , signUserIDwithRSA - , crossSignSubkeyWithRSA - , signDataWithEd25519 - , signDataWithEd25519Legacy - , signDataWithEd25519V6 - , signDataWithEd448 - , signDataWithEd448V6 - , signDataWithRSA - , signDataWithRSAV6 - -- * Builder-based API (Phase 2) - , signDataWithRSABuilder - , signDataWithRSAV6Builder - , signDataWithEd25519Builder - , signDataWithEd25519V6Builder - , signDataWithEd448Builder - , signDataWithEd448V6Builder - , signDataWithAlgorithmicBuilder - -- * Text normalization mode - , TextNormalizationMode(..) - ) where - -import Control.Applicative ((<|>)) -import Control.Error.Util (hush) -import Control.Lens ((&), (^.), _1) -import Control.Monad (liftM2, when) - -import Crypto.Error (eitherCryptoError) -import Crypto.Hash (hashWith) -import qualified Crypto.Hash.Algorithms as CHA -import Crypto.Number.Serialize (i2osp, os2ip) -import qualified Crypto.PubKey.DSA as DSA -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.Ed25519 as Ed25519 -import qualified Crypto.PubKey.Ed448 as Ed448 -import qualified Crypto.PubKey.RSA.PKCS15 as P15 -import qualified Crypto.PubKey.RSA.Types as RSATypes - -import Data.Bifunctor (first) -import Data.Binary.Put (runPut) -import qualified Data.ByteArray as BA -import qualified Data.ByteString as B -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as BL -import Data.Either (isRight, lefts, rights) -import Data.Function (on) -import Data.IxSet.Typed ((@=)) -import qualified Data.IxSet.Typed as IxSet -import qualified Data.Set as Set -import Data.List (find, intercalate, nub) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, mapMaybe) -import Data.Text (Text) -import Data.Time.Clock (UTCTime(..), addUTCTime, diffUTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Word (Word16, Word8) -import GHC.TypeLits (TypeError, ErrorMessage(..)) - -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) -import Codec.Encryption.OpenPGP.Expirations - ( isPKTimeValidWithSelfSignatures - , keyStateAt - , keyStateValid - ) -import Codec.Encryption.OpenPGP.Internal - ( PktStreamContext(..) - , emptyPSC - , issuer - , issuerFP - ) -import Codec.Encryption.OpenPGP.Ontology - ( isCertRevocationSig - , isRevocationKeySSP - , isRevokerP - , isSubkeyBindingSig - , isSubkeyRevocation - ) -import Codec.Encryption.OpenPGP.SignatureQualities - ( sigCT - , sigHA - , sigPKA - , sigType - , signatureHashedSubpacketsKnown - , signatureSubpacketListsKnown - ) - -import Codec.Encryption.OpenPGP.SerializeForSigs - ( payloadForSig - , putKeyforSigning - , putPartialSigforSigning - , putSigTrailer - , putUforSigning - ) -import Codec.Encryption.OpenPGP.Policy (signatureV6SaltSizeForHashAlgorithm) -import Codec.Encryption.OpenPGP.Subpackets - ( SigBuilder - , TextNormalizationMode(..) - , sbSigType - , sbHashAlgo - , sbHashedSubs - , sbUnhashedSubs - , sbSalt - , sbTextNormMode - , PrivateKeyFor - ) -import qualified Codec.Encryption.OpenPGP.Subpackets as SP -import Codec.Encryption.OpenPGP.Types -import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA -import Data.Conduit.OpenPGP.Keyring.Instances () - -data VerificationError - = IssuerSubpacketMismatch - | IssuerSubpacketUncheckable String - | IssuerKeyIdProhibitedInV6Signature - | IssuerFingerprintSubpacketMismatch - | UnsupportedCriticalSubpacket SigType - | UnknownCriticalPacketInStream Word8 - | BrokenCriticalPacketInStream Word8 String - | ExternalVerificationError String - | NonSignaturePacket - | UnexpectedSignaturePayloadShape - | MissingHashAlgorithm - | HashComputationFailed String - | UnexpectedKeyVersion - | SignatureHashUnsupportedByAlgorithm HashAlgorithm PubKeyAlgorithm - | KeyRevoked - | SigningKeyUnavailableAtSignatureTime - | MissingIssuer - | SigningKeyNotFound (Maybe EightOctetKeyId) (Maybe Fingerprint) - | MultipleVerificationSuccesses Int - | UnsupportedKeyType PubKeyAlgorithm - | SignatureMismatch PubKeyAlgorithm Fingerprint - | SignatureShapeMismatch PubKeyAlgorithm - | SignatureEncodingInvalid PubKeyAlgorithm String - | SignaturePolicyHashUnsupported HashAlgorithm - | SignaturePolicyPKAMismatch PubKeyAlgorithm PubKeyAlgorithm - | SignatureExpired - | CandidateKeyFailures [VerificationError] - | InvalidSubkeyBackSignature VerificationError - -- ^ An embedded primary-key back-signature (type 0x19) in a subkey - -- binding signature failed to verify. - deriving (Eq, Show) - -data CertificationState - = CertificationNotYetKnown - | CertificationActive - | CertificationRevoked - deriving (Eq, Show) - -renderVerificationError :: VerificationError -> String -renderVerificationError IssuerSubpacketMismatch = - "verification failed: issuer subpacket does not match the actual signer" -renderVerificationError (IssuerSubpacketUncheckable err) = - "verification failed: issuer subpacket cannot be checked (" ++ err ++ ")" -renderVerificationError IssuerKeyIdProhibitedInV6Signature = - "verification failed: Issuer Key ID subpacket is prohibited in v6 signatures" -renderVerificationError IssuerFingerprintSubpacketMismatch = - "verification failed: issuer fingerprint subpacket does not match the actual signer" -renderVerificationError (UnsupportedCriticalSubpacket sigType) = - "verification failed: unsupported critical hashed subpacket in " ++ - show sigType ++ " signature" -renderVerificationError (UnknownCriticalPacketInStream t) = - "verification failed: unknown critical packet type in packet sequence (" ++ show t ++ ")" -renderVerificationError (BrokenCriticalPacketInStream t err) = - "verification failed: broken critical packet type " ++ show t ++ ": " ++ err -renderVerificationError (ExternalVerificationError err) = err -renderVerificationError NonSignaturePacket = - "verification failed: non-signature packet encountered where signature was expected" -renderVerificationError UnexpectedSignaturePayloadShape = - "verification failed: unexpected signature payload shape" -renderVerificationError MissingHashAlgorithm = - "verification failed: signature payload is missing hash algorithm" -renderVerificationError (HashComputationFailed err) = - "verification failed: hash computation error (" ++ err ++ ")" -renderVerificationError UnexpectedKeyVersion = - "verification failed: signing key has unexpected version (only v4 and v6 are supported)" -renderVerificationError (SignatureHashUnsupportedByAlgorithm ha pka) = - "verification failed: hash algorithm " ++ show ha ++ - " is not supported by " ++ show pka ++ " signing backend" -renderVerificationError KeyRevoked = - "verification failed: signing key is revoked" -renderVerificationError SigningKeyUnavailableAtSignatureTime = - "verification failed: signing key was not valid at the signature creation time" -renderVerificationError MissingIssuer = - "verification failed: signature is missing issuer information" -renderVerificationError (SigningKeyNotFound meoki mfp) = - "verification failed: signing key not found in keyring" ++ issuerContext meoki mfp -renderVerificationError (MultipleVerificationSuccesses n) = - "verification failed: multiple successful key matches (" ++ show n ++ ")" -renderVerificationError (UnsupportedKeyType pka) = - "verification failed: unsupported public key algorithm for verification (" ++ show pka ++ ")" -renderVerificationError (SignatureMismatch pka fpr) = - "verification failed: " ++ show pka ++ " signature mismatch (signer " ++ show fpr ++ ")" -renderVerificationError (SignatureShapeMismatch pka) = - "verification failed: malformed " ++ show pka ++ " signature encoding" -renderVerificationError (SignatureEncodingInvalid pka err) = - "verification failed: invalid " ++ show pka ++ " key/signature encoding (" ++ err ++ ")" -renderVerificationError (SignaturePolicyHashUnsupported ha) = - "verification failed: unsupported signature hash policy (" ++ show ha ++ ")" -renderVerificationError (SignaturePolicyPKAMismatch sigPka keyPka) = - "verification failed: signature public-key algorithm " ++ - show sigPka ++ " does not match key algorithm " ++ show keyPka -renderVerificationError SignatureExpired = - "verification failed: signature expired" -renderVerificationError (CandidateKeyFailures errs) = - "verification failed: no candidate key validated the signature (" ++ - intercalate "; " (nub (map renderVerificationError errs)) ++ - ")" -renderVerificationError (InvalidSubkeyBackSignature err) = - "verification failed: embedded primary-key back-signature verification failed: " ++ - renderVerificationError err - -issuerContext :: - Maybe EightOctetKeyId -> Maybe Fingerprint -> String -issuerContext meoki mfp = - case (meoki, mfp) of - (Nothing, Nothing) -> "" - _ -> - " (issuer-keyid=" ++ - maybe "unknown" show meoki ++ - ", issuer-fingerprint=" ++ - maybe "unknown" show mfp ++ - ")" - -verificationError :: VerificationError -> Either VerificationError a -verificationError = Left - -renderVerificationResult :: Either VerificationError a -> Either String a -renderVerificationResult = first renderVerificationError - -data SignError - = SignBackendError String - | SignUnsupportedCertificationType SigType - | SignUnsupportedKeySignatureType SigType - | SignV6SaltSizeMismatch HashAlgorithm Word8 Int - | SignProducedWrongLength String Int Int - deriving (Eq, Show) - -renderSignError :: SignError -> String -renderSignError (SignBackendError err) = - "signature backend error: " ++ err -renderSignError (SignUnsupportedCertificationType st) = - "unsupported certification signature type: " ++ - show st ++ - " (expected one of GenericCert/PersonaCert/CasualCert/PositiveCert)" -renderSignError (SignUnsupportedKeySignatureType st) = - "unsupported key signature type: " ++ - show st ++ - " (expected SignatureDirectlyOnAKey or KeyRevocationSig)" -renderSignError (SignV6SaltSizeMismatch ha expected actual) = - "v6 signature salt size mismatch for " ++ - show ha ++ - ": expected " ++ show expected ++ ", got " ++ show actual -renderSignError (SignProducedWrongLength algo expected actual) = - algo ++ " produced a non-" ++ show expected ++ "-byte signature (got " ++ show actual ++ ")" - -data VerifiableSignatureV where - VerifiableSignatureV4 :: SignaturePayloadV 'SigPayloadV4 -> VerifiableSignatureV - VerifiableSignatureV6 :: SignaturePayloadV 'SigPayloadV6 -> VerifiableSignatureV - -fromSignaturePayloadVerifiableSignatureV :: - SignaturePayload -> Maybe VerifiableSignatureV -fromSignaturePayloadVerifiableSignatureV sigPayload = - case toSomeSignaturePayload sigPayload of - SomeSignaturePayload (payload@SigPayloadV4Data {}) -> - Just (VerifiableSignatureV4 payload) - SomeSignaturePayload (payload@SigPayloadV6Data {}) -> - Just (VerifiableSignatureV6 payload) - _ -> Nothing - -isVerifiableSignaturePayload :: SignaturePayload -> Bool -isVerifiableSignaturePayload = isJust . fromSignaturePayloadVerifiableSignatureV - -toSignaturePayloadFromVerifiable :: VerifiableSignatureV -> SignaturePayload -toSignaturePayloadFromVerifiable (VerifiableSignatureV4 payload) = - toSignaturePayload payload -toSignaturePayloadFromVerifiable (VerifiableSignatureV6 payload) = - toSignaturePayload payload - -fromPktEitherVerifiableSignatureV :: Pkt -> Either VerificationError VerifiableSignatureV -fromPktEitherVerifiableSignatureV (SignaturePkt sigPayload) = - case fromSignaturePayloadVerifiableSignatureV sigPayload of - Just verifiableSig -> Right verifiableSig - Nothing -> - verificationError UnexpectedSignaturePayloadShape -fromPktEitherVerifiableSignatureV _ = - verificationError NonSignaturePacket - -signaturePKAAndMPIsFromClass :: - SomeSignatureV - -> Either VerificationError (PubKeyAlgorithm, NonEmpty MPI) -signaturePKAAndMPIsFromClass = - fmap (\(pka, _, mpis) -> (pka, mpis)) . signatureVerificationMaterialFromClass - -signatureLeft16FromClass :: SomeSignatureV -> Either VerificationError Word16 -signatureLeft16FromClass = - fmap (\(_, l16, _) -> l16) . signatureVerificationMaterialFromClass - -signatureVerificationMaterialFromClass :: - SomeSignatureV - -> Either VerificationError (PubKeyAlgorithm, Word16, NonEmpty MPI) -signatureVerificationMaterialFromClass (SomeSignatureV typedSig) = - case typedSig of - SignatureV3Packet (SigPayloadV3Data _ _ _ pka _ l16 mpis) -> - Right (pka, l16, mpis) - SignatureV4Packet (SigPayloadV4Data _ pka _ _ _ l16 mpis) -> - Right (pka, l16, mpis) - SignatureV6Packet (SigPayloadV6Data _ pka _ _ _ _ l16 mpis) -> - Right (pka, l16, mpis) - _ -> - verificationError UnexpectedSignaturePayloadShape - -verifySigWith :: - (Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification) - -> Pkt - -> PktStreamContext - -> Maybe UTCTime - -> Either VerificationError Verification -verifySigWith vf sig@(SignaturePkt _) state mt = - case fromPktEitherVerifiableSignatureV sig of - Right verifiableSig -> - let (st, hs, us, checkSubpacket, checkUnhashedSubpackets) = - verifiableSignatureVerificationInputs verifiableSig - in checkUnhashedSubpackets us *> - verifyWithSubpacketChecks vf sig state mt st hs checkSubpacket - Left err -> - Left err - where - checkV4Subpacket signer i@Issuer {} = checkIssuerSubpacket (eightOctetKeyID signer) i - checkV4Subpacket signer i@IssuerFingerprint {} = - checkIssuerFingerprintSubpacket PKA.IssuerFingerprintV4 (fingerprint signer) i - checkV4Subpacket _ _ = Right True - -- RFC 9580 §5.2.3.35: v6 signatures MUST NOT include an Issuer Key ID subpacket. - -- Treat any such subpacket as a verification error rather than merely uncheckable. - checkV6Subpacket _ Issuer {} = - verificationError IssuerKeyIdProhibitedInV6Signature - checkV6Subpacket signer i@IssuerFingerprint {} = - checkIssuerFingerprintSubpacket PKA.IssuerFingerprintV6 (fingerprint signer) i - checkV6Subpacket _ _ = Right True - rejectV6UnhashedIssuer (SigSubPacket _ Issuer {}) = - verificationError IssuerKeyIdProhibitedInV6Signature - rejectV6UnhashedIssuer _ = Right () - verifiableSignatureVerificationInputs :: - VerifiableSignatureV - -> - ( SigType - , [SigSubPacket] - , [SigSubPacket] - , SomePKPayload -> SigSubPacketPayload -> Either VerificationError Bool - , [SigSubPacket] -> Either VerificationError () - ) - verifiableSignatureVerificationInputs - (VerifiableSignatureV4 (SigPayloadV4Data st _ _ hs us _ _)) = - (st, hs, us, checkV4Subpacket, const (Right ())) - verifiableSignatureVerificationInputs - (VerifiableSignatureV6 (SigPayloadV6Data st _ _ _ hs us _ _)) = - (st, hs, us, checkV6Subpacket, mapM_ rejectV6UnhashedIssuer) -verifySigWith _ _ _ _ = - verificationError NonSignaturePacket - -verifyWithSubpacketChecks :: - (Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification) - -> Pkt - -> PktStreamContext - -> Maybe UTCTime - -> SigType - -> [SigSubPacket] - -> (SomePKPayload -> SigSubPacketPayload -> Either VerificationError Bool) - -> Either VerificationError Verification -verifyWithSubpacketChecks vf sig state mt sigType hashedSubpackets checkSubpacket = do - mapM_ (rejectUnsupportedCriticalSubpacket sigType) hashedSubpackets - v <- vf sig mt (payloadForSig sigType state) - mapM_ (checkSubpacket (v ^. verificationSigner) . _sspPayload) hashedSubpackets - warnings <- - if sigType == SubkeyBindingSig - then verifySubkeyBackSignatures state mt hashedSubpackets - else Right [] - isSignatureExpired sig mt *> - pure - (v - { _verificationWarnings = - _verificationWarnings v ++ warnings - }) - --- | Verify embedded primary-key back-signatures (PrimaryKeyBindingSig, 0x19) --- found in the hashed subpackets of a SubkeyBindingSig. --- --- Per RFC 9580 §5.2.3.3, a signing-capable subkey MUST include an embedded --- PrimaryKeyBindingSig (0x19) made by the subkey. This requirement is --- enforced strictly for v6 subkeys. For v4 subkeys we still verify any --- embedded back-sigs that are present, but do not reject a missing one — --- real-world v4 signing subkeys predate the strict cross-certification --- mandate and widespread interoperability requires accepting them. -verifySubkeyBackSignatures :: - PktStreamContext - -> Maybe UTCTime - -> [SigSubPacket] - -> Either VerificationError [VerificationWarning] -verifySubkeyBackSignatures state mt hashedSubpackets = do - subkeyPKP <- - maybe - (verificationError NonSignaturePacket) - Right - (subkeyPKPFromPkt (lastSubkey state)) - let embeddedSigs = - [ sp - | SigSubPacket _ (EmbeddedSignature sp) <- hashedSubpackets - ] - isSigningCapable = - any - (\(SigSubPacket _ payload) -> - case payload of - KeyFlags flags -> SignDataKey `Set.member` flags - _ -> False) - hashedSubpackets - isV6Subkey = _keyVersion subkeyPKP == V6 - case embeddedSigs of - [] -> - -- Require back-sig only for v6 signing subkeys (RFC 9580 §5.2.3.3). - if isSigningCapable && isV6Subkey - then Right [MissingSubkeyBackSignatureWarning] - else Right [] - _ -> - -- Always verify back-sigs that are present, regardless of key version. - mapM_ (verifyOneBackSig subkeyPKP) embeddedSigs *> Right [] - where - verifyOneBackSig subkeyPKP embSigPayload = do - let embSigPkt = SignaturePkt embSigPayload - backSigContext = - emptyPSC - { lastPrimaryKey = lastPrimaryKey state - , lastSubkey = lastSubkey state - } - case verifyAgainstKey' subkeyPKP embSigPkt mt - (payloadForSig PrimaryKeyBindingSig backSigContext) of - Left err -> verificationError (InvalidSubkeyBackSignature err) - Right _ -> Right () - -rejectUnsupportedCriticalSubpacket :: SigType -> SigSubPacket -> Either VerificationError () -rejectUnsupportedCriticalSubpacket sigType (SigSubPacket isCritical payload) - | not isCritical = Right () - | not (isBindingSignatureType sigType) = Right () - | otherwise = - case payload of - UserDefinedSigSub {} -> verificationError (UnsupportedCriticalSubpacket sigType) - OtherSigSub {} -> verificationError (UnsupportedCriticalSubpacket sigType) - _ -> Right () - -isBindingSignatureType :: SigType -> Bool -isBindingSignatureType SubkeyBindingSig = True -isBindingSignatureType PrimaryKeyBindingSig = True -isBindingSignatureType _ = False - -checkIssuerSubpacket :: - Either String EightOctetKeyId - -> SigSubPacketPayload - -> Either VerificationError Bool -checkIssuerSubpacket (Right signer) (Issuer i) - | signer == i = Right True - | otherwise = verificationError IssuerSubpacketMismatch -checkIssuerSubpacket (Left err) (Issuer _) = - verificationError (IssuerSubpacketUncheckable err) -checkIssuerSubpacket _ _ = Right True - -checkIssuerFingerprintSubpacket :: - IssuerFingerprintVersion -> Fingerprint -> SigSubPacketPayload -> Either VerificationError Bool -checkIssuerFingerprintSubpacket expectedVersion signer (IssuerFingerprint kv i) - | kv /= expectedVersion = verificationError IssuerFingerprintSubpacketMismatch - | signer == i = Right True - | otherwise = verificationError IssuerFingerprintSubpacketMismatch -checkIssuerFingerprintSubpacket _ _ _ = Right True - -verifyTKWith :: - (Pkt -> PktStreamContext -> Maybe UTCTime -> Either VerificationError Verification) - -> Maybe UTCTime - -> TK k - -> Either VerificationError (TK k) -verifyTKWith vsf mt tk = do - verifiedUnknown <- verifyUnknownTKWith vsf mt (tkToUnknown tk) - let typedSubkeys = Map.fromList [ (keyPktToPkt kp, kp) | (kp, _) <- tk ^. tkSubs ] - verifiedTypedSubkeys = - mapMaybe - (\(pkt, sigs) -> (\kp -> (kp, sigs)) <$> Map.lookup pkt typedSubkeys) - (verifiedUnknown ^. tkuSubs) - pure - TK - { _tkPrimaryKey = tk ^. tkPrimaryKey - , _tkRevs = verifiedUnknown ^. tkuRevs - , _tkUIDs = verifiedUnknown ^. tkuUIDs - , _tkUAts = verifiedUnknown ^. tkuUAts - , _tkSubs = verifiedTypedSubkeys - } - -verifyUnknownTKWith :: - (Pkt -> PktStreamContext -> Maybe UTCTime -> Either VerificationError Verification) - -> Maybe UTCTime - -> TKUnknown - -> Either VerificationError TKUnknown -verifyUnknownTKWith vsf mt tk = do - revokers <- checkRevokers tk - revs <- checkKeyRevocations revokers tk - let uids = filter (not . null . snd) . checkUidSigs $ tk ^. tkuUIDs - let uats = filter (not . null . snd) . checkUAtSigs $ tk ^. tkuUAts - let subs = concatMap checkSub $ tk ^. tkuSubs - return (TKUnknown (tk ^. tkuKey) revs uids uats subs) - where - checkRevokers = - Right . concat . rights . map verifyRevoker . filter isRevokerP . _tkuRevs - checkKeyRevocations :: - [(PubKeyAlgorithm, Fingerprint)] - -> TKUnknown - -> Either VerificationError [SignaturePayload] - checkKeyRevocations rs k = - Prelude.sequence . concatMap (filterRevs rs) . rights . - map (liftM2 fmap (,) vSig) $ - k ^. - tkuRevs - checkUidSigs :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])] - checkUidSigs = - map - (\(uid, sps) -> - let verified = rights . map (\sp -> fmap ((,) sp) (vUid (uid, sp))) $ sps - in (uid, retainNonRevokedCertifications mt verified)) - checkUAtSigs :: - [([UserAttrSubPacket], [SignaturePayload])] - -> [([UserAttrSubPacket], [SignaturePayload])] - checkUAtSigs = - map - (\(uat, sps) -> - let verified = rights . map (\sp -> fmap ((,) sp) (vUAt (uat, sp))) $ sps - in (uat, retainNonRevokedCertifications mt verified)) - checkSub :: (Pkt, [SignaturePayload]) -> [(Pkt, [SignaturePayload])] - checkSub (pkt, sps) = - if revokedSub pkt sps - then [] - else checkSub' pkt sps - revokedSub :: Pkt -> [SignaturePayload] -> Bool - revokedSub _ [] = False - revokedSub p sigs = - any (vSubSig p) (filter subkeyRevocationEffective sigs) - checkSub' :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])] - checkSub' p sps = - let goodsigs = - filter (vSubSig p) . - filter signatureKnown . - filter isSubkeyBindingSig $ - sps - in if null goodsigs - then [] - else [(p, goodsigs)] - getHasheds = signatureHashedSubpackets - filterRevs :: - [(PubKeyAlgorithm, Fingerprint)] - -> (SignaturePayload, Verification) - -> [Either VerificationError SignaturePayload] - filterRevs vokers spv = - case spv of - (s, _) - | isV4OrV6Sig s && sigType s == Just SignatureDirectlyOnAKey -> - [Right s | signatureKnown s] - (s, v) - | isV4OrV6Sig s - , sigType s == Just KeyRevocationSig - , Just pka <- sigPKA s -> - if (v ^. verificationSigner == tk ^. tkuKey . _1) || - any - (\(p, f) -> - p == pka && f == fingerprint (v ^. verificationSigner)) - vokers - then - if keyRevocationEffective s - then [verificationError KeyRevoked] - else [Right s | signatureKnown s] - else [Right s | signatureKnown s] - _ -> [] - isV4OrV6Sig = isVerifiableSignaturePayload - vUid :: (Text, SignaturePayload) -> Either VerificationError Verification - vUid (uid, sp) = - vsf - (SignaturePkt sp) - emptyPSC - { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1) - , lastUIDorUAt = UserIdPkt uid - } - Nothing - vUAt :: - ([UserAttrSubPacket], SignaturePayload) -> Either VerificationError Verification - vUAt (uat, sp) = - vsf - (SignaturePkt sp) - emptyPSC - { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1) - , lastUIDorUAt = UserAttributePkt uat - } - Nothing - vSig :: SignaturePayload -> Either VerificationError Verification - vSig sp = - vsf - (SignaturePkt sp) - emptyPSC {lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)} - Nothing - vSubSig :: Pkt -> SignaturePayload -> Bool - vSubSig sk sp = - isRight - (vsf - (SignaturePkt sp) - emptyPSC - { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1) - , lastSubkey = sk - } - mt) - verifyRevoker :: - SignaturePayload - -> Either VerificationError [(PubKeyAlgorithm, Fingerprint)] - verifyRevoker sp = - vSig sp *> - pure - (map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp)) . - filter isRevocationKeySSP $ - getHasheds sp) - retainNonRevokedCertifications :: - Maybe UTCTime -> [(SignaturePayload, Verification)] -> [SignaturePayload] - retainNonRevokedCertifications validationTime verified = - map fst $ - filter - ((== CertificationActive) . certificationStateAt validationTime verified) - certifications - where - certifications = filter (not . isCertRevocationSig . fst) verified - signatureKnown = signatureKnownAt mt - subkeyRevocationEffective sp = isSubkeyRevocation sp && signatureEffectiveAt mt sp - keyRevocationEffective sp - | isHistoricalKeyRevocation sp = signatureEffectiveAt mt sp - | otherwise = signatureUnexpiredAt mt sp - -verifyAgainstKeyring :: - PublicKeyring -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification -verifyAgainstKeyring kr sig mt payload = do - let allKeys = map tkToUnknown (IxSet.toList kr) - signerValidationTime = signatureCreationTimeFromPacket sig - ikeys = (kr @=) <$> issuer sig - ifpkeys = (kr @=) <$> issuerFP sig - hintedKeys = maybe [] (map tkToUnknown . IxSet.toList) (ifpkeys <|> ikeys) - hintedResult = - if null hintedKeys - then Left MissingIssuer - else verifyFromCandidates allKeys hintedKeys sig signerValidationTime mt payload - in case hintedResult of - Right v -> Right v - Left hintedErr -> - let fallbackResult = - verifyFromCandidates allKeys allKeys sig signerValidationTime mt payload - in if null hintedKeys - then - case fallbackResult of - Right v -> Right v - Left _ -> - verificationError (SigningKeyNotFound (issuer sig) (issuerFP sig)) - else - case fallbackResult of - Right v -> Right v - Left _ -> Left hintedErr - -verifyFromCandidates :: - [TKUnknown] - -> [TKUnknown] - -> Pkt - -> Maybe UTCTime - -> Maybe UTCTime - -> ByteString - -> Either VerificationError Verification -verifyFromCandidates allKeys candidateTks sig signerValidationTime verificationTime payload = - let candidateResults = - map - (resolveCandidateSignerPKPs allKeys sig signerValidationTime (const True)) - candidateTks - candidateErrors = concatMap fst candidateResults - usablePkps = concatMap snd candidateResults - in if null usablePkps - then - if null candidateErrors - then verificationError (SigningKeyNotFound (issuer sig) (issuerFP sig)) - else verificationError (CandidateKeyFailures candidateErrors) - else - case verifyAgainstPKPs usablePkps sig verificationTime payload of - Left (CandidateKeyFailures errs) - | not (null candidateErrors) -> - verificationError (CandidateKeyFailures (candidateErrors ++ errs)) - other -> other - -verifyAgainstKeys :: - [TKUnknown] -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification -verifyAgainstKeys ks sig mt payload = do - let allpkps = - filter - (\x -> - (((fingerprint x ==) <$> issuerFP sig) == Just True) || - ((==) <$> issuer sig <*> hush (eightOctetKeyID x)) == - Just True) - (concatMap (\x -> (x ^. tkuKey . _1) : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x)) ks) - allCandidatePkps = - concatMap (\x -> (x ^. tkuKey . _1) : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x)) ks - normalizedCandidates - | null allpkps = allCandidatePkps - | otherwise = allpkps - verifyAgainstPKPs normalizedCandidates sig mt payload - -verifyAgainstPKPs :: - [SomePKPayload] -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification -verifyAgainstPKPs pkps sig mt payload = - case rights results of - [] -> verificationError (CandidateKeyFailures (lefts results)) - [r] -> isSignatureExpired sig mt *> pure r - rs -> verificationError (MultipleVerificationSuccesses (length rs)) - where - results = map (\pkp -> verifyAgainstKey' pkp sig mt payload) pkps - -resolveCandidateSignerPKPs :: - [TKUnknown] - -> Pkt - -> Maybe UTCTime - -> (SomePKPayload -> Bool) - -> TKUnknown - -> ([VerificationError], [SomePKPayload]) -resolveCandidateSignerPKPs _ _ Nothing matchesP tk = - ([], filter matchesP (candidatePKPs tk)) -resolveCandidateSignerPKPs allKeys _ (Just validationTime) matchesP tk = - let rawMatches = filter matchesP (candidatePKPs tk) - in case verifyUnknownTKWith (verifySigWith (verifyAgainstKeys allKeys)) (Just validationTime) tk of - Left err -> (replicate (length rawMatches) err, []) - Right verifiedTK -> - let verifiedMatches = - map - (\pkp -> - case historicallyValidSigner validationTime (timelineValidationTK pkp verifiedTK) pkp of - Right () -> Right pkp - Left err -> Left err) - rawMatches - in (lefts verifiedMatches, rights verifiedMatches) - where - timelineValidationTK pkp verifiedTK' - | fingerprint pkp == fingerprint (tk ^. tkuKey . _1) = tk - | otherwise = verifiedTK' - -candidatePKPs :: TKUnknown -> [SomePKPayload] -candidatePKPs tk = (tk ^. tkuKey . _1) : mapMaybe (subkeyPKPFromPkt . fst) (tk ^. tkuSubs) - -historicallyValidSigner :: - UTCTime -> TKUnknown -> SomePKPayload -> Either VerificationError () -historicallyValidSigner validationTime tk pkp - | fingerprint pkp == fingerprint (tk ^. tkuKey . _1) = - if keyStateValid (keyStateAt validationTime tk) - then Right () - else verificationError SigningKeyUnavailableAtSignatureTime - | otherwise = - case find (\(pkt, _) -> maybe False ((== fingerprint pkp) . fingerprint) (subkeyPKPFromPkt pkt)) (tk ^. tkuSubs) of - Nothing -> verificationError SigningKeyUnavailableAtSignatureTime - Just (subPkt, sigs) -> - case subkeyPKPFromPkt subPkt of - Nothing -> verificationError SigningKeyUnavailableAtSignatureTime - Just subPKP -> - if isPKTimeValidWithSelfSignatures validationTime subPKP sigs - then Right () - else verificationError SigningKeyUnavailableAtSignatureTime - -signatureCreationTimeFromPacket :: Pkt -> Maybe UTCTime -signatureCreationTimeFromPacket (SignaturePkt sigPayload) = signatureCreationTime sigPayload -signatureCreationTimeFromPacket _ = Nothing - -signatureCreationTime :: SignaturePayload -> Maybe UTCTime -signatureCreationTime = - fmap (posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp) . sigCT - -signatureKnownAt :: Maybe UTCTime -> SignaturePayload -> Bool -signatureKnownAt Nothing _ = True -signatureKnownAt (Just validationTime) sigPayload = - maybe False (<= validationTime) (signatureCreationTime sigPayload) - -signatureEffectiveAt :: Maybe UTCTime -> SignaturePayload -> Bool -signatureEffectiveAt Nothing _ = True -signatureEffectiveAt (Just validationTime) sigPayload = - signatureKnownAt (Just validationTime) sigPayload && - maybe True (validationTime <) (signatureExpirationTime sigPayload) - -signatureUnexpiredAt :: Maybe UTCTime -> SignaturePayload -> Bool -signatureUnexpiredAt Nothing _ = True -signatureUnexpiredAt (Just validationTime) sigPayload = - maybe True (validationTime <) (signatureExpirationTime sigPayload) - -signatureExpirationTime :: SignaturePayload -> Maybe UTCTime -signatureExpirationTime sigPayload = - addDurationToTime <$> - signatureCreationTime sigPayload <*> - signatureExpirationDuration sigPayload - -signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration -signatureExpirationDuration sigPayload = - signatureHashedSubpacketsKnown sigPayload >>= firstSignatureExpirationDuration - -firstSignatureExpirationDuration :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration -firstSignatureExpirationDuration = - foldr - (\subpacket acc -> - case subpacket of - SigSubPacket _ (SigExpirationTime duration) -> Just duration - _ -> acc) - Nothing - -addDurationToTime :: UTCTime -> ThirtyTwoBitDuration -> UTCTime -addDurationToTime baseTime duration = - addUTCTime (fromIntegral (unThirtyTwoBitDuration duration)) baseTime - -certificationStateAt :: - Maybe UTCTime - -> [(SignaturePayload, Verification)] - -> (SignaturePayload, Verification) - -> CertificationState -certificationStateAt validationTime verified certification@(certificationSig, _) - | not (signatureKnownAt validationTime certificationSig) = CertificationNotYetKnown - | not (signatureEffectiveAt validationTime certificationSig) = CertificationRevoked - | any (`revokesCertification` certification) visibleRevocations = CertificationRevoked - | otherwise = CertificationActive - where - visibleRevocations = - filter - (signatureEffectiveAt validationTime . fst) - (filter (isCertRevocationSig . fst) verified) - -revokesCertification :: - (SignaturePayload, Verification) - -> (SignaturePayload, Verification) - -> Bool -revokesCertification (revocationSig, revocationVerification) (certificationSig, certificationVerification) = - sameSigner && certificationPrecedesRevocation certificationSig revocationSig - where - sameSigner = - fingerprint (revocationVerification ^. verificationSigner) == - fingerprint (certificationVerification ^. verificationSigner) - -certificationPrecedesRevocation :: - SignaturePayload -> SignaturePayload -> Bool -certificationPrecedesRevocation certificationSig revocationSig = - case (signatureCreationTime certificationSig, signatureCreationTime revocationSig) of - (Just certificationTime, Just revocationTime) -> - certificationTime < revocationTime - _ -> False - -isHistoricalKeyRevocation :: SignaturePayload -> Bool -isHistoricalKeyRevocation sigPayload = - case revocationReasonCode sigPayload of - Just KeySuperseded -> True - Just KeyRetiredAndNoLongerUsed -> True - Just UserIdInfoNoLongerValid -> True - _ -> False - -revocationReasonCode :: SignaturePayload -> Maybe RevocationCode -revocationReasonCode sigPayload = - (\(SigSubPacket _ (ReasonForRevocation reasonCode _)) -> reasonCode) <$> - find isReasonForRevocation (signatureSubpackets sigPayload) - where - isReasonForRevocation (SigSubPacket _ ReasonForRevocation {}) = True - isReasonForRevocation _ = False - -signatureSubpackets :: SignaturePayload -> [SigSubPacket] -signatureSubpackets sigPayload = - case signatureSubpacketListsKnown sigPayload of - Just (hashed, unhashed) -> hashed ++ unhashed - Nothing -> [] - -signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket] -signatureHashedSubpackets sigPayload = - maybe [] id (signatureHashedSubpacketsKnown sigPayload) - -subkeyPKPFromPkt :: Pkt -> Maybe SomePKPayload -subkeyPKPFromPkt (PublicSubkeyPkt p) = Just p -subkeyPKPFromPkt (SecretSubkeyPkt p _) = Just p -subkeyPKPFromPkt _ = Nothing - -verifyAgainstKey' :: SomePKPayload -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification -verifyAgainstKey' pkp sig mt payload = do - sigClass <- - either - (verificationError . const NonSignaturePacket) - Right - (fromPktEitherSomeSignatureV sig) - let sigPayload = - case sigClass of - SomeSignatureV typedSig -> signaturePayloadFromSignatureV typedSig - sigHash <- - maybe - (verificationError MissingHashAlgorithm) - Right - (sigHA sigPayload) - sigDetails <- signaturePKAAndMPIsFromClass sigClass - enforcePKACompatibility sigPayload - enforceSignatureHashPolicy sigHash - _ <- isSignatureExpired sig mt - let signedPayload = BL.toStrict (finalPayload sig payload) - enforceLeft16Prefix sigClass sigHash signedPayload - (\verifiedSigner -> Verification verifiedSigner sigPayload []) <$> - verify' sigDetails pkp sigHash signedPayload - where - enforcePKACompatibility sigPayload = - let sigPka = maybe (OtherPKA 0) id (sigPKA sigPayload) - keyPka = _pkalgo pkp - in if pkaCompatible sigPka keyPka - then Right () - else verificationError (SignaturePolicyPKAMismatch sigPka keyPka) - enforceSignatureHashPolicy sigHash = - case sigHash of - OtherHA {} -> verificationError (SignaturePolicyHashUnsupported sigHash) - _ -> Right () - enforceLeft16Prefix sigClass sigHash signedPayload = do - expectedLeft16 <- - either - (verificationError . HashComputationFailed) - Right - (left16FromSignedPayload sigHash signedPayload) - actualLeft16 <- signatureLeft16FromClass sigClass - if actualLeft16 == expectedLeft16 - then Right () - else - verificationError - (SignatureMismatch (_pkalgo pkp) (fingerprint pkp)) - pkaCompatible RSA keyPka = - keyPka `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] - pkaCompatible DeprecatedRSASignOnly keyPka = - keyPka `elem` [RSA, DeprecatedRSASignOnly] - pkaCompatible PKA.EdDSA keyPka = - keyPka `elem` [PKA.EdDSA, PKA.Ed25519, PKA.Ed448] - pkaCompatible PKA.Ed25519 keyPka = - keyPka `elem` [PKA.EdDSA, PKA.Ed25519] - pkaCompatible PKA.Ed448 keyPka = - keyPka `elem` [PKA.EdDSA, PKA.Ed448] - pkaCompatible sigPka keyPka = sigPka == keyPka - verify' details pub@(PKPayload V4 _ _ _ pkey) ha pl = - verifyByHash details pub pkey ha pl - verify' details pub@(PKPayload V6 _ _ _ pkey) ha pl = - verifyByHash details pub pkey ha pl - verify' _ _ _ _ = - verificationError UnexpectedKeyVersion - verifyByHash details pub pkey ha pl = - case ha of - SHA1 -> verify'' details CHA.SHA1 pub pkey pl - RIPEMD160 -> verify'' details CHA.RIPEMD160 pub pkey pl - SHA224 -> verify'' details CHA.SHA224 pub pkey pl - SHA256 -> verify'' details CHA.SHA256 pub pkey pl - SHA384 -> verify'' details CHA.SHA384 pub pkey pl - SHA512 -> verify'' details CHA.SHA512 pub pkey pl - SHA3_256 -> verifyNoRSA SHA3_256 details CHA.SHA3_256 pub pkey pl - SHA3_512 -> verifyNoRSA SHA3_512 details CHA.SHA3_512 pub pkey pl - DeprecatedMD5 -> verify'' details CHA.MD5 pub pkey pl - _ -> - verificationError (SignaturePolicyHashUnsupported ha) - verify'' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = - dsaVerify pub mpis hd pkey bs - verify'' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs = - ecdsaVerify pub mpis hd pkey bs - verify'' (sigPka, mpis) hd pub (EdDSAPubKey Ed25519 pkey) bs - | sigPka `elem` [EdDSA, PKA.Ed25519] = - ed25519Verify sigPka pub mpis hd pkey bs - verify'' (sigPka, mpis) hd pub (EdDSAPubKey Ed448 pkey) bs - | sigPka `elem` [EdDSA, PKA.Ed448] = - ed448Verify sigPka pub mpis hd pkey bs - verify'' (RSA, mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs = - rsaVerify pub mpis hd pkey bs - verify'' (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka) - verifyNoRSA ha' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = - dsaVerify pub mpis hd pkey bs - verifyNoRSA ha' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs = - ecdsaVerify pub mpis hd pkey bs - verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey Ed25519 pkey) bs - | sigPka `elem` [EdDSA, PKA.Ed25519] = - ed25519Verify sigPka pub mpis hd pkey bs - verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey Ed448 pkey) bs - | sigPka `elem` [EdDSA, PKA.Ed448] = - ed448Verify sigPka pub mpis hd pkey bs - verifyNoRSA ha' (RSA, _) _ _ _ _ = - verificationError (SignatureHashUnsupportedByAlgorithm ha' RSA) - verifyNoRSA _ (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka) - dsaVerify pub (r :| [s]) hd pkey bs = - if DSA.verify hd pkey (dsaMPIsToSig r s) bs - then Right pub - else verificationError (SignatureMismatch DSA (fingerprint pub)) - dsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch DSA) - ecdsaVerify pub (r :| [s]) hd pkey bs = - if ECDSA.verify hd pkey (ecdsaMPIsToSig r s) bs - then Right pub - else verificationError (SignatureMismatch ECDSA (fingerprint pub)) - ecdsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch ECDSA) - ed25519Verify sigPka pub (r :| [s]) hd pkey bs = - case edPointToRawPublic 32 pkey of - Left err -> - verificationError (SignatureEncodingInvalid sigPka err) - Right rawPub -> - case cf2es (Ed25519.publicKey rawPub) of - Left err -> - verificationError (SignatureEncodingInvalid sigPka err) - Right ep -> - case cf2es (Ed25519.signature (pad32 (i2osp (unMPI r)) <> pad32 (i2osp (unMPI s)))) of - Left err -> - verificationError (SignatureEncodingInvalid sigPka err) - Right es -> - let prehash = crazyHash hd bs :: B.ByteString - in if Ed25519.verify ep prehash es - then Right pub - else verificationError (SignatureMismatch sigPka (fingerprint pub)) - ed25519Verify sigPka _ _ _ _ _ = - verificationError (SignatureShapeMismatch sigPka) - ed448Verify sigPka pub (r :| [s]) hd pkey bs = - case edPointToRawPublic 57 pkey of - Left err -> - verificationError (SignatureEncodingInvalid sigPka err) - Right rawPub -> - case cf2es (Ed448.publicKey rawPub) of - Left err -> - verificationError (SignatureEncodingInvalid sigPka err) - Right ep -> - case cf2es (Ed448.signature (padN 57 (i2osp (unMPI r)) <> padN 57 (i2osp (unMPI s)))) of - Left err -> - verificationError (SignatureEncodingInvalid sigPka err) - Right es -> - let prehash = crazyHash hd bs :: B.ByteString - in if Ed448.verify ep prehash es - then Right pub - else verificationError (SignatureMismatch sigPka (fingerprint pub)) - ed448Verify sigPka _ _ _ _ _ = - verificationError (SignatureShapeMismatch sigPka) - edPointToRawPublic expectedLen (NativeEPoint (EPoint x)) = - exactLengthPublic expectedLen "native" (i2osp x) - edPointToRawPublic expectedLen (PrefixedNativeEPoint (EPoint x)) = do - prefixed <- exactLengthPublic (expectedLen + 1) "prefixed-native" (i2osp x) - if B.head prefixed /= 0x40 - then Left "prefixed-native EdDSA public key is missing the 0x40 prefix" - else Right (B.tail prefixed) - exactLengthPublic expectedLen label bs - | B.length bs == expectedLen = Right bs - | otherwise = - Left - ("invalid " ++ label ++ " EdDSA public key length: expected " ++ - show expectedLen ++ " octets, got " ++ show (B.length bs)) - pad32 bs = - let l = B.length bs - in if l >= 32 - then bs - else B.replicate (32 - l) 0 <> bs - padN n bs = - let l = B.length bs - in if l >= n - then bs - else B.replicate (n - l) 0 <> bs - cf2es = either (Left . show) return . eitherCryptoError - rsaVerify pub mpis hd pkey bs = - if P15.verify (Just hd) pkey bs (rsaMPItoSig pkey mpis) - then Right pub - else verificationError (SignatureMismatch RSA (fingerprint pub)) - dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s) - ecdsaMPIsToSig r s = ECDSA.Signature (unMPI r) (unMPI s) - rsaMPItoSig pkey (s :| []) = - let sz = RSATypes.public_size pkey - raw = i2osp (unMPI s) - pad = sz - B.length raw - in B.replicate pad 0 <> raw - crazyHash h = BA.convert . hashWith h - -isSignatureExpired :: Pkt -> Maybe UTCTime -> Either VerificationError Bool -isSignatureExpired _ Nothing = return False -isSignatureExpired s (Just t) = - do - sigClass <- - either - (verificationError . const NonSignaturePacket) - Right - (fromPktEitherSomeSignatureV s) - if any - (expiredBefore t) - (signatureHashedSubpackets - (case sigClass of - SomeSignatureV typedSig -> signaturePayloadFromSignatureV typedSig)) - then verificationError SignatureExpired - else return True - where - expiredBefore :: UTCTime -> SigSubPacket -> Bool - expiredBefore ct (SigSubPacket _ (SigExpirationTime et)) = - fromEnum ((posixSecondsToUTCTime . toEnum . fromEnum) et `diffUTCTime` ct) < - 0 - expiredBefore _ _ = False - -finalPayload :: Pkt -> ByteString -> ByteString -finalPayload s pl = BL.concat [pl, sigbit, trailer s] - where - sigbit = runPut $ putPartialSigforSigning s - trailer :: Pkt -> ByteString - trailer (SignaturePkt sigPayload) = - maybe - BL.empty - (const (runPut $ putSigTrailer s)) - (fromSignaturePayloadVerifiableSignatureV sigPayload) - trailer _ = BL.empty - -normalizePayloadForSigType :: SigType -> ByteString -> ByteString -normalizePayloadForSigType CanonicalTextSig = - stripTrailingWhitespacePerLine . canonicalizeLineEndings -normalizePayloadForSigType _ = id - -normalizePayloadForSigTypeWith :: TextNormalizationMode -> SigType -> ByteString -> ByteString -normalizePayloadForSigTypeWith CleartextCompat st = normalizePayloadForSigType st -normalizePayloadForSigTypeWith RFC9580Strict CanonicalTextSig = canonicalizeLineEndings -normalizePayloadForSigTypeWith RFC9580Strict _ = id - -canonicalizeLineEndings :: ByteString -> ByteString -canonicalizeLineEndings = BL.pack . go . BL.unpack - where - go [] = [] - go (0x0d:0x0a:rest) = 0x0d : 0x0a : go rest - go (0x0d:rest) = 0x0d : 0x0a : go rest - go (0x0a:rest) = 0x0d : 0x0a : go rest - go (w:rest) = w : go rest - -stripTrailingWhitespacePerLine :: ByteString -> ByteString -stripTrailingWhitespacePerLine = BL.pack . go [] . BL.unpack - where - go lineRev [] = reverseTrimmed lineRev - go lineRev (0x0d:0x0a:rest) = - reverseTrimmed lineRev ++ [0x0d, 0x0a] ++ go [] rest - go lineRev (w:rest) = go (w : lineRev) rest - - reverseTrimmed :: [Word8] -> [Word8] - reverseTrimmed = reverse . dropWhile isTrailingWhitespace - - isTrailingWhitespace :: Word8 -> Bool - isTrailingWhitespace w = w == 0x20 || w == 0x09 - -hashWithSHA512 :: B.ByteString -> B.ByteString -hashWithSHA512 = BA.convert . hashWith CHA.SHA512 - -hashForSignatureAlgorithm :: HashAlgorithm -> B.ByteString -> Either String B.ByteString -hashForSignatureAlgorithm ha bs = - case ha of - SHA1 -> Right (BA.convert (hashWith CHA.SHA1 bs)) - RIPEMD160 -> Right (BA.convert (hashWith CHA.RIPEMD160 bs)) - SHA224 -> Right (BA.convert (hashWith CHA.SHA224 bs)) - SHA256 -> Right (BA.convert (hashWith CHA.SHA256 bs)) - SHA384 -> Right (BA.convert (hashWith CHA.SHA384 bs)) - SHA512 -> Right (BA.convert (hashWith CHA.SHA512 bs)) - SHA3_256 -> Right (BA.convert (hashWith CHA.SHA3_256 bs)) - SHA3_512 -> Right (BA.convert (hashWith CHA.SHA3_512 bs)) - DeprecatedMD5 -> Right (BA.convert (hashWith CHA.MD5 bs)) - _ -> Left ("unsupported hash algorithm for left16 derivation: " ++ show ha) - -left16FromHashPrefix :: B.ByteString -> Either String Word16 -left16FromHashPrefix bs - | B.length bs >= 2 = Right (fromIntegral (os2ip (B.take 2 bs))) - | otherwise = Left "hash output too short to derive left16" - -left16FromSignedPayload :: HashAlgorithm -> B.ByteString -> Either String Word16 -left16FromSignedPayload ha signedPayload = do - digest <- hashForSignatureAlgorithm ha signedPayload - left16FromHashPrefix digest - -left16FromSignedPayloadForSign :: HashAlgorithm -> B.ByteString -> Either SignError Word16 -left16FromSignedPayloadForSign ha = - first SignBackendError . left16FromSignedPayload ha - -ed25519Signer :: Ed25519.SecretKey -> B.ByteString -> B.ByteString -ed25519Signer sk prehash = - BA.convert (Ed25519.sign sk (Ed25519.toPublic sk) prehash) - -ed448Signer :: Ed448.SecretKey -> B.ByteString -> B.ByteString -ed448Signer sk prehash = - BA.convert (Ed448.sign sk (Ed448.toPublic sk) prehash) - -rsaPKCS15Sign :: - HashAlgorithm - -> RSATypes.PrivateKey - -> B.ByteString - -> Either SignError B.ByteString -rsaPKCS15Sign ha prv bytes = - case ha of - SHA1 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA1) prv bytes) - SHA224 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA224) prv bytes) - SHA256 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA256) prv bytes) - SHA384 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA384) prv bytes) - SHA512 -> first (SignBackendError . show) (P15.sign Nothing (Just CHA.SHA512) prv bytes) - _ -> - Left - (SignBackendError - ("signature hash algorithm is not supported by RSA PKCS#1 v1.5 backend: " ++ - show ha)) - -validateV6SaltSize :: HashAlgorithm -> SignatureSalt -> Either SignError () -validateV6SaltSize ha salt = - let saltBytes = BL.toStrict (unSignatureSalt salt) - actualSaltLen = B.length saltBytes - in case signatureV6SaltSizeForHashAlgorithm ha of - Nothing -> - Left - (SignBackendError - ("signature hash algorithm does not define a V6 salt size: " ++ show ha)) - Just expectedSaltLen -> - if actualSaltLen == fromIntegral expectedSaltLen - then Right () - else Left (SignV6SaltSizeMismatch ha expectedSaltLen actualSaltLen) - -signEdDSAV4 :: - String - -> Int - -> Int - -> (B.ByteString -> B.ByteString) - -> TextNormalizationMode - -> SigType - -> PubKeyAlgorithm - -> HashAlgorithm - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either SignError SignaturePayload -signEdDSAV4 algoName sigLen limbLen signer mode st pka ha has uhas payload = do - let normalizedPayload = normalizePayloadForSigTypeWith mode st payload - sig0 = SigV4 st pka ha has [] 0 (NE.fromList [MPI 0, MPI 0]) - prehash = - hashWithSHA512 - (BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload)) - sigBytes = signer prehash - if B.length sigBytes /= sigLen - then Left (SignProducedWrongLength algoName sigLen (B.length sigBytes)) - else - let (r, s) = B.splitAt limbLen sigBytes - in (\left16 -> - SigV4 - st - pka - ha - has - uhas - left16 - (NE.fromList [MPI (os2ip r), MPI (os2ip s)])) - <$> first SignBackendError (left16FromHashPrefix prehash) - -signEdDSAV6 :: - String - -> Int - -> Int - -> (B.ByteString -> B.ByteString) - -> TextNormalizationMode - -> SigType - -> PubKeyAlgorithm - -> HashAlgorithm - -> SignatureSalt - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either SignError SignaturePayload -signEdDSAV6 algoName sigLen limbLen signer mode st pka ha salt has uhas payload = do - validateV6SaltSize ha salt - let normalizedPayload = normalizePayloadForSigTypeWith mode st payload - sig0 = SigV6 st pka ha salt has [] 0 (NE.fromList [MPI 0, MPI 0]) - prehash = - hashWithSHA512 - (BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload)) - sigBytes = signer prehash - if B.length sigBytes /= sigLen - then Left (SignProducedWrongLength algoName sigLen (B.length sigBytes)) - else - let (r, s) = B.splitAt limbLen sigBytes - in (\left16 -> - SigV6 - st - pka - ha - salt - has - uhas - left16 - (NE.fromList [MPI (os2ip r), MPI (os2ip s)])) - <$> first SignBackendError (left16FromHashPrefix prehash) - -signUserIDwithRSA :: SomePKPayload -- ^ public key "payload" of user ID being signed - -> UserId -- ^ user ID being signed - -> [SigSubPacket] -- ^ hashed signature subpackets - -> [SigSubPacket] -- ^ unhashed signature subpackets - -> RSATypes.PrivateKey -- ^ RSA signing key - -> Either SignError SignaturePayload -signUserIDwithRSA = signCertificationWithRSA PositiveCert - -signCertificationWithRSA :: - SigType -- ^ certification type (GenericCert, PersonaCert, CasualCert, PositiveCert) - -> SomePKPayload -- ^ public key "payload" of user ID being signed - -> UserId -- ^ user ID being signed - -> [SigSubPacket] -- ^ hashed signature subpackets - -> [SigSubPacket] -- ^ unhashed signature subpackets - -> RSATypes.PrivateKey -- ^ RSA signing key - -> Either SignError SignaturePayload -signCertificationWithRSA st pkp uid hsigsubs usigsubs prv - | st `elem` [GenericCert, PersonaCert, CasualCert, PositiveCert] = do - let payloadToSign = BL.toStrict (finalPayload (SignaturePkt uidsigp) uidpayload) - uidsigp' - <$> left16FromSignedPayloadForSign SHA512 payloadToSign - <*> first - (SignBackendError . show) - (P15.sign - Nothing - (Just CHA.SHA512) - prv - payloadToSign) - | otherwise = - Left (SignUnsupportedCertificationType st) - where - uidpayload = - runPut - (sequence_ - [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)]) - uidsigp = - SigV4 st RSA SHA512 hsigsubs usigsubs 0 (NE.fromList [MPI 0]) - uidsigp' left16 us = - SigV4 - st - RSA - SHA512 - hsigsubs - usigsubs - left16 - (NE.fromList [MPI (os2ip us)]) - -signDirectKeyWithRSA :: - SigType -- ^ key-scoped signature type (SignatureDirectlyOnAKey or KeyRevocationSig) - -> SomePKPayload -- ^ primary key "payload" being signed - -> [SigSubPacket] -- ^ hashed signature subpackets - -> [SigSubPacket] -- ^ unhashed signature subpackets - -> RSATypes.PrivateKey -- ^ RSA signing key - -> Either SignError SignaturePayload -signDirectKeyWithRSA st pkp hsigsubs usigsubs prv - | st `elem` [SignatureDirectlyOnAKey, KeyRevocationSig] = - signDataWithRSA st prv hsigsubs usigsubs keypayload - | otherwise = - Left (SignUnsupportedKeySignatureType st) - where - keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp)) - -signKeyRevocationWithRSA :: SomePKPayload -- ^ primary key "payload" being revoked - -> [SigSubPacket] -- ^ hashed signature subpackets - -> [SigSubPacket] -- ^ unhashed signature subpackets - -> RSATypes.PrivateKey -- ^ RSA signing key - -> Either SignError SignaturePayload -signKeyRevocationWithRSA = signDirectKeyWithRSA KeyRevocationSig - -signSubkeyRevocationWithRSA :: SomePKPayload -- ^ primary key "payload" - -> SomePKPayload -- ^ public subkey "payload" being revoked - -> [SigSubPacket] -- ^ hashed signature subpackets - -> [SigSubPacket] -- ^ unhashed signature subpackets - -> RSATypes.PrivateKey -- ^ RSA signing key - -> Either SignError SignaturePayload -signSubkeyRevocationWithRSA pkp subpkp hsigsubs usigsubs prv = - signDataWithRSA SubkeyRevocationSig prv hsigsubs usigsubs subkeypayload - where - subkeypayload = - runPut - (sequence_ - [ putKeyforSigning (PublicKeyPkt pkp) - , putKeyforSigning (PublicSubkeyPkt subpkp) - ]) - -signCertRevocationWithRSA :: SomePKPayload -- ^ primary key "payload" - -> UserId -- ^ user ID certification being revoked - -> [SigSubPacket] -- ^ hashed signature subpackets - -> [SigSubPacket] -- ^ unhashed signature subpackets - -> RSATypes.PrivateKey -- ^ RSA signing key - -> Either SignError SignaturePayload -signCertRevocationWithRSA pkp uid hsigsubs usigsubs prv = - signDataWithRSA CertRevocationSig prv hsigsubs usigsubs certpayload - where - certpayload = - runPut - (sequence_ - [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)]) - -crossSignSubkeyWithRSA :: SomePKPayload -- ^ public key "payload" of key being signed - -> SomePKPayload -- ^ public subkey "payload" of key being signed - -> [SigSubPacket] -- ^ hashed signature subpackets for binding sig - -> [SigSubPacket] -- ^ unhashed signature subpackets for binding sig - -> [SigSubPacket] -- ^ hashed signature subpackets for embedded sig - -> [SigSubPacket] -- ^ unhashed signature subpackets for embedded sig - -> RSATypes.PrivateKey -- ^ RSA signing key - -> RSATypes.PrivateKey -- ^ RSA signing subkey - -> Either SignError SignaturePayload -crossSignSubkeyWithRSA pkp subpkp subhsigsubs subusigsubs embhsigsubs embusigsubs prv ssb = do - let embPayloadToSign = BL.toStrict (finalPayload (SignaturePkt embsigp) subkeypayload) - subPayloadToSign = BL.toStrict (finalPayload (SignaturePkt subsigp) subkeypayload) - (\embleft16 subleft16 embsig subsig -> - subsigp' (embsigp' embleft16 embsig) subleft16 subsig) - <$> left16FromSignedPayloadForSign SHA512 embPayloadToSign - <*> left16FromSignedPayloadForSign SHA512 subPayloadToSign - <*> first - (SignBackendError . show) - (P15.sign - Nothing - (Just CHA.SHA512) - ssb - embPayloadToSign) - <*> first - (SignBackendError . show) - (P15.sign - Nothing - (Just CHA.SHA512) - prv - subPayloadToSign) - where - subkeypayload = - runPut - (sequence_ - [ putKeyforSigning (PublicKeyPkt pkp) - , putKeyforSigning (PublicSubkeyPkt subpkp) - ]) - embsigp = - SigV4 - PrimaryKeyBindingSig - RSA - SHA512 - embhsigsubs - embusigsubs - 0 - (NE.fromList [MPI 0]) - embsigp' left16 es = - SigV4 - PrimaryKeyBindingSig - RSA - SHA512 - embhsigsubs - embusigsubs - left16 - (NE.fromList [MPI (os2ip es)]) - subsigp = - SigV4 SubkeyBindingSig RSA SHA512 subhsigsubs [] 0 (NE.fromList [MPI 0]) - sspes es = SigSubPacket False (EmbeddedSignature es) - subsigp' es left16 ss = - SigV4 - SubkeyBindingSig - RSA - SHA512 - subhsigsubs - (sspes es : subusigsubs) - left16 - (NE.fromList [MPI (os2ip ss)]) - -signRSAV4Core :: - TextNormalizationMode - -> SigType - -> HashAlgorithm - -> [SigSubPacket] - -> [SigSubPacket] - -> RSATypes.PrivateKey - -> ByteString - -> Either SignError SignaturePayload -signRSAV4Core mode st ha has uhas prv payload = - (\left16 ss -> SigV4 st RSA ha has uhas left16 (NE.fromList [MPI (os2ip ss)])) - <$> left16FromSignedPayloadForSign ha payloadToSign - <*> rsaPKCS15Sign ha prv payloadToSign - where - sig0 = SigV4 st RSA ha has [] 0 (NE.fromList [MPI 0]) - payloadToSign = BL.toStrict (finalPayload (SignaturePkt sig0) (normalizePayloadForSigTypeWith mode st payload)) - -signRSAV6Core :: - TextNormalizationMode - -> SigType - -> HashAlgorithm - -> SignatureSalt - -> [SigSubPacket] - -> [SigSubPacket] - -> RSATypes.PrivateKey - -> ByteString - -> Either SignError SignaturePayload -signRSAV6Core mode st ha salt has uhas prv payload = do - validateV6SaltSize ha salt - (\left16 sigBytes -> SigV6 st RSA ha salt has uhas left16 (NE.fromList [MPI (os2ip sigBytes)])) - <$> left16FromSignedPayloadForSign ha payloadToSign - <*> rsaPKCS15Sign ha prv payloadToSign - where - sig0 = SigV6 st RSA ha salt has [] 0 (NE.fromList [MPI 0]) - payloadToSign = BL.toStrict (finalPayload (SignaturePkt sig0) (normalizePayloadForSigTypeWith mode st payload)) - -signDataWithRSA :: - SigType - -> RSATypes.PrivateKey - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either SignError SignaturePayload -signDataWithRSA st prv has uhas payload = - signRSAV4Core CleartextCompat st SHA512 has uhas prv payload - -signDataWithRSAV6 :: - SigType - -> SignatureSalt - -> RSATypes.PrivateKey - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either SignError SignaturePayload -signDataWithRSAV6 st salt prv has uhas payload = - signRSAV6Core CleartextCompat st SHA512 salt has uhas prv payload - --- FIXME: clean this up -ed25519Params, ed25519LegacyParams, ed448Params :: (String, Int, Int, PubKeyAlgorithm) -ed25519Params = ("Ed25519", 64, 32, PKA.Ed25519) -ed25519LegacyParams = ("Ed25519Legacy", 64, 32, PKA.EdDSA) -ed448Params = ("Ed448", 114, 57, PKA.Ed448) - -signDataWithEdDSAV4Generic :: - (String, Int, Int, PubKeyAlgorithm) - -> (B.ByteString -> B.ByteString) - -> TextNormalizationMode - -> HashAlgorithm - -> SigType - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either SignError SignaturePayload -signDataWithEdDSAV4Generic (algoName, sigLen, limbLen, pka) signer mode ha st has uhas payload = - signEdDSAV4 algoName sigLen limbLen signer mode st pka ha has uhas payload - -signDataWithEdDSAV6Generic :: - (String, Int, Int, PubKeyAlgorithm) - -> (B.ByteString -> B.ByteString) - -> TextNormalizationMode - -> HashAlgorithm - -> SigType - -> SignatureSalt - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either SignError SignaturePayload -signDataWithEdDSAV6Generic (algoName, sigLen, limbLen, pka) signer mode ha st salt has uhas payload = - signEdDSAV6 algoName sigLen limbLen signer mode st pka ha salt has uhas payload - -signDataWithEd25519 :: - SigType - -> Ed25519.SecretKey - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either SignError SignaturePayload -signDataWithEd25519 st sk has uhas payload = - signDataWithEdDSAV4Generic ed25519Params (ed25519Signer sk) CleartextCompat SHA512 st has uhas payload - -signDataWithEd25519Legacy :: - SigType - -> Ed25519.SecretKey - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either SignError SignaturePayload -signDataWithEd25519Legacy st sk has uhas payload = - signDataWithEdDSAV4Generic ed25519LegacyParams (ed25519Signer sk) CleartextCompat SHA512 st has uhas payload - -signDataWithEd25519V6 :: - SigType - -> SignatureSalt - -> Ed25519.SecretKey - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either SignError SignaturePayload -signDataWithEd25519V6 st salt sk has uhas payload = - signDataWithEdDSAV6Generic ed25519Params (ed25519Signer sk) CleartextCompat SHA512 st salt has uhas payload - -signDataWithEd448 :: - SigType - -> Ed448.SecretKey - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either SignError SignaturePayload -signDataWithEd448 st sk has uhas payload = - signDataWithEdDSAV4Generic ed448Params (ed448Signer sk) CleartextCompat SHA512 st has uhas payload - -signDataWithEd448V6 :: - SigType - -> SignatureSalt - -> Ed448.SecretKey - -> [SigSubPacket] - -> [SigSubPacket] - -> ByteString - -> Either SignError SignaturePayload -signDataWithEd448V6 st salt sk has uhas payload = - signDataWithEdDSAV6Generic ed448Params (ed448Signer sk) CleartextCompat SHA512 st salt has uhas payload - --- | Builder-based signature creation for RSA --- --- Example usage: --- builder <- sigBuilderInit BinarySig RSA SHA512 --- builder' <- addHashedSubs hashedSubpackets builder --- builder'' <- addUnhashedSubs unhashedSubpackets builder' --- sig <- signDataWithRSABuilder builder'' rsaPrivateKey payload -signDataWithRSABuilder :: - SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig 'PKA.RSA - -> RSATypes.PrivateKey - -> ByteString - -> Either SignError SignaturePayload -signDataWithRSABuilder builder prv payload = - signRSAV4Core - (sbTextNormMode builder) - (sbSigType builder) - (sbHashAlgo builder) - (sbHashedSubs builder) - (sbUnhashedSubs builder) - prv - payload - --- | Builder-based signature creation for RSA (v6) -signDataWithRSAV6Builder :: - SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V6Sig 'PKA.RSA - -> RSATypes.PrivateKey - -> ByteString - -> Either SignError SignaturePayload -signDataWithRSAV6Builder builder prv payload = - signRSAV6Core - (sbTextNormMode builder) - (sbSigType builder) - (sbHashAlgo builder) - (sbSalt builder) - (sbHashedSubs builder) - (sbUnhashedSubs builder) - prv - payload - --- | Builder-based signature creation for Ed25519 (v4) --- --- Example usage: --- builder <- sigBuilderInit BinarySig Ed25519 SHA512 --- builder' <- addHashedSubs hashedSubpackets builder --- builder'' <- addUnhashedSubs unhashedSubpackets builder' --- sig <- signDataWithEd25519Builder builder'' ed25519PrivateKey payload -signDataWithEd25519Builder :: - SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig 'PKA.Ed25519 - -> Ed25519.SecretKey - -> ByteString - -> Either SignError SignaturePayload -signDataWithEd25519Builder builder sk payload = - signDataWithEdDSAV4Generic ed25519Params (ed25519Signer sk) - (sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder) - (sbHashedSubs builder) (sbUnhashedSubs builder) payload - --- | Builder-based signature creation for Ed25519 (v6) --- --- Example usage: --- builder <- sigBuilderInitV6 BinarySig Ed25519 SHA512 salt --- builder' <- addHashedSubs hashedSubpackets builder --- builder'' <- addUnhashedSubs unhashedSubpackets builder' --- sig <- signDataWithEd25519V6Builder builder'' ed25519PrivateKey payload -signDataWithEd25519V6Builder :: - SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V6Sig 'PKA.Ed25519 - -> Ed25519.SecretKey - -> ByteString - -> Either SignError SignaturePayload -signDataWithEd25519V6Builder builder sk payload = - signDataWithEdDSAV6Generic ed25519Params (ed25519Signer sk) - (sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder) - (sbSalt builder) (sbHashedSubs builder) (sbUnhashedSubs builder) payload - --- | Builder-based signature creation for Ed448 (v4) --- --- Example usage: --- builder <- sigBuilderInit BinarySig Ed448 SHA512 --- builder' <- addHashedSubs hashedSubpackets builder --- builder'' <- addUnhashedSubs unhashedSubpackets builder' --- sig <- signDataWithEd448Builder builder'' ed448PrivateKey payload -signDataWithEd448Builder :: - SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig 'PKA.Ed448 - -> Ed448.SecretKey - -> ByteString - -> Either SignError SignaturePayload -signDataWithEd448Builder builder sk payload = - signDataWithEdDSAV4Generic ed448Params (ed448Signer sk) - (sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder) - (sbHashedSubs builder) (sbUnhashedSubs builder) payload - --- | Builder-based signature creation for Ed448 (v6) -signDataWithEd448V6Builder :: - SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V6Sig 'PKA.Ed448 - -> Ed448.SecretKey - -> ByteString - -> Either SignError SignaturePayload -signDataWithEd448V6Builder builder sk payload = - signDataWithEdDSAV6Generic ed448Params (ed448Signer sk) - (sbTextNormMode builder) (sbHashAlgo builder) (sbSigType builder) - (sbSalt builder) (sbHashedSubs builder) (sbUnhashedSubs builder) payload - --- | Algorithm-agnostic signature builder dispatcher (Phase 2) --- --- Dispatches to the appropriate signing function based on the private key type. --- The private key type (PrivateKeyFor algo) encodes the algorithm at the type level, --- allowing compile-time verification that the key and builder algorithm match. --- --- Example usage: -class BuilderSigningAlgorithm (algo :: PKA.PubKeyAlgorithm) where - signDataWithAlgorithmicBuilderImpl - :: SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig algo - -> PrivateKeyFor algo - -> ByteString - -> Either SignError SignaturePayload - -instance BuilderSigningAlgorithm 'PKA.RSA where - signDataWithAlgorithmicBuilderImpl builder (SP.RSAPrivateKey prv) payload = - signDataWithRSABuilder builder prv payload - -instance BuilderSigningAlgorithm 'PKA.Ed25519 where - signDataWithAlgorithmicBuilderImpl builder (SP.Ed25519PrivateKey sk) payload = - signDataWithEd25519Builder builder sk payload - -instance BuilderSigningAlgorithm 'PKA.Ed448 where - signDataWithAlgorithmicBuilderImpl builder (SP.Ed448PrivateKey sk) payload = - signDataWithEd448Builder builder sk payload - --- | Catch-all instance that produces a compile-time error for any algorithm --- that is not supported by the algorithmic builder (e.g. DSA, ECDSA). -instance {-# OVERLAPPABLE #-} - TypeError - ( 'Text "signDataWithAlgorithmicBuilder does not support this algorithm." - ':$$: 'Text "Supported algorithms: RSA, Ed25519, Ed448." - ':$$: 'Text "For DSA or ECDSA, use signDataWith{DSA,ECDSA}Builder directly." - ) - => BuilderSigningAlgorithm algo where - signDataWithAlgorithmicBuilderImpl = error "unreachable: TypeError fires at compile time" - -signDataWithAlgorithmicBuilder - :: forall (algo :: PKA.PubKeyAlgorithm) - . BuilderSigningAlgorithm algo - => SigBuilder Codec.Encryption.OpenPGP.Types.Unhashed Codec.Encryption.OpenPGP.Types.V4Sig algo - -> PrivateKeyFor algo - -> ByteString - -> Either SignError SignaturePayload -signDataWithAlgorithmicBuilder = - signDataWithAlgorithmicBuilderImpl +{-# LANGUAGE ConstraintKinds #-} +-- Signatures.hs: OpenPGP (RFC9580) signature verification +-- Copyright © 2012-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 ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Codec.Encryption.OpenPGP.Signatures + ( SignError (..) + , renderSignError + , CertificationState (..) + , certificationStateAt + , VerificationError (..) + , renderVerificationError + , verifySigWith + , verifyAgainstKeyring + , verifyAgainstKeys + , verifyAgainstKeysWithPolicy + , verifyAgainstPKPs + , verifyAgainstPKPsWithPolicy + , verifyTKWith + , verifyUnknownTKWith + , signCertificationWithRSA + , signDirectKeyWithRSA + , signKeyRevocationWithRSA + , signSubkeyRevocationWithRSA + , signCertRevocationWithRSA + , signUserIDwithRSA + , crossSignSubkeyWithRSA + , signDataWithEd25519 + , signDataWithEd25519Legacy + , signDataWithEd25519V6 + , signDataWithEd448 + , signDataWithEd448V6 + , signDataWithRSA + , signDataWithRSAV6 + + -- * Builder-based API (Phase 2) + , signDataWithRSABuilder + , signDataWithRSAV6Builder + , signDataWithEd25519Builder + , signDataWithEd25519V6Builder + , signDataWithEd448Builder + , signDataWithEd448V6Builder + , signDataWithAlgorithmicBuilder + + -- * Text normalization mode + , TextNormalizationMode (..) + ) where + +import Control.Applicative ((<|>)) +import Control.Error.Util (hush) +import Control.Lens ((&), (^.), _1) +import Control.Monad (liftM2, when) +import Crypto.Error (eitherCryptoError) +import Crypto.Hash (hashWith) +import qualified Crypto.Hash.Algorithms as CHA +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.RSA.PKCS15 as P15 +import qualified Crypto.PubKey.RSA.Types as RSATypes +import Data.Bifunctor (first) +import Data.Binary.Put (runPut) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL +import Data.Either (isRight, lefts, rights) +import Data.Function (on) +import Data.IxSet.Typed ((@=)) +import qualified Data.IxSet.Typed as IxSet +import Data.List (find, intercalate, nub) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe (isJust, mapMaybe) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Time.Clock (UTCTime (..), addUTCTime, diffUTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Word (Word16, Word8) +import GHC.TypeLits (ErrorMessage (..), TypeError) + +import Codec.Encryption.OpenPGP.Expirations + ( isPKTimeValidWithSelfSignatures + , keyStateAt + , keyStateValid + ) +import Codec.Encryption.OpenPGP.Fingerprint + ( eightOctetKeyID + , fingerprint + ) +import Codec.Encryption.OpenPGP.Internal + ( PktStreamContext (..) + , emptyPSC + , issuer + , issuerFP + ) +import Codec.Encryption.OpenPGP.Ontology + ( isCertRevocationSig + , isRevocationKeySSP + , isRevokerP + , isSubkeyBindingSig + , isSubkeyRevocation + ) +import Codec.Encryption.OpenPGP.Policy + ( VerificationPolicy (..) + , VerificationPolicyAction (..) + , applyVerificationPolicy + , defaultVerificationPolicy + , isVerificationError + , isVerificationWarning + , signatureV6SaltSizeForHashAlgorithm + ) +import Codec.Encryption.OpenPGP.SerializeForSigs + ( payloadForSig + , putKeyforSigning + , putPartialSigforSigning + , putSigTrailer + , putUforSigning + ) +import Codec.Encryption.OpenPGP.SignatureQualities + ( sigCT + , sigHA + , sigPKA + , sigType + , signatureHashedSubpacketsKnown + , signatureSubpacketListsKnown + ) +import Codec.Encryption.OpenPGP.Subpackets + ( PrivateKeyFor + , SigBuilder + , TextNormalizationMode (..) + , sbHashAlgo + , sbHashedSubs + , sbSalt + , sbSigType + , sbTextNormMode + , sbUnhashedSubs + ) +import qualified Codec.Encryption.OpenPGP.Subpackets as SP +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA +import Codec.Encryption.OpenPGP.Types.Internal.Pkt + ( VerificationWarning (..) + ) +import Data.Conduit.OpenPGP.Keyring.Instances () + +data VerificationError + = IssuerSubpacketMismatch + | IssuerSubpacketUncheckable String + | IssuerKeyIdProhibitedInV6Signature + | IssuerFingerprintSubpacketMismatch + | UnsupportedCriticalSubpacket SigType + | UnknownCriticalPacketInStream Word8 + | BrokenCriticalPacketInStream Word8 String + | ExternalVerificationError String + | NonSignaturePacket + | UnexpectedSignaturePayloadShape + | MissingHashAlgorithm + | HashComputationFailed String + | UnexpectedKeyVersion + | SignatureHashUnsupportedByAlgorithm HashAlgorithm PubKeyAlgorithm + | KeyRevoked + | SigningKeyUnavailableAtSignatureTime + | MissingIssuer + | SigningKeyNotFound (Maybe EightOctetKeyId) (Maybe Fingerprint) + | MultipleVerificationSuccesses Int + | UnsupportedKeyType PubKeyAlgorithm + | SignatureMismatch PubKeyAlgorithm Fingerprint + | SignatureShapeMismatch PubKeyAlgorithm + | SignatureEncodingInvalid PubKeyAlgorithm String + | SignaturePolicyHashUnsupported HashAlgorithm + | SignaturePolicyPKAMismatch PubKeyAlgorithm PubKeyAlgorithm + | SignatureExpired + | CandidateKeyFailures [VerificationError] + | {- | An embedded primary-key back-signature (type 0x19) in a subkey + binding signature failed to verify. + -} + InvalidSubkeyBackSignature VerificationError + deriving (Eq, Show) + +data CertificationState + = CertificationNotYetKnown + | CertificationActive + | CertificationRevoked + deriving (Eq, Show) + +renderVerificationError :: VerificationError -> String +renderVerificationError IssuerSubpacketMismatch = + "verification failed: issuer subpacket does not match the actual signer" +renderVerificationError (IssuerSubpacketUncheckable err) = + "verification failed: issuer subpacket cannot be checked (" + ++ err + ++ ")" +renderVerificationError IssuerKeyIdProhibitedInV6Signature = + "verification failed: Issuer Key ID subpacket is prohibited in v6 signatures" +renderVerificationError IssuerFingerprintSubpacketMismatch = + "verification failed: issuer fingerprint subpacket does not match the actual signer" +renderVerificationError (UnsupportedCriticalSubpacket sigType) = + "verification failed: unsupported critical hashed subpacket in " + ++ show sigType + ++ " signature" +renderVerificationError (UnknownCriticalPacketInStream t) = + "verification failed: unknown critical packet type in packet sequence (" + ++ show t + ++ ")" +renderVerificationError (BrokenCriticalPacketInStream t err) = + "verification failed: broken critical packet type " + ++ show t + ++ ": " + ++ err +renderVerificationError (ExternalVerificationError err) = err +renderVerificationError NonSignaturePacket = + "verification failed: non-signature packet encountered where signature was expected" +renderVerificationError UnexpectedSignaturePayloadShape = + "verification failed: unexpected signature payload shape" +renderVerificationError MissingHashAlgorithm = + "verification failed: signature payload is missing hash algorithm" +renderVerificationError (HashComputationFailed err) = + "verification failed: hash computation error (" ++ err ++ ")" +renderVerificationError UnexpectedKeyVersion = + "verification failed: signing key has unexpected version (only v4 and v6 are supported)" +renderVerificationError (SignatureHashUnsupportedByAlgorithm ha pka) = + "verification failed: hash algorithm " + ++ show ha + ++ " is not supported by " + ++ show pka + ++ " signing backend" +renderVerificationError KeyRevoked = + "verification failed: signing key is revoked" +renderVerificationError SigningKeyUnavailableAtSignatureTime = + "verification failed: signing key was not valid at the signature creation time" +renderVerificationError MissingIssuer = + "verification failed: signature is missing issuer information" +renderVerificationError (SigningKeyNotFound meoki mfp) = + "verification failed: signing key not found in keyring" + ++ issuerContext meoki mfp +renderVerificationError (MultipleVerificationSuccesses n) = + "verification failed: multiple successful key matches (" + ++ show n + ++ ")" +renderVerificationError (UnsupportedKeyType pka) = + "verification failed: unsupported public key algorithm for verification (" + ++ show pka + ++ ")" +renderVerificationError (SignatureMismatch pka fpr) = + "verification failed: " + ++ show pka + ++ " signature mismatch (signer " + ++ show fpr + ++ ")" +renderVerificationError (SignatureShapeMismatch pka) = + "verification failed: malformed " + ++ show pka + ++ " signature encoding" +renderVerificationError (SignatureEncodingInvalid pka err) = + "verification failed: invalid " + ++ show pka + ++ " key/signature encoding (" + ++ err + ++ ")" +renderVerificationError (SignaturePolicyHashUnsupported ha) = + "verification failed: unsupported signature hash policy (" + ++ show ha + ++ ")" +renderVerificationError (SignaturePolicyPKAMismatch sigPka keyPka) = + "verification failed: signature public-key algorithm " + ++ show sigPka + ++ " does not match key algorithm " + ++ show keyPka +renderVerificationError SignatureExpired = + "verification failed: signature expired" +renderVerificationError (CandidateKeyFailures errs) = + "verification failed: no candidate key validated the signature (" + ++ intercalate "; " (nub (map renderVerificationError errs)) + ++ ")" +renderVerificationError (InvalidSubkeyBackSignature err) = + "verification failed: embedded primary-key back-signature verification failed: " + ++ renderVerificationError err + +issuerContext + :: Maybe EightOctetKeyId -> Maybe Fingerprint -> String +issuerContext meoki mfp = + case (meoki, mfp) of + (Nothing, Nothing) -> "" + _ -> + " (issuer-keyid=" + ++ maybe "unknown" show meoki + ++ ", issuer-fingerprint=" + ++ maybe "unknown" show mfp + ++ ")" + +verificationError + :: VerificationError -> Either VerificationError a +verificationError = Left + +renderVerificationResult + :: Either VerificationError a -> Either String a +renderVerificationResult = first renderVerificationError + +data SignError + = SignBackendError String + | SignUnsupportedCertificationType SigType + | SignUnsupportedKeySignatureType SigType + | SignV6SaltSizeMismatch HashAlgorithm Word8 Int + | SignProducedWrongLength String Int Int + deriving (Eq, Show) + +renderSignError :: SignError -> String +renderSignError (SignBackendError err) = + "signature backend error: " ++ err +renderSignError (SignUnsupportedCertificationType st) = + "unsupported certification signature type: " + ++ show st + ++ " (expected one of GenericCert/PersonaCert/CasualCert/PositiveCert)" +renderSignError (SignUnsupportedKeySignatureType st) = + "unsupported key signature type: " + ++ show st + ++ " (expected SignatureDirectlyOnAKey or KeyRevocationSig)" +renderSignError (SignV6SaltSizeMismatch ha expected actual) = + "v6 signature salt size mismatch for " + ++ show ha + ++ ": expected " + ++ show expected + ++ ", got " + ++ show actual +renderSignError (SignProducedWrongLength algo expected actual) = + algo + ++ " produced a non-" + ++ show expected + ++ "-byte signature (got " + ++ show actual + ++ ")" + +data VerifiableSignatureV where + VerifiableSignatureV4 + :: SignaturePayloadV 'SigPayloadV4 -> VerifiableSignatureV + VerifiableSignatureV6 + :: SignaturePayloadV 'SigPayloadV6 -> VerifiableSignatureV + +fromSignaturePayloadVerifiableSignatureV + :: SignaturePayload -> Maybe VerifiableSignatureV +fromSignaturePayloadVerifiableSignatureV sigPayload = + case toSomeSignaturePayload sigPayload of + SomeSignaturePayload (payload@SigPayloadV4Data {}) -> + Just (VerifiableSignatureV4 payload) + SomeSignaturePayload (payload@SigPayloadV6Data {}) -> + Just (VerifiableSignatureV6 payload) + _ -> Nothing + +isVerifiableSignaturePayload :: SignaturePayload -> Bool +isVerifiableSignaturePayload = isJust . fromSignaturePayloadVerifiableSignatureV + +toSignaturePayloadFromVerifiable + :: VerifiableSignatureV -> SignaturePayload +toSignaturePayloadFromVerifiable (VerifiableSignatureV4 payload) = + toSignaturePayload payload +toSignaturePayloadFromVerifiable (VerifiableSignatureV6 payload) = + toSignaturePayload payload + +fromPktEitherVerifiableSignatureV + :: Pkt -> Either VerificationError VerifiableSignatureV +fromPktEitherVerifiableSignatureV (SignaturePkt sigPayload) = + case fromSignaturePayloadVerifiableSignatureV sigPayload of + Just verifiableSig -> Right verifiableSig + Nothing -> + verificationError UnexpectedSignaturePayloadShape +fromPktEitherVerifiableSignatureV _ = + verificationError NonSignaturePacket + +signaturePKAAndMPIsFromClass + :: SomeSignatureV + -> Either VerificationError (PubKeyAlgorithm, NonEmpty MPI) +signaturePKAAndMPIsFromClass = + fmap (\(pka, _, mpis) -> (pka, mpis)) + . signatureVerificationMaterialFromClass + +signatureLeft16FromClass + :: SomeSignatureV -> Either VerificationError Word16 +signatureLeft16FromClass = + fmap (\(_, l16, _) -> l16) + . signatureVerificationMaterialFromClass + +signatureVerificationMaterialFromClass + :: SomeSignatureV + -> Either VerificationError (PubKeyAlgorithm, Word16, NonEmpty MPI) +signatureVerificationMaterialFromClass (SomeSignatureV typedSig) = + case typedSig of + SignatureV3Packet (SigPayloadV3Data _ _ _ pka _ l16 mpis) -> + Right (pka, l16, mpis) + SignatureV4Packet (SigPayloadV4Data _ pka _ _ _ l16 mpis) -> + Right (pka, l16, mpis) + SignatureV6Packet (SigPayloadV6Data _ pka _ _ _ _ l16 mpis) -> + Right (pka, l16, mpis) + _ -> + verificationError UnexpectedSignaturePayloadShape + +verifySigWith + :: VerificationPolicy + -> ( Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification + ) + -> Pkt + -> PktStreamContext + -> Maybe UTCTime + -> Either VerificationError Verification +verifySigWith policy vf sig@(SignaturePkt _) state mt = + case fromPktEitherVerifiableSignatureV sig of + Right verifiableSig -> + let (st, hs, us, checkSubpacket, checkUnhashedSubpackets) = + verifiableSignatureVerificationInputs verifiableSig + in checkUnhashedSubpackets us + *> verifyWithSubpacketChecks + policy + vf + sig + state + mt + st + hs + checkSubpacket + Left err -> + Left err + where + checkV4Subpacket signer i@Issuer {} = checkIssuerSubpacket (eightOctetKeyID signer) i + checkV4Subpacket signer i@IssuerFingerprint {} = + checkIssuerFingerprintSubpacket + PKA.IssuerFingerprintV4 + (fingerprint signer) + i + checkV4Subpacket _ _ = Right True + -- RFC 9580 §5.2.3.35: v6 signatures MUST NOT include an Issuer Key ID subpacket. + -- Treat any such subpacket as a verification error rather than merely uncheckable. + checkV6Subpacket _ Issuer {} = + case applyVerificationPolicy + (vpLegacyIssuerKeyIdInV6 policy) + "Issuer Key ID subpacket is prohibited in v6 signatures" of + Left err -> verificationError IssuerKeyIdProhibitedInV6Signature + Right warn -> Right True -- We don't have a warning type for this yet + checkV6Subpacket signer i@IssuerFingerprint {} = + checkIssuerFingerprintSubpacket + PKA.IssuerFingerprintV6 + (fingerprint signer) + i + checkV6Subpacket _ _ = Right True + rejectV6UnhashedIssuer (SigSubPacket _ Issuer {}) = + case applyVerificationPolicy + (vpLegacyIssuerKeyIdInV6 policy) + "Issuer Key ID subpacket is prohibited in v6 signatures" of + Left err -> verificationError IssuerKeyIdProhibitedInV6Signature + Right warn -> Right () -- We don't have a warning type for this yet + rejectV6UnhashedIssuer _ = Right () + verifiableSignatureVerificationInputs + :: VerifiableSignatureV + -> ( SigType + , [SigSubPacket] + , [SigSubPacket] + , SomePKPayload + -> SigSubPacketPayload + -> Either VerificationError Bool + , [SigSubPacket] -> Either VerificationError () + ) + verifiableSignatureVerificationInputs + (VerifiableSignatureV4 (SigPayloadV4Data st _ _ hs us _ _)) = + (st, hs, us, checkV4Subpacket, const (Right ())) + verifiableSignatureVerificationInputs + (VerifiableSignatureV6 (SigPayloadV6Data st _ _ _ hs us _ _)) = + (st, hs, us, checkV6Subpacket, mapM_ rejectV6UnhashedIssuer) +verifySigWith _ _ _ _ _ = + verificationError NonSignaturePacket + +verifyWithSubpacketChecks + :: VerificationPolicy + -> ( Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification + ) + -> Pkt + -> PktStreamContext + -> Maybe UTCTime + -> SigType + -> [SigSubPacket] + -> ( SomePKPayload + -> SigSubPacketPayload + -> Either VerificationError Bool + ) + -> Either VerificationError Verification +verifyWithSubpacketChecks policy vf sig state mt sigType hashedSubpackets checkSubpacket = do + mapM_ + (rejectUnsupportedCriticalSubpacket policy sigType) + hashedSubpackets + v <- vf sig mt (payloadForSig sigType state) + mapM_ + (checkSubpacket (v ^. verificationSigner) . _sspPayload) + hashedSubpackets + warnings <- + if sigType == SubkeyBindingSig + then verifySubkeyBackSignatures policy state mt hashedSubpackets + else Right [] + isSignatureExpired sig mt + *> pure + ( v + { _verificationWarnings = + _verificationWarnings v ++ warnings + } + ) + +{- | Verify embedded primary-key back-signatures (PrimaryKeyBindingSig, 0x19) +found in the hashed subpackets of a SubkeyBindingSig. + +Per RFC 9580 §5.2.3.3, a signing-capable subkey MUST include an embedded +PrimaryKeyBindingSig (0x19) made by the subkey. This requirement is +enforced strictly for v6 subkeys. For v4 subkeys we still verify any +embedded back-sigs that are present, but do not reject a missing one — +real-world v4 signing subkeys predate the strict cross-certification +mandate and widespread interoperability requires accepting them. +-} +verifySubkeyBackSignatures + :: VerificationPolicy + -> PktStreamContext + -> Maybe UTCTime + -> [SigSubPacket] + -> Either VerificationError [VerificationWarning] +verifySubkeyBackSignatures policy state mt hashedSubpackets = do + subkeyPKP <- + maybe + (verificationError NonSignaturePacket) + Right + (subkeyPKPFromPkt (lastSubkey state)) + let embeddedSigs = + [ sp + | SigSubPacket _ (EmbeddedSignature sp) <- hashedSubpackets + ] + isSigningCapable = + any + ( \(SigSubPacket _ payload) -> + case payload of + KeyFlags flags -> SignDataKey `Set.member` flags + _ -> False + ) + hashedSubpackets + isV6Subkey = _keyVersion subkeyPKP == V6 + case embeddedSigs of + [] -> + -- Require back-sig only for v6 signing subkeys (RFC 9580 §5.2.3.3). + if isSigningCapable && isV6Subkey + then case applyVerificationPolicy + (vpMissingSubkeyBackSignature policy) + "Missing subkey back-signature (v6 signing subkey)" of + Left err -> + verificationError (SignaturePolicyHashUnsupported DeprecatedMD5) -- We'll need a better error type + Right warn -> Right [MissingSubkeyBackSignatureWarning] + else Right [] + _ -> + -- Always verify back-sigs that are present, regardless of key version. + mapM_ (verifyOneBackSig policy subkeyPKP) embeddedSigs + *> Right [] + where + verifyOneBackSig vp subkeyPKP embSigPayload = do + let embSigPkt = SignaturePkt embSigPayload + backSigContext = + emptyPSC + { lastPrimaryKey = lastPrimaryKey state + , lastSubkey = lastSubkey state + } + case verifyAgainstKeyWithPolicy + vp + subkeyPKP + embSigPkt + mt + (payloadForSig PrimaryKeyBindingSig backSigContext) of + Left err -> verificationError (InvalidSubkeyBackSignature err) + Right _ -> Right () + +rejectUnsupportedCriticalSubpacket + :: VerificationPolicy + -> SigType + -> SigSubPacket + -> Either VerificationError () +rejectUnsupportedCriticalSubpacket policy sigType (SigSubPacket isCritical payload) + | not isCritical = Right () + | not (isBindingSignatureType sigType) = Right () + | otherwise = + case payload of + UserDefinedSigSub {} -> + case applyVerificationPolicy + (vpUnsupportedCriticalSubpacket policy) + ( "Unsupported critical subpacket in " + ++ show sigType + ++ " signature" + ) of + Left err -> verificationError (UnsupportedCriticalSubpacket sigType) + Right warn -> Right () -- We don't have a warning type for this yet + OtherSigSub {} -> + case applyVerificationPolicy + (vpUnsupportedCriticalSubpacket policy) + ( "Unsupported critical subpacket in " + ++ show sigType + ++ " signature" + ) of + Left err -> verificationError (UnsupportedCriticalSubpacket sigType) + Right warn -> Right () + _ -> Right () + +isBindingSignatureType :: SigType -> Bool +isBindingSignatureType SubkeyBindingSig = True +isBindingSignatureType PrimaryKeyBindingSig = True +isBindingSignatureType _ = False + +checkIssuerSubpacket + :: Either String EightOctetKeyId + -> SigSubPacketPayload + -> Either VerificationError Bool +checkIssuerSubpacket (Right signer) (Issuer i) + | signer == i = Right True + | otherwise = verificationError IssuerSubpacketMismatch +checkIssuerSubpacket (Left err) (Issuer _) = + verificationError (IssuerSubpacketUncheckable err) +checkIssuerSubpacket _ _ = Right True + +checkIssuerFingerprintSubpacket + :: IssuerFingerprintVersion + -> Fingerprint + -> SigSubPacketPayload + -> Either VerificationError Bool +checkIssuerFingerprintSubpacket expectedVersion signer (IssuerFingerprint kv i) + | kv /= expectedVersion = + verificationError IssuerFingerprintSubpacketMismatch + | signer == i = Right True + | otherwise = + verificationError IssuerFingerprintSubpacketMismatch +checkIssuerFingerprintSubpacket _ _ _ = Right True + +verifyTKWith + :: ( Pkt + -> PktStreamContext + -> Maybe UTCTime + -> Either VerificationError Verification + ) + -> Maybe UTCTime + -> TK k + -> Either VerificationError (TK k) +verifyTKWith vsf mt tk = do + verifiedUnknown <- verifyUnknownTKWith vsf mt (tkToUnknown tk) + let typedSubkeys = + Map.fromList [(keyPktToPkt kp, kp) | (kp, _) <- tk ^. tkSubs] + verifiedTypedSubkeys = + mapMaybe + ( \(pkt, sigs) -> (\kp -> (kp, sigs)) <$> Map.lookup pkt typedSubkeys + ) + (verifiedUnknown ^. tkuSubs) + pure + TK + { _tkPrimaryKey = tk ^. tkPrimaryKey + , _tkRevs = verifiedUnknown ^. tkuRevs + , _tkUIDs = verifiedUnknown ^. tkuUIDs + , _tkUAts = verifiedUnknown ^. tkuUAts + , _tkSubs = verifiedTypedSubkeys + } + +verifyUnknownTKWith + :: ( Pkt + -> PktStreamContext + -> Maybe UTCTime + -> Either VerificationError Verification + ) + -> Maybe UTCTime + -> TKUnknown + -> Either VerificationError TKUnknown +verifyUnknownTKWith vsf mt tk = do + revokers <- checkRevokers tk + revs <- checkKeyRevocations revokers tk + let uids = filter (not . null . snd) . checkUidSigs $ tk ^. tkuUIDs + let uats = filter (not . null . snd) . checkUAtSigs $ tk ^. tkuUAts + let subs = concatMap checkSub $ tk ^. tkuSubs + return (TKUnknown (tk ^. tkuKey) revs uids uats subs) + where + checkRevokers = + Right + . concat + . rights + . map verifyRevoker + . filter isRevokerP + . _tkuRevs + checkKeyRevocations + :: [(PubKeyAlgorithm, Fingerprint)] + -> TKUnknown + -> Either VerificationError [SignaturePayload] + checkKeyRevocations rs k = + Prelude.sequence + . concatMap (filterRevs rs) + . rights + . map (liftM2 fmap (,) vSig) + $ k + ^. tkuRevs + checkUidSigs + :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])] + checkUidSigs = + map + ( \(uid, sps) -> + let verified = rights . map (\sp -> fmap ((,) sp) (vUid (uid, sp))) $ sps + in (uid, retainNonRevokedCertifications mt verified) + ) + checkUAtSigs + :: [([UserAttrSubPacket], [SignaturePayload])] + -> [([UserAttrSubPacket], [SignaturePayload])] + checkUAtSigs = + map + ( \(uat, sps) -> + let verified = rights . map (\sp -> fmap ((,) sp) (vUAt (uat, sp))) $ sps + in (uat, retainNonRevokedCertifications mt verified) + ) + checkSub + :: (Pkt, [SignaturePayload]) -> [(Pkt, [SignaturePayload])] + checkSub (pkt, sps) = + if revokedSub pkt sps + then [] + else checkSub' pkt sps + revokedSub :: Pkt -> [SignaturePayload] -> Bool + revokedSub _ [] = False + revokedSub p sigs = + any (vSubSig p) (filter subkeyRevocationEffective sigs) + checkSub' + :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])] + checkSub' p sps = + let goodsigs = + filter (vSubSig p) + . filter signatureKnown + . filter isSubkeyBindingSig + $ sps + in if null goodsigs + then [] + else [(p, goodsigs)] + getHasheds = signatureHashedSubpackets + filterRevs + :: [(PubKeyAlgorithm, Fingerprint)] + -> (SignaturePayload, Verification) + -> [Either VerificationError SignaturePayload] + filterRevs vokers spv = + case spv of + (s, _) + | isV4OrV6Sig s && sigType s == Just SignatureDirectlyOnAKey -> + [Right s | signatureKnown s] + (s, v) + | isV4OrV6Sig s + , sigType s == Just KeyRevocationSig + , Just pka <- sigPKA s -> + if (v ^. verificationSigner == tk ^. tkuKey . _1) + || any + ( \(p, f) -> + p == pka && f == fingerprint (v ^. verificationSigner) + ) + vokers + then + if keyRevocationEffective s + then [verificationError KeyRevoked] + else [Right s | signatureKnown s] + else [Right s | signatureKnown s] + _ -> [] + isV4OrV6Sig = isVerifiableSignaturePayload + vUid + :: (Text, SignaturePayload) -> Either VerificationError Verification + vUid (uid, sp) = + vsf + (SignaturePkt sp) + emptyPSC + { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1) + , lastUIDorUAt = UserIdPkt uid + } + Nothing + vUAt + :: ([UserAttrSubPacket], SignaturePayload) + -> Either VerificationError Verification + vUAt (uat, sp) = + vsf + (SignaturePkt sp) + emptyPSC + { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1) + , lastUIDorUAt = UserAttributePkt uat + } + Nothing + vSig :: SignaturePayload -> Either VerificationError Verification + vSig sp = + vsf + (SignaturePkt sp) + emptyPSC {lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1)} + Nothing + vSubSig :: Pkt -> SignaturePayload -> Bool + vSubSig sk sp = + isRight + ( vsf + (SignaturePkt sp) + emptyPSC + { lastPrimaryKey = PublicKeyPkt (tk ^. tkuKey . _1) + , lastSubkey = sk + } + mt + ) + verifyRevoker + :: SignaturePayload + -> Either VerificationError [(PubKeyAlgorithm, Fingerprint)] + verifyRevoker sp = + vSig sp + *> pure + ( map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp)) + . filter isRevocationKeySSP + $ getHasheds sp + ) + retainNonRevokedCertifications + :: Maybe UTCTime + -> [(SignaturePayload, Verification)] + -> [SignaturePayload] + retainNonRevokedCertifications validationTime verified = + map fst $ + filter + ( (== CertificationActive) + . certificationStateAt validationTime verified + ) + certifications + where + certifications = filter (not . isCertRevocationSig . fst) verified + signatureKnown = signatureKnownAt mt + subkeyRevocationEffective sp = isSubkeyRevocation sp && signatureEffectiveAt mt sp + keyRevocationEffective sp + | isHistoricalKeyRevocation sp = signatureEffectiveAt mt sp + | otherwise = signatureUnexpiredAt mt sp + +verifyAgainstKeyring + :: PublicKeyring + -> Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification +verifyAgainstKeyring kr sig mt payload = do + let allKeys = map tkToUnknown (IxSet.toList kr) + signerValidationTime = signatureCreationTimeFromPacket sig + ikeys = (kr @=) <$> issuer sig + ifpkeys = (kr @=) <$> issuerFP sig + hintedKeys = maybe [] (map tkToUnknown . IxSet.toList) (ifpkeys <|> ikeys) + hintedResult = + if null hintedKeys + then Left MissingIssuer + else + verifyFromCandidates + allKeys + hintedKeys + sig + signerValidationTime + mt + payload + in case hintedResult of + Right v -> Right v + Left hintedErr -> + let fallbackResult = + verifyFromCandidates + allKeys + allKeys + sig + signerValidationTime + mt + payload + in if null hintedKeys + then case fallbackResult of + Right v -> Right v + Left _ -> + verificationError + (SigningKeyNotFound (issuer sig) (issuerFP sig)) + else case fallbackResult of + Right v -> Right v + Left _ -> Left hintedErr + +verifyFromCandidates + :: [TKUnknown] + -> [TKUnknown] + -> Pkt + -> Maybe UTCTime + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification +verifyFromCandidates allKeys candidateTks sig signerValidationTime verificationTime payload = + let candidateResults = + map + ( resolveCandidateSignerPKPs + allKeys + sig + signerValidationTime + (const True) + ) + candidateTks + candidateErrors = concatMap fst candidateResults + usablePkps = concatMap snd candidateResults + in if null usablePkps + then + if null candidateErrors + then + verificationError + (SigningKeyNotFound (issuer sig) (issuerFP sig)) + else verificationError (CandidateKeyFailures candidateErrors) + else case verifyAgainstPKPs usablePkps sig verificationTime payload of + Left (CandidateKeyFailures errs) + | not (null candidateErrors) -> + verificationError + (CandidateKeyFailures (candidateErrors ++ errs)) + other -> other + +verifyAgainstKeys + :: [TKUnknown] + -> Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification +verifyAgainstKeys ks sig mt payload = + verifyAgainstKeysWithPolicy + defaultVerificationPolicy + ks + sig + mt + payload + +-- | Verify a signature against a list of keys with a custom verification policy. +verifyAgainstKeysWithPolicy + :: VerificationPolicy + -> [TKUnknown] + -> Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification +verifyAgainstKeysWithPolicy policy ks sig mt payload = do + let allpkps = + filter + ( \x -> + (((fingerprint x ==) <$> issuerFP sig) == Just True) + || ((==) <$> issuer sig <*> hush (eightOctetKeyID x)) + == Just True + ) + ( concatMap + ( \x -> + (x ^. tkuKey . _1) + : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x) + ) + ks + ) + allCandidatePkps = + concatMap + ( \x -> + (x ^. tkuKey . _1) + : mapMaybe (subkeyPKPFromPkt . fst) (_tkuSubs x) + ) + ks + normalizedCandidates + | null allpkps = allCandidatePkps + | otherwise = allpkps + verifyAgainstPKPsWithPolicy + policy + normalizedCandidates + sig + mt + payload + +verifyAgainstPKPs + :: [SomePKPayload] + -> Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification +verifyAgainstPKPs pkps sig mt payload = + verifyAgainstPKPsWithPolicy + defaultVerificationPolicy + pkps + sig + mt + payload + +-- | Verify a signature against a list of public key payloads with a custom verification policy. +verifyAgainstPKPsWithPolicy + :: VerificationPolicy + -> [SomePKPayload] + -> Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification +verifyAgainstPKPsWithPolicy policy pkps sig mt payload = + case rights results of + [] -> verificationError (CandidateKeyFailures (lefts results)) + [r] -> isSignatureExpired sig mt *> pure r + rs -> verificationError (MultipleVerificationSuccesses (length rs)) + where + results = + map + (\pkp -> verifyAgainstKeyWithPolicy policy pkp sig mt payload) + pkps + +resolveCandidateSignerPKPs + :: [TKUnknown] + -> Pkt + -> Maybe UTCTime + -> (SomePKPayload -> Bool) + -> TKUnknown + -> ([VerificationError], [SomePKPayload]) +resolveCandidateSignerPKPs _ _ Nothing matchesP tk = + ([], filter matchesP (candidatePKPs tk)) +resolveCandidateSignerPKPs allKeys _ (Just validationTime) matchesP tk = + let rawMatches = filter matchesP (candidatePKPs tk) + in case verifyUnknownTKWith + ( verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys allKeys) + ) + (Just validationTime) + tk of + Left err -> (replicate (length rawMatches) err, []) + Right verifiedTK -> + let verifiedMatches = + map + ( \pkp -> + case historicallyValidSigner + validationTime + (timelineValidationTK pkp verifiedTK) + pkp of + Right () -> Right pkp + Left err -> Left err + ) + rawMatches + in (lefts verifiedMatches, rights verifiedMatches) + where + timelineValidationTK pkp verifiedTK' + | fingerprint pkp == fingerprint (tk ^. tkuKey . _1) = tk + | otherwise = verifiedTK' + +candidatePKPs :: TKUnknown -> [SomePKPayload] +candidatePKPs tk = + (tk ^. tkuKey . _1) + : mapMaybe (subkeyPKPFromPkt . fst) (tk ^. tkuSubs) + +historicallyValidSigner + :: UTCTime + -> TKUnknown + -> SomePKPayload + -> Either VerificationError () +historicallyValidSigner validationTime tk pkp + | fingerprint pkp == fingerprint (tk ^. tkuKey . _1) = + if keyStateValid (keyStateAt validationTime tk) + then Right () + else verificationError SigningKeyUnavailableAtSignatureTime + | otherwise = + case find + ( \(pkt, _) -> + maybe + False + ((== fingerprint pkp) . fingerprint) + (subkeyPKPFromPkt pkt) + ) + (tk ^. tkuSubs) of + Nothing -> verificationError SigningKeyUnavailableAtSignatureTime + Just (subPkt, sigs) -> + case subkeyPKPFromPkt subPkt of + Nothing -> verificationError SigningKeyUnavailableAtSignatureTime + Just subPKP -> + if isPKTimeValidWithSelfSignatures validationTime subPKP sigs + then Right () + else verificationError SigningKeyUnavailableAtSignatureTime + +signatureCreationTimeFromPacket :: Pkt -> Maybe UTCTime +signatureCreationTimeFromPacket (SignaturePkt sigPayload) = signatureCreationTime sigPayload +signatureCreationTimeFromPacket _ = Nothing + +signatureCreationTime :: SignaturePayload -> Maybe UTCTime +signatureCreationTime = + fmap + (posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp) + . sigCT + +signatureKnownAt :: Maybe UTCTime -> SignaturePayload -> Bool +signatureKnownAt Nothing _ = True +signatureKnownAt (Just validationTime) sigPayload = + maybe + False + (<= validationTime) + (signatureCreationTime sigPayload) + +signatureEffectiveAt :: Maybe UTCTime -> SignaturePayload -> Bool +signatureEffectiveAt Nothing _ = True +signatureEffectiveAt (Just validationTime) sigPayload = + signatureKnownAt (Just validationTime) sigPayload + && maybe + True + (validationTime <) + (signatureExpirationTime sigPayload) + +signatureUnexpiredAt :: Maybe UTCTime -> SignaturePayload -> Bool +signatureUnexpiredAt Nothing _ = True +signatureUnexpiredAt (Just validationTime) sigPayload = + maybe + True + (validationTime <) + (signatureExpirationTime sigPayload) + +signatureExpirationTime :: SignaturePayload -> Maybe UTCTime +signatureExpirationTime sigPayload = + addDurationToTime + <$> signatureCreationTime sigPayload + <*> signatureExpirationDuration sigPayload + +signatureExpirationDuration + :: SignaturePayload -> Maybe ThirtyTwoBitDuration +signatureExpirationDuration sigPayload = + signatureHashedSubpacketsKnown sigPayload + >>= firstSignatureExpirationDuration + +firstSignatureExpirationDuration + :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration +firstSignatureExpirationDuration = + foldr + ( \subpacket acc -> + case subpacket of + SigSubPacket _ (SigExpirationTime duration) -> Just duration + _ -> acc + ) + Nothing + +addDurationToTime :: UTCTime -> ThirtyTwoBitDuration -> UTCTime +addDurationToTime baseTime duration = + addUTCTime + (fromIntegral (unThirtyTwoBitDuration duration)) + baseTime + +certificationStateAt + :: Maybe UTCTime + -> [(SignaturePayload, Verification)] + -> (SignaturePayload, Verification) + -> CertificationState +certificationStateAt validationTime verified certification@(certificationSig, _) + | not (signatureKnownAt validationTime certificationSig) = + CertificationNotYetKnown + | not (signatureEffectiveAt validationTime certificationSig) = + CertificationRevoked + | any (`revokesCertification` certification) visibleRevocations = + CertificationRevoked + | otherwise = CertificationActive + where + visibleRevocations = + filter + (signatureEffectiveAt validationTime . fst) + (filter (isCertRevocationSig . fst) verified) + +revokesCertification + :: (SignaturePayload, Verification) + -> (SignaturePayload, Verification) + -> Bool +revokesCertification (revocationSig, revocationVerification) (certificationSig, certificationVerification) = + sameSigner + && certificationPrecedesRevocation certificationSig revocationSig + where + sameSigner = + fingerprint (revocationVerification ^. verificationSigner) + == fingerprint (certificationVerification ^. verificationSigner) + +certificationPrecedesRevocation + :: SignaturePayload -> SignaturePayload -> Bool +certificationPrecedesRevocation certificationSig revocationSig = + case ( signatureCreationTime certificationSig + , signatureCreationTime revocationSig + ) of + (Just certificationTime, Just revocationTime) -> + certificationTime < revocationTime + _ -> False + +isHistoricalKeyRevocation :: SignaturePayload -> Bool +isHistoricalKeyRevocation sigPayload = + case revocationReasonCode sigPayload of + Just KeySuperseded -> True + Just KeyRetiredAndNoLongerUsed -> True + Just UserIdInfoNoLongerValid -> True + _ -> False + +revocationReasonCode :: SignaturePayload -> Maybe RevocationCode +revocationReasonCode sigPayload = + ( \(SigSubPacket _ (ReasonForRevocation reasonCode _)) -> reasonCode + ) + <$> find isReasonForRevocation (signatureSubpackets sigPayload) + where + isReasonForRevocation (SigSubPacket _ ReasonForRevocation {}) = True + isReasonForRevocation _ = False + +signatureSubpackets :: SignaturePayload -> [SigSubPacket] +signatureSubpackets sigPayload = + case signatureSubpacketListsKnown sigPayload of + Just (hashed, unhashed) -> hashed ++ unhashed + Nothing -> [] + +signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket] +signatureHashedSubpackets sigPayload = + maybe [] id (signatureHashedSubpacketsKnown sigPayload) + +subkeyPKPFromPkt :: Pkt -> Maybe SomePKPayload +subkeyPKPFromPkt (PublicSubkeyPkt p) = Just p +subkeyPKPFromPkt (SecretSubkeyPkt p _) = Just p +subkeyPKPFromPkt _ = Nothing + +verifyAgainstKey' + :: SomePKPayload + -> Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification +verifyAgainstKey' pkp sig mt payload = + verifyAgainstKeyWithPolicy + defaultVerificationPolicy + pkp + sig + mt + payload + +{- | Verify a signature against a key with a custom verification policy. +This allows callers to control whether certain signature features +(deprecated hash algorithms, PKA mismatches, etc.) are treated as +hard errors or warnings. +-} +verifyAgainstKeyWithPolicy + :: VerificationPolicy + -> SomePKPayload + -> Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification +verifyAgainstKeyWithPolicy policy pkp sig mt payload = do + sigClass <- + either + (verificationError . const NonSignaturePacket) + Right + (fromPktEitherSomeSignatureV sig) + let sigPayload = + case sigClass of + SomeSignatureV typedSig -> signaturePayloadFromSignatureV typedSig + sigHash <- + maybe + (verificationError MissingHashAlgorithm) + Right + (sigHA sigPayload) + sigDetails <- signaturePKAAndMPIsFromClass sigClass + warnings <- enforcePKACompatibility policy sigPayload + hashWarnings <- enforceSignatureHashPolicy policy sigHash + _ <- isSignatureExpired sig mt + let signedPayload = BL.toStrict (finalPayload sig payload) + enforceLeft16Prefix sigClass sigHash signedPayload + ( \verifiedSigner -> + Verification verifiedSigner sigPayload (warnings ++ hashWarnings) + ) + <$> verify' sigDetails pkp sigHash signedPayload + where + enforcePKACompatibility vp sigPayload = + let sigPka = maybe (OtherPKA 0) id (sigPKA sigPayload) + keyPka = _pkalgo pkp + in if pkaCompatible sigPka keyPka + then Right [] + else case applyVerificationPolicy + (vpPkaMismatch vp) + ( "PKA mismatch: signature uses " + ++ show sigPka + ++ " but key uses " + ++ show keyPka + ) of + Left err -> verificationError (SignaturePolicyPKAMismatch sigPka keyPka) + Right warn -> Right [PkaMismatchWarning sigPka keyPka] + enforceSignatureHashPolicy vp sigHash = + case sigHash of + OtherHA {} -> + case applyVerificationPolicy + (vpUnsupportedHashAlgorithm vp) + ("Unsupported hash algorithm: " ++ show sigHash) of + Left err -> verificationError (SignaturePolicyHashUnsupported sigHash) + Right warn -> Right [UnsupportedHashAlgorithmWarning sigHash] + DeprecatedMD5 -> + case applyVerificationPolicy + (vpDeprecatedHashAlgorithm vp) + ("Deprecated hash algorithm: MD5") of + Left err -> verificationError (SignaturePolicyHashUnsupported sigHash) + Right warn -> Right [DeprecatedHashAlgorithmWarning sigHash] + SHA1 -> + case applyVerificationPolicy + (vpDeprecatedHashAlgorithm vp) + ("Deprecated hash algorithm: SHA1") of + Left err -> verificationError (SignaturePolicyHashUnsupported sigHash) + Right warn -> Right [DeprecatedHashAlgorithmWarning sigHash] + RIPEMD160 -> + case applyVerificationPolicy + (vpDeprecatedHashAlgorithm vp) + ("Deprecated hash algorithm: RIPEMD160") of + Left err -> verificationError (SignaturePolicyHashUnsupported sigHash) + Right warn -> Right [DeprecatedHashAlgorithmWarning sigHash] + _ -> Right [] + enforceLeft16Prefix sigClass sigHash signedPayload = do + expectedLeft16 <- + either + (verificationError . HashComputationFailed) + Right + (left16FromSignedPayload sigHash signedPayload) + actualLeft16 <- signatureLeft16FromClass sigClass + if actualLeft16 == expectedLeft16 + then Right () + else + verificationError + (SignatureMismatch (_pkalgo pkp) (fingerprint pkp)) + pkaCompatible RSA keyPka = + keyPka + `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] + pkaCompatible DeprecatedRSASignOnly keyPka = + keyPka `elem` [RSA, DeprecatedRSASignOnly] + pkaCompatible PKA.EdDSA keyPka = + keyPka `elem` [PKA.EdDSA, PKA.Ed25519, PKA.Ed448] + pkaCompatible PKA.Ed25519 keyPka = + keyPka `elem` [PKA.EdDSA, PKA.Ed25519] + pkaCompatible PKA.Ed448 keyPka = + keyPka `elem` [PKA.EdDSA, PKA.Ed448] + pkaCompatible sigPka keyPka = sigPka == keyPka + verify' details pub@(PKPayload V4 _ _ _ pkey) ha pl = + verifyByHash details pub pkey ha pl + verify' details pub@(PKPayload V6 _ _ _ pkey) ha pl = + verifyByHash details pub pkey ha pl + verify' _ _ _ _ = + verificationError UnexpectedKeyVersion + verifyByHash details pub pkey ha pl = + case ha of + SHA1 -> verify'' details CHA.SHA1 pub pkey pl + RIPEMD160 -> verify'' details CHA.RIPEMD160 pub pkey pl + SHA224 -> verify'' details CHA.SHA224 pub pkey pl + SHA256 -> verify'' details CHA.SHA256 pub pkey pl + SHA384 -> verify'' details CHA.SHA384 pub pkey pl + SHA512 -> verify'' details CHA.SHA512 pub pkey pl + SHA3_256 -> verifyNoRSA SHA3_256 details CHA.SHA3_256 pub pkey pl + SHA3_512 -> verifyNoRSA SHA3_512 details CHA.SHA3_512 pub pkey pl + DeprecatedMD5 -> verify'' details CHA.MD5 pub pkey pl + _ -> + verificationError (SignaturePolicyHashUnsupported ha) + verify'' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = + dsaVerify pub mpis hd pkey bs + verify'' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs = + ecdsaVerify pub mpis hd pkey bs + verify'' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve25519 pkey) bs + | sigPka `elem` [EdDSA, PKA.Ed25519] = + ed25519Verify sigPka pub mpis hd pkey bs + verify'' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve448 pkey) bs + | sigPka `elem` [EdDSA, PKA.Ed448] = + ed448Verify sigPka pub mpis hd pkey bs + verify'' (RSA, mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs = + rsaVerify pub mpis hd pkey bs + verify'' (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka) + verifyNoRSA ha' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = + dsaVerify pub mpis hd pkey bs + verifyNoRSA ha' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs = + ecdsaVerify pub mpis hd pkey bs + verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve25519 pkey) bs + | sigPka `elem` [EdDSA, PKA.Ed25519] = + ed25519Verify sigPka pub mpis hd pkey bs + verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve448 pkey) bs + | sigPka `elem` [EdDSA, PKA.Ed448] = + ed448Verify sigPka pub mpis hd pkey bs + verifyNoRSA ha' (RSA, _) _ _ _ _ = + verificationError (SignatureHashUnsupportedByAlgorithm ha' RSA) + verifyNoRSA _ (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka) + dsaVerify pub (r :| [s]) hd pkey bs = + if DSA.verify hd pkey (dsaMPIsToSig r s) bs + then Right pub + else verificationError (SignatureMismatch DSA (fingerprint pub)) + dsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch DSA) + ecdsaVerify pub (r :| [s]) hd pkey bs = + if ECDSA.verify hd pkey (ecdsaMPIsToSig r s) bs + then Right pub + else + verificationError (SignatureMismatch ECDSA (fingerprint pub)) + ecdsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch ECDSA) + ed25519Verify sigPka pub (r :| [s]) hd pkey bs = + case edPointToRawPublic 32 pkey of + Left err -> + verificationError (SignatureEncodingInvalid sigPka err) + Right rawPub -> + case cf2es (Ed25519.publicKey rawPub) of + Left err -> + verificationError (SignatureEncodingInvalid sigPka err) + Right ep -> + case cf2es + ( Ed25519.signature + (pad32 (i2osp (unMPI r)) <> pad32 (i2osp (unMPI s))) + ) of + Left err -> + verificationError (SignatureEncodingInvalid sigPka err) + Right es -> + let prehash = crazyHash hd bs :: B.ByteString + in if Ed25519.verify ep prehash es + then Right pub + else + verificationError (SignatureMismatch sigPka (fingerprint pub)) + ed25519Verify sigPka _ _ _ _ _ = + verificationError (SignatureShapeMismatch sigPka) + ed448Verify sigPka pub (r :| [s]) hd pkey bs = + case edPointToRawPublic 57 pkey of + Left err -> + verificationError (SignatureEncodingInvalid sigPka err) + Right rawPub -> + case cf2es (Ed448.publicKey rawPub) of + Left err -> + verificationError (SignatureEncodingInvalid sigPka err) + Right ep -> + case cf2es + ( Ed448.signature + (padN 57 (i2osp (unMPI r)) <> padN 57 (i2osp (unMPI s))) + ) of + Left err -> + verificationError (SignatureEncodingInvalid sigPka err) + Right es -> + let prehash = crazyHash hd bs :: B.ByteString + in if Ed448.verify ep prehash es + then Right pub + else + verificationError (SignatureMismatch sigPka (fingerprint pub)) + ed448Verify sigPka _ _ _ _ _ = + verificationError (SignatureShapeMismatch sigPka) + edPointToRawPublic expectedLen (NativeEPoint (EPoint x)) = + exactLengthPublic expectedLen "native" (i2osp x) + edPointToRawPublic expectedLen (PrefixedNativeEPoint (EPoint x)) = do + prefixed <- + exactLengthPublic (expectedLen + 1) "prefixed-native" (i2osp x) + if B.head prefixed /= 0x40 + then + Left + "prefixed-native EdDSA public key is missing the 0x40 prefix" + else Right (B.tail prefixed) + exactLengthPublic expectedLen label bs + | B.length bs == expectedLen = Right bs + | otherwise = + Left + ( "invalid " + ++ label + ++ " EdDSA public key length: expected " + ++ show expectedLen + ++ " octets, got " + ++ show (B.length bs) + ) + pad32 bs = + let l = B.length bs + in if l >= 32 + then bs + else B.replicate (32 - l) 0 <> bs + padN n bs = + let l = B.length bs + in if l >= n + then bs + else B.replicate (n - l) 0 <> bs + cf2es = either (Left . show) return . eitherCryptoError + rsaVerify pub mpis hd pkey bs = + if P15.verify (Just hd) pkey bs (rsaMPItoSig pkey mpis) + then Right pub + else verificationError (SignatureMismatch RSA (fingerprint pub)) + dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s) + ecdsaMPIsToSig r s = ECDSA.Signature (unMPI r) (unMPI s) + rsaMPItoSig pkey (s :| []) = + let sz = RSATypes.public_size pkey + raw = i2osp (unMPI s) + pad = sz - B.length raw + in B.replicate pad 0 <> raw + crazyHash h = BA.convert . hashWith h + +isSignatureExpired + :: Pkt -> Maybe UTCTime -> Either VerificationError Bool +isSignatureExpired _ Nothing = return False +isSignatureExpired s (Just t) = + do + sigClass <- + either + (verificationError . const NonSignaturePacket) + Right + (fromPktEitherSomeSignatureV s) + if any + (expiredBefore t) + ( signatureHashedSubpackets + ( case sigClass of + SomeSignatureV typedSig -> signaturePayloadFromSignatureV typedSig + ) + ) + then verificationError SignatureExpired + else return True + where + expiredBefore :: UTCTime -> SigSubPacket -> Bool + expiredBefore ct (SigSubPacket _ (SigExpirationTime et)) = + fromEnum + ((posixSecondsToUTCTime . toEnum . fromEnum) et `diffUTCTime` ct) + < 0 + expiredBefore _ _ = False + +finalPayload :: Pkt -> ByteString -> ByteString +finalPayload s pl = BL.concat [pl, sigbit, trailer s] + where + sigbit = runPut $ putPartialSigforSigning s + trailer :: Pkt -> ByteString + trailer (SignaturePkt sigPayload) = + maybe + BL.empty + (const (runPut $ putSigTrailer s)) + (fromSignaturePayloadVerifiableSignatureV sigPayload) + trailer _ = BL.empty + +normalizePayloadForSigType :: SigType -> ByteString -> ByteString +normalizePayloadForSigType CanonicalTextSig = + stripTrailingWhitespacePerLine . canonicalizeLineEndings +normalizePayloadForSigType _ = id + +normalizePayloadForSigTypeWith + :: TextNormalizationMode -> SigType -> ByteString -> ByteString +normalizePayloadForSigTypeWith CleartextCompat st = normalizePayloadForSigType st +normalizePayloadForSigTypeWith RFC9580Strict CanonicalTextSig = canonicalizeLineEndings +normalizePayloadForSigTypeWith RFC9580Strict _ = id + +canonicalizeLineEndings :: ByteString -> ByteString +canonicalizeLineEndings = BL.pack . go . BL.unpack + where + go [] = [] + go (0x0d : 0x0a : rest) = 0x0d : 0x0a : go rest + go (0x0d : rest) = 0x0d : 0x0a : go rest + go (0x0a : rest) = 0x0d : 0x0a : go rest + go (w : rest) = w : go rest + +stripTrailingWhitespacePerLine :: ByteString -> ByteString +stripTrailingWhitespacePerLine = BL.pack . go [] . BL.unpack + where + go lineRev [] = reverseTrimmed lineRev + go lineRev (0x0d : 0x0a : rest) = + reverseTrimmed lineRev ++ [0x0d, 0x0a] ++ go [] rest + go lineRev (w : rest) = go (w : lineRev) rest + + reverseTrimmed :: [Word8] -> [Word8] + reverseTrimmed = reverse . dropWhile isTrailingWhitespace + + isTrailingWhitespace :: Word8 -> Bool + isTrailingWhitespace w = w == 0x20 || w == 0x09 + +hashWithSHA512 :: B.ByteString -> B.ByteString +hashWithSHA512 = BA.convert . hashWith CHA.SHA512 + +hashForSignatureAlgorithm + :: HashAlgorithm -> B.ByteString -> Either String B.ByteString +hashForSignatureAlgorithm ha bs = + case ha of + SHA1 -> Right (BA.convert (hashWith CHA.SHA1 bs)) + RIPEMD160 -> Right (BA.convert (hashWith CHA.RIPEMD160 bs)) + SHA224 -> Right (BA.convert (hashWith CHA.SHA224 bs)) + SHA256 -> Right (BA.convert (hashWith CHA.SHA256 bs)) + SHA384 -> Right (BA.convert (hashWith CHA.SHA384 bs)) + SHA512 -> Right (BA.convert (hashWith CHA.SHA512 bs)) + SHA3_256 -> Right (BA.convert (hashWith CHA.SHA3_256 bs)) + SHA3_512 -> Right (BA.convert (hashWith CHA.SHA3_512 bs)) + DeprecatedMD5 -> Right (BA.convert (hashWith CHA.MD5 bs)) + _ -> + Left + ("unsupported hash algorithm for left16 derivation: " ++ show ha) + +left16FromHashPrefix :: B.ByteString -> Either String Word16 +left16FromHashPrefix bs + | B.length bs >= 2 = Right (fromIntegral (os2ip (B.take 2 bs))) + | otherwise = Left "hash output too short to derive left16" + +left16FromSignedPayload + :: HashAlgorithm -> B.ByteString -> Either String Word16 +left16FromSignedPayload ha signedPayload = do + digest <- hashForSignatureAlgorithm ha signedPayload + left16FromHashPrefix digest + +left16FromSignedPayloadForSign + :: HashAlgorithm -> B.ByteString -> Either SignError Word16 +left16FromSignedPayloadForSign ha = + first SignBackendError . left16FromSignedPayload ha + +ed25519Signer + :: Ed25519.SecretKey -> B.ByteString -> B.ByteString +ed25519Signer sk prehash = + BA.convert (Ed25519.sign sk (Ed25519.toPublic sk) prehash) + +ed448Signer :: Ed448.SecretKey -> B.ByteString -> B.ByteString +ed448Signer sk prehash = + BA.convert (Ed448.sign sk (Ed448.toPublic sk) prehash) + +rsaPKCS15Sign + :: HashAlgorithm + -> RSATypes.PrivateKey + -> B.ByteString + -> Either SignError B.ByteString +rsaPKCS15Sign ha prv bytes = + case ha of + SHA1 -> + first + (SignBackendError . show) + (P15.sign Nothing (Just CHA.SHA1) prv bytes) + SHA224 -> + first + (SignBackendError . show) + (P15.sign Nothing (Just CHA.SHA224) prv bytes) + SHA256 -> + first + (SignBackendError . show) + (P15.sign Nothing (Just CHA.SHA256) prv bytes) + SHA384 -> + first + (SignBackendError . show) + (P15.sign Nothing (Just CHA.SHA384) prv bytes) + SHA512 -> + first + (SignBackendError . show) + (P15.sign Nothing (Just CHA.SHA512) prv bytes) + _ -> + Left + ( SignBackendError + ( "signature hash algorithm is not supported by RSA PKCS#1 v1.5 backend: " + ++ show ha + ) + ) + +validateV6SaltSize + :: HashAlgorithm -> SignatureSalt -> Either SignError () +validateV6SaltSize ha salt = + let saltBytes = BL.toStrict (unSignatureSalt salt) + actualSaltLen = B.length saltBytes + in case signatureV6SaltSizeForHashAlgorithm ha of + Nothing -> + Left + ( SignBackendError + ( "signature hash algorithm does not define a V6 salt size: " + ++ show ha + ) + ) + Just expectedSaltLen -> + if actualSaltLen == fromIntegral expectedSaltLen + then Right () + else + Left (SignV6SaltSizeMismatch ha expectedSaltLen actualSaltLen) + +signEdDSAV4 + :: String + -> Int + -> Int + -> (B.ByteString -> B.ByteString) + -> TextNormalizationMode + -> SigType + -> PubKeyAlgorithm + -> HashAlgorithm + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signEdDSAV4 algoName sigLen limbLen signer mode st pka ha has uhas payload = do + let normalizedPayload = normalizePayloadForSigTypeWith mode st payload + sig0 = SigV4 st pka ha has [] 0 (NE.fromList [MPI 0, MPI 0]) + prehash = + hashWithSHA512 + (BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload)) + sigBytes = signer prehash + if B.length sigBytes /= sigLen + then + Left + (SignProducedWrongLength algoName sigLen (B.length sigBytes)) + else + let (r, s) = B.splitAt limbLen sigBytes + in ( \left16 -> + SigV4 + st + pka + ha + has + uhas + left16 + (NE.fromList [MPI (os2ip r), MPI (os2ip s)]) + ) + <$> first SignBackendError (left16FromHashPrefix prehash) + +signEdDSAV6 + :: String + -> Int + -> Int + -> (B.ByteString -> B.ByteString) + -> TextNormalizationMode + -> SigType + -> PubKeyAlgorithm + -> HashAlgorithm + -> SignatureSalt + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signEdDSAV6 algoName sigLen limbLen signer mode st pka ha salt has uhas payload = do + validateV6SaltSize ha salt + let normalizedPayload = normalizePayloadForSigTypeWith mode st payload + sig0 = SigV6 st pka ha salt has [] 0 (NE.fromList [MPI 0, MPI 0]) + prehash = + hashWithSHA512 + (BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload)) + sigBytes = signer prehash + if B.length sigBytes /= sigLen + then + Left + (SignProducedWrongLength algoName sigLen (B.length sigBytes)) + else + let (r, s) = B.splitAt limbLen sigBytes + in ( \left16 -> + SigV6 + st + pka + ha + salt + has + uhas + left16 + (NE.fromList [MPI (os2ip r), MPI (os2ip s)]) + ) + <$> first SignBackendError (left16FromHashPrefix prehash) + +signUserIDwithRSA + :: SomePKPayload + -- ^ public key "payload" of user ID being signed + -> UserId + -- ^ user ID being signed + -> [SigSubPacket] + -- ^ hashed signature subpackets + -> [SigSubPacket] + -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey + -- ^ RSA signing key + -> Either SignError SignaturePayload +signUserIDwithRSA = signCertificationWithRSA PositiveCert + +signCertificationWithRSA + :: SigType + -- ^ certification type (GenericCert, PersonaCert, CasualCert, PositiveCert) + -> SomePKPayload + -- ^ public key "payload" of user ID being signed + -> UserId + -- ^ user ID being signed + -> [SigSubPacket] + -- ^ hashed signature subpackets + -> [SigSubPacket] + -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey + -- ^ RSA signing key + -> Either SignError SignaturePayload +signCertificationWithRSA st pkp uid hsigsubs usigsubs prv + | st `elem` [GenericCert, PersonaCert, CasualCert, PositiveCert] = do + let payloadToSign = BL.toStrict (finalPayload (SignaturePkt uidsigp) uidpayload) + uidsigp' + <$> left16FromSignedPayloadForSign SHA512 payloadToSign + <*> first + (SignBackendError . show) + ( P15.sign + Nothing + (Just CHA.SHA512) + prv + payloadToSign + ) + | otherwise = + Left (SignUnsupportedCertificationType st) + where + uidpayload = + runPut + ( sequence_ + [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)] + ) + uidsigp = + SigV4 st RSA SHA512 hsigsubs usigsubs 0 (NE.fromList [MPI 0]) + uidsigp' left16 us = + SigV4 + st + RSA + SHA512 + hsigsubs + usigsubs + left16 + (NE.fromList [MPI (os2ip us)]) + +signDirectKeyWithRSA + :: SigType + -- ^ key-scoped signature type (SignatureDirectlyOnAKey or KeyRevocationSig) + -> SomePKPayload + -- ^ primary key "payload" being signed + -> [SigSubPacket] + -- ^ hashed signature subpackets + -> [SigSubPacket] + -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey + -- ^ RSA signing key + -> Either SignError SignaturePayload +signDirectKeyWithRSA st pkp hsigsubs usigsubs prv + | st `elem` [SignatureDirectlyOnAKey, KeyRevocationSig] = + signDataWithRSA st prv hsigsubs usigsubs keypayload + | otherwise = + Left (SignUnsupportedKeySignatureType st) + where + keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp)) + +signKeyRevocationWithRSA + :: SomePKPayload + -- ^ primary key "payload" being revoked + -> [SigSubPacket] + -- ^ hashed signature subpackets + -> [SigSubPacket] + -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey + -- ^ RSA signing key + -> Either SignError SignaturePayload +signKeyRevocationWithRSA = signDirectKeyWithRSA KeyRevocationSig + +signSubkeyRevocationWithRSA + :: SomePKPayload + -- ^ primary key "payload" + -> SomePKPayload + -- ^ public subkey "payload" being revoked + -> [SigSubPacket] + -- ^ hashed signature subpackets + -> [SigSubPacket] + -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey + -- ^ RSA signing key + -> Either SignError SignaturePayload +signSubkeyRevocationWithRSA pkp subpkp hsigsubs usigsubs prv = + signDataWithRSA + SubkeyRevocationSig + prv + hsigsubs + usigsubs + subkeypayload + where + subkeypayload = + runPut + ( sequence_ + [ putKeyforSigning (PublicKeyPkt pkp) + , putKeyforSigning (PublicSubkeyPkt subpkp) + ] + ) + +signCertRevocationWithRSA + :: SomePKPayload + -- ^ primary key "payload" + -> UserId + -- ^ user ID certification being revoked + -> [SigSubPacket] + -- ^ hashed signature subpackets + -> [SigSubPacket] + -- ^ unhashed signature subpackets + -> RSATypes.PrivateKey + -- ^ RSA signing key + -> Either SignError SignaturePayload +signCertRevocationWithRSA pkp uid hsigsubs usigsubs prv = + signDataWithRSA + CertRevocationSig + prv + hsigsubs + usigsubs + certpayload + where + certpayload = + runPut + ( sequence_ + [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)] + ) + +crossSignSubkeyWithRSA + :: SomePKPayload + -- ^ public key "payload" of key being signed + -> SomePKPayload + -- ^ public subkey "payload" of key being signed + -> [SigSubPacket] + -- ^ hashed signature subpackets for binding sig + -> [SigSubPacket] + -- ^ unhashed signature subpackets for binding sig + -> [SigSubPacket] + -- ^ hashed signature subpackets for embedded sig + -> [SigSubPacket] + -- ^ unhashed signature subpackets for embedded sig + -> RSATypes.PrivateKey + -- ^ RSA signing key + -> RSATypes.PrivateKey + -- ^ RSA signing subkey + -> Either SignError SignaturePayload +crossSignSubkeyWithRSA pkp subpkp subhsigsubs subusigsubs embhsigsubs embusigsubs prv ssb = do + let embPayloadToSign = + BL.toStrict (finalPayload (SignaturePkt embsigp) subkeypayload) + subPayloadToSign = + BL.toStrict (finalPayload (SignaturePkt subsigp) subkeypayload) + ( \embleft16 subleft16 embsig subsig -> + subsigp' (embsigp' embleft16 embsig) subleft16 subsig + ) + <$> left16FromSignedPayloadForSign SHA512 embPayloadToSign + <*> left16FromSignedPayloadForSign SHA512 subPayloadToSign + <*> first + (SignBackendError . show) + ( P15.sign + Nothing + (Just CHA.SHA512) + ssb + embPayloadToSign + ) + <*> first + (SignBackendError . show) + ( P15.sign + Nothing + (Just CHA.SHA512) + prv + subPayloadToSign + ) + where + subkeypayload = + runPut + ( sequence_ + [ putKeyforSigning (PublicKeyPkt pkp) + , putKeyforSigning (PublicSubkeyPkt subpkp) + ] + ) + embsigp = + SigV4 + PrimaryKeyBindingSig + RSA + SHA512 + embhsigsubs + embusigsubs + 0 + (NE.fromList [MPI 0]) + embsigp' left16 es = + SigV4 + PrimaryKeyBindingSig + RSA + SHA512 + embhsigsubs + embusigsubs + left16 + (NE.fromList [MPI (os2ip es)]) + subsigp = + SigV4 + SubkeyBindingSig + RSA + SHA512 + subhsigsubs + [] + 0 + (NE.fromList [MPI 0]) + sspes es = SigSubPacket False (EmbeddedSignature es) + subsigp' es left16 ss = + SigV4 + SubkeyBindingSig + RSA + SHA512 + subhsigsubs + (sspes es : subusigsubs) + left16 + (NE.fromList [MPI (os2ip ss)]) + +signRSAV4Core + :: TextNormalizationMode + -> SigType + -> HashAlgorithm + -> [SigSubPacket] + -> [SigSubPacket] + -> RSATypes.PrivateKey + -> ByteString + -> Either SignError SignaturePayload +signRSAV4Core mode st ha has uhas prv payload = + ( \left16 ss -> + SigV4 st RSA ha has uhas left16 (NE.fromList [MPI (os2ip ss)]) + ) + <$> left16FromSignedPayloadForSign ha payloadToSign + <*> rsaPKCS15Sign ha prv payloadToSign + where + sig0 = SigV4 st RSA ha has [] 0 (NE.fromList [MPI 0]) + payloadToSign = + BL.toStrict + ( finalPayload + (SignaturePkt sig0) + (normalizePayloadForSigTypeWith mode st payload) + ) + +signRSAV6Core + :: TextNormalizationMode + -> SigType + -> HashAlgorithm + -> SignatureSalt + -> [SigSubPacket] + -> [SigSubPacket] + -> RSATypes.PrivateKey + -> ByteString + -> Either SignError SignaturePayload +signRSAV6Core mode st ha salt has uhas prv payload = do + validateV6SaltSize ha salt + ( \left16 sigBytes -> + SigV6 + st + RSA + ha + salt + has + uhas + left16 + (NE.fromList [MPI (os2ip sigBytes)]) + ) + <$> left16FromSignedPayloadForSign ha payloadToSign + <*> rsaPKCS15Sign ha prv payloadToSign + where + sig0 = SigV6 st RSA ha salt has [] 0 (NE.fromList [MPI 0]) + payloadToSign = + BL.toStrict + ( finalPayload + (SignaturePkt sig0) + (normalizePayloadForSigTypeWith mode st payload) + ) + +signDataWithRSA + :: SigType + -> RSATypes.PrivateKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithRSA st prv has uhas payload = + signRSAV4Core CleartextCompat st SHA512 has uhas prv payload + +signDataWithRSAV6 + :: SigType + -> SignatureSalt + -> RSATypes.PrivateKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithRSAV6 st salt prv has uhas payload = + signRSAV6Core CleartextCompat st SHA512 salt has uhas prv payload + +-- FIXME: clean this up +ed25519Params + , ed25519LegacyParams + , ed448Params + :: (String, Int, Int, PubKeyAlgorithm) +ed25519Params = ("Ed25519", 64, 32, PKA.Ed25519) +ed25519LegacyParams = ("Ed25519Legacy", 64, 32, PKA.EdDSA) +ed448Params = ("Ed448", 114, 57, PKA.Ed448) + +signDataWithEdDSAV4Generic + :: (String, Int, Int, PubKeyAlgorithm) + -> (B.ByteString -> B.ByteString) + -> TextNormalizationMode + -> HashAlgorithm + -> SigType + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEdDSAV4Generic (algoName, sigLen, limbLen, pka) signer mode ha st has uhas payload = + signEdDSAV4 + algoName + sigLen + limbLen + signer + mode + st + pka + ha + has + uhas + payload + +signDataWithEdDSAV6Generic + :: (String, Int, Int, PubKeyAlgorithm) + -> (B.ByteString -> B.ByteString) + -> TextNormalizationMode + -> HashAlgorithm + -> SigType + -> SignatureSalt + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEdDSAV6Generic (algoName, sigLen, limbLen, pka) signer mode ha st salt has uhas payload = + signEdDSAV6 + algoName + sigLen + limbLen + signer + mode + st + pka + ha + salt + has + uhas + payload + +signDataWithEd25519 + :: SigType + -> Ed25519.SecretKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd25519 st sk has uhas payload = + signDataWithEdDSAV4Generic + ed25519Params + (ed25519Signer sk) + CleartextCompat + SHA512 + st + has + uhas + payload + +signDataWithEd25519Legacy + :: SigType + -> Ed25519.SecretKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd25519Legacy st sk has uhas payload = + signDataWithEdDSAV4Generic + ed25519LegacyParams + (ed25519Signer sk) + CleartextCompat + SHA512 + st + has + uhas + payload + +signDataWithEd25519V6 + :: SigType + -> SignatureSalt + -> Ed25519.SecretKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd25519V6 st salt sk has uhas payload = + signDataWithEdDSAV6Generic + ed25519Params + (ed25519Signer sk) + CleartextCompat + SHA512 + st + salt + has + uhas + payload + +signDataWithEd448 + :: SigType + -> Ed448.SecretKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd448 st sk has uhas payload = + signDataWithEdDSAV4Generic + ed448Params + (ed448Signer sk) + CleartextCompat + SHA512 + st + has + uhas + payload + +signDataWithEd448V6 + :: SigType + -> SignatureSalt + -> Ed448.SecretKey + -> [SigSubPacket] + -> [SigSubPacket] + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd448V6 st salt sk has uhas payload = + signDataWithEdDSAV6Generic + ed448Params + (ed448Signer sk) + CleartextCompat + SHA512 + st + salt + has + uhas + payload + +{- | Builder-based signature creation for RSA + +Example usage: + builder <- sigBuilderInit BinarySig RSA SHA512 + builder' <- addHashedSubs hashedSubpackets builder + builder'' <- addUnhashedSubs unhashedSubpackets builder' + sig <- signDataWithRSABuilder builder'' rsaPrivateKey payload +-} +signDataWithRSABuilder + :: SigBuilder + Codec.Encryption.OpenPGP.Types.Unhashed + Codec.Encryption.OpenPGP.Types.V4Sig + 'PKA.RSA + -> RSATypes.PrivateKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithRSABuilder builder prv payload = + signRSAV4Core + (sbTextNormMode builder) + (sbSigType builder) + (sbHashAlgo builder) + (sbHashedSubs builder) + (sbUnhashedSubs builder) + prv + payload + +-- | Builder-based signature creation for RSA (v6) +signDataWithRSAV6Builder + :: SigBuilder + Codec.Encryption.OpenPGP.Types.Unhashed + Codec.Encryption.OpenPGP.Types.V6Sig + 'PKA.RSA + -> RSATypes.PrivateKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithRSAV6Builder builder prv payload = + signRSAV6Core + (sbTextNormMode builder) + (sbSigType builder) + (sbHashAlgo builder) + (sbSalt builder) + (sbHashedSubs builder) + (sbUnhashedSubs builder) + prv + payload + +{- | Builder-based signature creation for Ed25519 (v4) + +Example usage: + builder <- sigBuilderInit BinarySig Ed25519 SHA512 + builder' <- addHashedSubs hashedSubpackets builder + builder'' <- addUnhashedSubs unhashedSubpackets builder' + sig <- signDataWithEd25519Builder builder'' ed25519PrivateKey payload +-} +signDataWithEd25519Builder + :: SigBuilder + Codec.Encryption.OpenPGP.Types.Unhashed + Codec.Encryption.OpenPGP.Types.V4Sig + 'PKA.Ed25519 + -> Ed25519.SecretKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd25519Builder builder sk payload = + signDataWithEdDSAV4Generic + ed25519Params + (ed25519Signer sk) + (sbTextNormMode builder) + (sbHashAlgo builder) + (sbSigType builder) + (sbHashedSubs builder) + (sbUnhashedSubs builder) + payload + +{- | Builder-based signature creation for Ed25519 (v6) + +Example usage: + builder <- sigBuilderInitV6 BinarySig Ed25519 SHA512 salt + builder' <- addHashedSubs hashedSubpackets builder + builder'' <- addUnhashedSubs unhashedSubpackets builder' + sig <- signDataWithEd25519V6Builder builder'' ed25519PrivateKey payload +-} +signDataWithEd25519V6Builder + :: SigBuilder + Codec.Encryption.OpenPGP.Types.Unhashed + Codec.Encryption.OpenPGP.Types.V6Sig + 'PKA.Ed25519 + -> Ed25519.SecretKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd25519V6Builder builder sk payload = + signDataWithEdDSAV6Generic + ed25519Params + (ed25519Signer sk) + (sbTextNormMode builder) + (sbHashAlgo builder) + (sbSigType builder) + (sbSalt builder) + (sbHashedSubs builder) + (sbUnhashedSubs builder) + payload + +{- | Builder-based signature creation for Ed448 (v4) + +Example usage: + builder <- sigBuilderInit BinarySig Ed448 SHA512 + builder' <- addHashedSubs hashedSubpackets builder + builder'' <- addUnhashedSubs unhashedSubpackets builder' + sig <- signDataWithEd448Builder builder'' ed448PrivateKey payload +-} +signDataWithEd448Builder + :: SigBuilder + Codec.Encryption.OpenPGP.Types.Unhashed + Codec.Encryption.OpenPGP.Types.V4Sig + 'PKA.Ed448 + -> Ed448.SecretKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd448Builder builder sk payload = + signDataWithEdDSAV4Generic + ed448Params + (ed448Signer sk) + (sbTextNormMode builder) + (sbHashAlgo builder) + (sbSigType builder) + (sbHashedSubs builder) + (sbUnhashedSubs builder) + payload + +-- | Builder-based signature creation for Ed448 (v6) +signDataWithEd448V6Builder + :: SigBuilder + Codec.Encryption.OpenPGP.Types.Unhashed + Codec.Encryption.OpenPGP.Types.V6Sig + 'PKA.Ed448 + -> Ed448.SecretKey + -> ByteString + -> Either SignError SignaturePayload +signDataWithEd448V6Builder builder sk payload = + signDataWithEdDSAV6Generic + ed448Params + (ed448Signer sk) + (sbTextNormMode builder) + (sbHashAlgo builder) + (sbSigType builder) + (sbSalt builder) + (sbHashedSubs builder) + (sbUnhashedSubs builder) + payload + +{- | Algorithm-agnostic signature builder dispatcher (Phase 2) + +Dispatches to the appropriate signing function based on the private key type. +The private key type (PrivateKeyFor algo) encodes the algorithm at the type level, +allowing compile-time verification that the key and builder algorithm match. + +Example usage: +-} +class BuilderSigningAlgorithm (algo :: PKA.PubKeyAlgorithm) where + signDataWithAlgorithmicBuilderImpl + :: SigBuilder + Codec.Encryption.OpenPGP.Types.Unhashed + Codec.Encryption.OpenPGP.Types.V4Sig + algo + -> PrivateKeyFor algo + -> ByteString + -> Either SignError SignaturePayload + +instance BuilderSigningAlgorithm 'PKA.RSA where + signDataWithAlgorithmicBuilderImpl builder (SP.RSAPrivateKey prv) payload = + signDataWithRSABuilder builder prv payload + +instance BuilderSigningAlgorithm 'PKA.Ed25519 where + signDataWithAlgorithmicBuilderImpl builder (SP.Ed25519PrivateKey sk) payload = + signDataWithEd25519Builder builder sk payload + +instance BuilderSigningAlgorithm 'PKA.Ed448 where + signDataWithAlgorithmicBuilderImpl builder (SP.Ed448PrivateKey sk) payload = + signDataWithEd448Builder builder sk payload + +{- | Catch-all instance that produces a compile-time error for any algorithm +that is not supported by the algorithmic builder (e.g. DSA, ECDSA). +-} +instance + {-# OVERLAPPABLE #-} + ( TypeError + ( 'Text + "signDataWithAlgorithmicBuilder does not support this algorithm." + ':$$: 'Text "Supported algorithms: RSA, Ed25519, Ed448." + ':$$: 'Text + "For DSA or ECDSA, use signDataWith{DSA,ECDSA}Builder directly." + ) + ) + => BuilderSigningAlgorithm algo + where + signDataWithAlgorithmicBuilderImpl = error "unreachable: TypeError fires at compile time" + +signDataWithAlgorithmicBuilder + :: forall (algo :: PKA.PubKeyAlgorithm) + . BuilderSigningAlgorithm algo + => SigBuilder + Codec.Encryption.OpenPGP.Types.Unhashed + Codec.Encryption.OpenPGP.Types.V4Sig + algo + -> PrivateKeyFor algo + -> ByteString + -> Either SignError SignaturePayload +signDataWithAlgorithmicBuilder = + signDataWithAlgorithmicBuilderImpl diff --git a/Codec/Encryption/OpenPGP/Types.hs b/Codec/Encryption/OpenPGP/Types.hs --- a/Codec/Encryption/OpenPGP/Types.hs +++ b/Codec/Encryption/OpenPGP/Types.hs @@ -4,10 +4,10 @@ -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Types - ( module X - ) where + ( module X + ) where -import Codec.Encryption.OpenPGP.Types.Internal.Base as X hiding (Ed25519, Ed448) +import Codec.Encryption.OpenPGP.Types.Internal.Base as X import Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes as X import Codec.Encryption.OpenPGP.Types.Internal.PKITypes as X import Codec.Encryption.OpenPGP.Types.Internal.PacketClass as X diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs @@ -2,1770 +2,2053 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - -{-# LANGUAGE CPP #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} - -module Codec.Encryption.OpenPGP.Types.Internal.Base where - -import GHC.Generics (Generic) - -import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils (prettyLBS) -import Control.Applicative ((<|>)) -import Control.Arrow ((***)) -import Control.Lens (makeLenses, op, Wrapped) -import Control.Monad (mzero) -import Data.Bits ((.&.)) -import Data.Aeson ((.=), object) -import qualified Data.Aeson as A -import qualified Data.Aeson.Key as AK -import qualified Data.Aeson.TH as ATH -import Data.ByteArray (ByteArrayAccess) -import qualified Data.ByteString as B -import qualified Data.ByteString.Base16.Lazy as B16L -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC8 -import Data.Char (toLower, toUpper) -import Data.Data (Data) -import Data.Hashable (Hashable(..)) -import Data.Int (Int64) -import Data.Kind (Type) -import Data.List (unfoldr) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NE -import Data.List.Split (chunksOf) -import Data.Maybe (fromMaybe) -import Data.Ord (comparing) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Time.Format (formatTime) -import Data.Time.Locale.Compat (defaultTimeLocale) -import Data.Typeable (Typeable) -import Data.Word (Word16, Word32, Word8) -import Network.URI (URI(..), nullURI, parseURI, uriToString) -import Numeric (readHex) -import Prettyprinter (Pretty(..), (<+>), hsep, punctuate, space) -import Data.IORef (IORef, atomicModifyIORef', newIORef) -import System.IO.Unsafe (unsafePerformIO) - -type Exportability = Bool - -type TrustLevel = Word8 - -type TrustAmount = Word8 - -type AlmostPublicDomainRegex = ByteString - -type Revocability = Bool - -type RevocationReason = Text - -type KeyServer = ByteString - -type SignatureHash = ByteString - -type PacketVersion = Word8 - -type V3Expiration = Word16 - -type CompressedDataPayload = ByteString - -type FileName = ByteString - -type ImageData = ByteString - -type NestedFlag = Bool - --- | Phantom types for tracking subpacket classification and signature version --- These types are never instantiated; they exist purely for compile-time type safety. - --- | Phantom marker for hashed subpackets (included in signature hash computation) -data Hashed - --- | Phantom marker for unhashed subpackets (not included in signature hash computation) -data Unhashed - --- | Phantom marker for v4 signatures (8-octet issuer, no salt) -data V4Sig - --- | Phantom marker for v6 signatures (fingerprint issuer, requires salt) -data V6Sig - -data ByteRange = - ByteRange - { _rangeOffset :: Int64 - , _rangeLength :: Int64 - } - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -newtype WireRepSourceId = - WireRepSourceId - { _unWireRepSourceId :: Int64 - } - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -data WireRepRef = - WireRepRef - { _wireRepSourceId :: WireRepSourceId - , _wireRepLength :: Int64 - , _wireRepName :: Maybe Text - , _wireRepWasOriginallyArmored :: Bool - } - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -type WireRepRefs = NonEmpty WireRepRef - -wireRepRef :: ByteString -> WireRepRef -wireRepRef = mkWireRepRefWithLength Nothing False . BL.length - -namedWireRepRef :: Text -> ByteString -> WireRepRef -namedWireRepRef name = mkWireRepRefWithLength (Just name) False . BL.length - -mkWireRepRefWithLength :: - Maybe Text -> Bool -> Int64 -> WireRepRef -mkWireRepRefWithLength mname wasOriginallyArmored payloadLen = - WireRepRef - { _wireRepSourceId = freshWireRepSourceId payloadLen - , _wireRepLength = payloadLen - , _wireRepName = mname - , _wireRepWasOriginallyArmored = wasOriginallyArmored - } - -mkWireRepRef :: Maybe Text -> Bool -> ByteString -> WireRepRef -mkWireRepRef mname wasOriginallyArmored = - mkWireRepRefWithLength mname wasOriginallyArmored . BL.length - -wireRepSourceCounter :: IORef Int64 -wireRepSourceCounter = unsafePerformIO (newIORef 0) -{-# NOINLINE wireRepSourceCounter #-} - -freshWireRepSourceId :: Int64 -> WireRepSourceId -freshWireRepSourceId !_ = - unsafePerformIO $ - atomicModifyIORef' wireRepSourceCounter (\n -> let n' = n + 1 in (n', WireRepSourceId n')) -{-# NOINLINE freshWireRepSourceId #-} - -rangeEnd :: ByteRange -> Int64 -rangeEnd r = _rangeOffset r + _rangeLength r - -spanByteRanges :: [ByteRange] -> Maybe ByteRange -spanByteRanges [] = Nothing -spanByteRanges (r:rs) = - let start = minimum (_rangeOffset <$> (r : rs)) - ending = maximum (rangeEnd <$> (r : rs)) - in Just (ByteRange start (ending - start)) - -$(makeLenses ''ByteRange) -$(makeLenses ''WireRepRef) - -class (Eq a, Ord a) => - FutureFlag a - where - fromFFlag :: a -> Int - toFFlag :: Int -> a - -class (Eq a, Ord a) => - FutureVal a - where - fromFVal :: a -> Word8 - toFVal :: Word8 -> a - -data SymmetricAlgorithm - = Plaintext - | IDEA - | TripleDES - | CAST5 - | Blowfish - | ReservedSAFER - | ReservedDES - | AES128 - | AES192 - | AES256 - | Twofish - | Camellia128 - | Camellia192 - | Camellia256 - | OtherSA Word8 - deriving (Data, Generic, Show, Typeable) - -instance Eq SymmetricAlgorithm where - (==) a b = fromFVal a == fromFVal b - -instance Ord SymmetricAlgorithm where - compare = comparing fromFVal - -instance FutureVal SymmetricAlgorithm where - fromFVal Plaintext = 0 - fromFVal IDEA = 1 - fromFVal TripleDES = 2 - fromFVal CAST5 = 3 - fromFVal Blowfish = 4 - fromFVal ReservedSAFER = 5 - fromFVal ReservedDES = 6 - fromFVal AES128 = 7 - fromFVal AES192 = 8 - fromFVal AES256 = 9 - fromFVal Twofish = 10 - fromFVal Camellia128 = 11 - fromFVal Camellia192 = 12 - fromFVal Camellia256 = 13 - fromFVal (OtherSA o) = o - toFVal 0 = Plaintext - toFVal 1 = IDEA - toFVal 2 = TripleDES - toFVal 3 = CAST5 - toFVal 4 = Blowfish - toFVal 5 = ReservedSAFER - toFVal 6 = ReservedDES - toFVal 7 = AES128 - toFVal 8 = AES192 - toFVal 9 = AES256 - toFVal 10 = Twofish - toFVal 11 = Camellia128 - toFVal 12 = Camellia192 - toFVal 13 = Camellia256 - toFVal o = OtherSA o - -instance Hashable SymmetricAlgorithm - -instance Pretty SymmetricAlgorithm where - pretty Plaintext = pretty "plaintext" - pretty IDEA = pretty "IDEA" - pretty TripleDES = pretty "3DES" - pretty CAST5 = pretty "CAST-128" - pretty Blowfish = pretty "Blowfish" - pretty ReservedSAFER = pretty "(reserved) SAFER" - pretty ReservedDES = pretty "(reserved) DES" - pretty AES128 = pretty "AES-128" - pretty AES192 = pretty "AES-192" - pretty AES256 = pretty "AES-256" - pretty Twofish = pretty "Twofish" - pretty Camellia128 = pretty "Camellia-128" - pretty Camellia192 = pretty "Camellia-192" - pretty Camellia256 = pretty "Camellia-256" - pretty (OtherSA sa) = pretty "unknown symmetric algorithm" <+> pretty sa - -$(ATH.deriveJSON ATH.defaultOptions ''SymmetricAlgorithm) - -data NotationFlag - = HumanReadable - | OtherNF Word8 - deriving (Data, Generic, Show, Typeable) - -mkNotationFlag :: Word8 -> NotationFlag -mkNotationFlag o - | o' == 0 = HumanReadable - | otherwise = OtherNF o' - where - o' = o .&. 0x0f - -instance Eq NotationFlag where - (==) a b = fromFFlag a == fromFFlag b - -instance Ord NotationFlag where - compare = comparing fromFFlag - -instance FutureFlag NotationFlag where - fromFFlag HumanReadable = 0 - fromFFlag (OtherNF o) = fromIntegral (o .&. 0x0f) - toFFlag 0 = HumanReadable - toFFlag o = mkNotationFlag (fromIntegral o) - -instance Hashable NotationFlag - -instance Pretty NotationFlag where - pretty HumanReadable = pretty "human-readable" - pretty (OtherNF o) = pretty "unknown notation flag type" <+> pretty o - -$(ATH.deriveJSON ATH.defaultOptions ''NotationFlag) - -newtype ThirtyTwoBitTimeStamp = - ThirtyTwoBitTimeStamp - { unThirtyTwoBitTimeStamp :: Word32 - } - deriving ( Bounded - , Data - , Enum - , Eq - , Generic - , Hashable - , Integral - , Num - , Ord - , Real - , Show - , Typeable - ) - -instance Wrapped ThirtyTwoBitTimeStamp - -instance Pretty ThirtyTwoBitTimeStamp where - pretty = - pretty . - formatTime defaultTimeLocale "%Y%m%d-%H%M%S" . - posixSecondsToUTCTime . realToFrac - -$(ATH.deriveJSON ATH.defaultOptions ''ThirtyTwoBitTimeStamp) - -durU :: (Integral a, Show a) => a -> Maybe (String, a) -durU x - | x >= 31557600 = Just ((++ "y") . show $ x `div` 31557600, x `mod` 31557600) - | x >= 2629800 = Just ((++ "m") . show $ x `div` 2629800, x `mod` 2629800) - | x >= 86400 = Just ((++ "d") . show $ x `div` 86400, x `mod` 86400) - | x > 0 = Just ((++ "s") . show $ x, 0) - | otherwise = Nothing - -newtype ThirtyTwoBitDuration = - ThirtyTwoBitDuration - { unThirtyTwoBitDuration :: Word32 - } - deriving ( Bounded - , Data - , Enum - , Eq - , Generic - , Hashable - , Integral - , Num - , Ord - , Real - , Show - , Typeable - ) - -instance Wrapped ThirtyTwoBitDuration - -instance Pretty ThirtyTwoBitDuration where - pretty = pretty . concat . unfoldr durU . op ThirtyTwoBitDuration - -$(ATH.deriveJSON ATH.defaultOptions ''ThirtyTwoBitDuration) - -data RevocationClass - = SensitiveRK - | RClOther Word8 - deriving (Data, Generic, Show, Typeable) - -mkRevocationClass :: Word8 -> RevocationClass -mkRevocationClass i - | i' == 1 = SensitiveRK - | otherwise = RClOther i' - where - i' = i .&. 0x07 - -instance Eq RevocationClass where - (==) a b = fromFFlag a == fromFFlag b - -instance Ord RevocationClass where - compare = comparing fromFFlag - -instance FutureFlag RevocationClass where - fromFFlag SensitiveRK = 1 - fromFFlag (RClOther i) = fromIntegral (i .&. 0x07) - toFFlag 1 = SensitiveRK - toFFlag i = mkRevocationClass (fromIntegral i) - -instance Hashable RevocationClass - -instance Pretty RevocationClass where - pretty SensitiveRK = pretty "sensitive" - pretty (RClOther o) = pretty "unknown revocation class" <+> pretty o - -$(ATH.deriveJSON ATH.defaultOptions ''RevocationClass) - -data PubKeyAlgorithm - = RSA - | DeprecatedRSAEncryptOnly - | DeprecatedRSASignOnly - | ElgamalEncryptOnly - | DSA - | ECDH - | ECDSA - | ForbiddenElgamal - | DH - | EdDSA - | X25519 - | X448 - | Ed25519 - | Ed448 - | OtherPKA Word8 - deriving (Show, Data, Generic, Typeable) - -instance Eq PubKeyAlgorithm where - (==) a b = fromFVal a == fromFVal b - -instance Ord PubKeyAlgorithm where - compare = comparing fromFVal - -instance FutureVal PubKeyAlgorithm where - fromFVal RSA = 1 - fromFVal DeprecatedRSAEncryptOnly = 2 - fromFVal DeprecatedRSASignOnly = 3 - fromFVal ElgamalEncryptOnly = 16 - fromFVal DSA = 17 - fromFVal ECDH = 18 - fromFVal ECDSA = 19 - fromFVal ForbiddenElgamal = 20 - fromFVal DH = 21 - fromFVal EdDSA = 22 - fromFVal X25519 = 25 - fromFVal X448 = 26 - fromFVal Ed25519 = 27 - fromFVal Ed448 = 28 - fromFVal (OtherPKA o) = o - toFVal 1 = RSA - toFVal 2 = DeprecatedRSAEncryptOnly - toFVal 3 = DeprecatedRSASignOnly - toFVal 16 = ElgamalEncryptOnly - toFVal 17 = DSA - toFVal 18 = ECDH - toFVal 19 = ECDSA - toFVal 20 = ForbiddenElgamal - toFVal 21 = DH - toFVal 22 = EdDSA - toFVal 25 = X25519 - toFVal 26 = X448 - toFVal 27 = Ed25519 - toFVal 28 = Ed448 - toFVal o = OtherPKA o - -instance Hashable PubKeyAlgorithm - -instance Pretty PubKeyAlgorithm where - pretty RSA = pretty "RSA" - pretty DeprecatedRSAEncryptOnly = pretty "(deprecated) RSA encrypt-only" - pretty DeprecatedRSASignOnly = pretty "(deprecated) RSA sign-only" - pretty ElgamalEncryptOnly = pretty "Elgamal encrypt-only" - pretty DSA = pretty "DSA" - pretty ECDH = pretty "ECDH" - pretty ECDSA = pretty "ECDSA" - pretty ForbiddenElgamal = pretty "(forbidden) Elgamal" - pretty DH = pretty "DH" - pretty EdDSA = pretty "EdDSA" - pretty X25519 = pretty "X25519" - pretty X448 = pretty "X448" - pretty Ed25519 = pretty "Ed25519" - pretty Ed448 = pretty "Ed448" - pretty (OtherPKA pka) = pretty "unknown pubkey algorithm type" <+> pretty pka - -$(ATH.deriveJSON ATH.defaultOptions ''PubKeyAlgorithm) - --- | An OpenPGP fingerprint. Length depends on key version: --- 16 bytes (v3/MD5), 20 bytes (v4/SHA-1), or 32 bytes (v6/SHA-256). -newtype Fingerprint = - Fingerprint - { unFingerprint :: ByteString - } - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Wrapped Fingerprint - -instance Read Fingerprint where - readsPrec _ s = - let ws = hexToW8s (filter (/= ' ') s) - in if null ws - then [] - else [(Fingerprint (BL.pack (map fst ws)), snd (last ws))] - -instance Hashable Fingerprint - -instance Pretty Fingerprint where - pretty = pretty . bsToHexUpper . unFingerprint - --- FIXME: we should not be exporting this -key :: String -> AK.Key -key = AK.fromText . T.pack - -instance A.ToJSON Fingerprint where - toJSON e = object [key "fpr" .= (A.toJSON . show . pretty) e] - -instance A.FromJSON Fingerprint where - parseJSON (A.Object v) = Fingerprint . read <$> v A..: key "fpr" - parseJSON _ = mzero - -newtype SpacedFingerprint = - SpacedFingerprint - { unSpacedFingerprint :: Fingerprint - } - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Wrapped SpacedFingerprint - -instance Pretty SpacedFingerprint where - pretty = - hsep . - punctuate space . - map hsep . - chunksOf 5 . - map pretty . chunksOf 4 . bsToHexUpper . unFingerprint . op SpacedFingerprint - -bsToHexUpper :: ByteString -> String -bsToHexUpper = map toUpper . BLC8.unpack . B16L.encode - -hexToW8s :: ReadS Word8 -hexToW8s = concatMap readHex . chunksOf 2 . map toLower - -newtype EightOctetKeyId = - EightOctetKeyId - { unEOKI :: ByteString - } - deriving (Data, Eq, Generic, Ord, Typeable) - -instance Wrapped EightOctetKeyId - -instance Pretty EightOctetKeyId where - pretty = pretty . bsToHexUpper . op EightOctetKeyId - -instance Show EightOctetKeyId where - show = bsToHexUpper . op EightOctetKeyId - -instance Read EightOctetKeyId where - readsPrec _ = - map ((EightOctetKeyId . BL.pack *** concat) . unzip) . chunksOf 8 . hexToW8s - -instance Hashable EightOctetKeyId - -instance A.ToJSON EightOctetKeyId where - toJSON e = object [key "eoki" .= (bsToHexUpper . op EightOctetKeyId) e] - -instance A.FromJSON EightOctetKeyId where - parseJSON (A.Object v) = EightOctetKeyId . read <$> v A..: key "eoki" - parseJSON _ = mzero - -data KeyIdentifier - = KeyIdentifierWildcard - | KeyIdentifierEightOctet EightOctetKeyId - | KeyIdentifierFingerprint Fingerprint - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Pretty KeyIdentifier where - pretty KeyIdentifierWildcard = pretty "wildcard" - pretty (KeyIdentifierEightOctet kid) = pretty "key-id" <+> pretty kid - pretty (KeyIdentifierFingerprint fp) = pretty "fingerprint" <+> pretty fp - -instance A.ToJSON KeyIdentifier where - toJSON KeyIdentifierWildcard = object [key "wildcard" .= A.Bool True] - toJSON (KeyIdentifierEightOctet kid) = object [key "keyId" .= kid] - toJSON (KeyIdentifierFingerprint fp) = object [key "fingerprint" .= fp] - -instance A.FromJSON KeyIdentifier where - parseJSON (A.Object v) = - ((v A..: key "wildcard") >>= \isWildcard -> - if isWildcard then pure KeyIdentifierWildcard else mzero) - <|> (KeyIdentifierEightOctet <$> v A..: key "keyId") - <|> (KeyIdentifierFingerprint <$> v A..: key "fingerprint") - parseJSON _ = mzero - -newtype NotationName = - NotationName - { unNotationName :: ByteString - } - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) - -instance Pretty NotationName where - pretty = prettyLBS . unNotationName - -instance Wrapped NotationName - -instance A.ToJSON NotationName where - toJSON nn = object [key "notationname" .= show (op NotationName nn)] - -instance A.FromJSON NotationName where - parseJSON (A.Object v) = NotationName . read <$> v A..: key "notationname" - parseJSON _ = mzero - -newtype NotationValue = - NotationValue - { unNotationValue :: ByteString - } - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) - -instance Pretty NotationValue where - pretty = prettyLBS . unNotationValue - -instance Wrapped NotationValue - -instance A.ToJSON NotationValue where - toJSON nv = object [key "notationvalue" .= show (op NotationValue nv)] - -instance A.FromJSON NotationValue where - parseJSON (A.Object v) = - NotationValue . read <$> v A..: key "notationvalue" - parseJSON _ = mzero - -data HashAlgorithm - = DeprecatedMD5 - | SHA1 - | RIPEMD160 - | SHA256 - | SHA384 - | SHA512 - | SHA224 - | SHA3_256 - | SHA3_512 - | OtherHA Word8 - deriving (Data, Generic, Show, Typeable) - -instance Eq HashAlgorithm where - (==) a b = fromFVal a == fromFVal b - -instance Ord HashAlgorithm where - compare = comparing fromFVal - -instance FutureVal HashAlgorithm where - fromFVal DeprecatedMD5 = 1 - fromFVal SHA1 = 2 - fromFVal RIPEMD160 = 3 - fromFVal SHA256 = 8 - fromFVal SHA384 = 9 - fromFVal SHA512 = 10 - fromFVal SHA224 = 11 - fromFVal SHA3_256 = 12 - fromFVal SHA3_512 = 14 - fromFVal (OtherHA o) = o - toFVal 1 = DeprecatedMD5 - toFVal 2 = SHA1 - toFVal 3 = RIPEMD160 - toFVal 8 = SHA256 - toFVal 9 = SHA384 - toFVal 10 = SHA512 - toFVal 11 = SHA224 - toFVal 12 = SHA3_256 - toFVal 14 = SHA3_512 - toFVal o = OtherHA o - -instance Hashable HashAlgorithm - -instance Pretty HashAlgorithm where - pretty DeprecatedMD5 = pretty "(deprecated) MD5" - pretty SHA1 = pretty "SHA-1" - pretty RIPEMD160 = pretty "RIPEMD-160" - pretty SHA256 = pretty "SHA-256" - pretty SHA384 = pretty "SHA-384" - pretty SHA512 = pretty "SHA-512" - pretty SHA224 = pretty "SHA-224" - pretty SHA3_256 = pretty "SHA3-256" - pretty SHA3_512 = pretty "SHA3-512" - pretty (OtherHA ha) = pretty "unknown hash algorithm type" <+> pretty ha - -$(ATH.deriveJSON ATH.defaultOptions ''HashAlgorithm) - -data CompressionAlgorithm - = Uncompressed - | ZIP - | ZLIB - | BZip2 - | OtherCA Word8 - deriving (Show, Data, Generic, Typeable) - -instance Eq CompressionAlgorithm where - (==) a b = fromFVal a == fromFVal b - -instance Ord CompressionAlgorithm where - compare = comparing fromFVal - -instance FutureVal CompressionAlgorithm where - fromFVal Uncompressed = 0 - fromFVal ZIP = 1 - fromFVal ZLIB = 2 - fromFVal BZip2 = 3 - fromFVal (OtherCA o) = o - toFVal 0 = Uncompressed - toFVal 1 = ZIP - toFVal 2 = ZLIB - toFVal 3 = BZip2 - toFVal o = OtherCA o - -instance Hashable CompressionAlgorithm - -instance Pretty CompressionAlgorithm where - pretty Uncompressed = pretty "uncompressed" - pretty ZIP = pretty "ZIP" - pretty ZLIB = pretty "zlib" - pretty BZip2 = pretty "bzip2" - pretty (OtherCA ca) = - pretty "unknown compression algorithm type" <+> pretty ca - -$(ATH.deriveJSON ATH.defaultOptions ''CompressionAlgorithm) - -data AEADAlgorithm - = EAX - | OCB - | GCM - | OtherAEADAlgo Word8 - deriving (Show, Data, Generic, Typeable) - -instance Eq AEADAlgorithm where - (==) a b = fromFVal a == fromFVal b - -instance Ord AEADAlgorithm where - compare = comparing fromFVal - -instance FutureVal AEADAlgorithm where - fromFVal EAX = 1 - fromFVal OCB = 2 - fromFVal GCM = 3 - fromFVal (OtherAEADAlgo o) = o - toFVal 1 = EAX - toFVal 2 = OCB - toFVal 3 = GCM - toFVal o = OtherAEADAlgo o - -instance Hashable AEADAlgorithm - -instance Pretty AEADAlgorithm where - pretty EAX = pretty "EAX" - pretty OCB = pretty "OCB" - pretty GCM = pretty "GCM" - pretty (OtherAEADAlgo aa) = pretty "unknown AEAD algorithm type" <+> pretty aa - -$(ATH.deriveJSON ATH.defaultOptions ''AEADAlgorithm) - -data KSPFlag - = NoModify - | KSPOther Int - deriving (Data, Generic, Show, Typeable) - -instance Eq KSPFlag where - (==) a b = fromFFlag a == fromFFlag b - -instance Ord KSPFlag where - compare = comparing fromFFlag - -instance FutureFlag KSPFlag where - fromFFlag NoModify = 0 - fromFFlag (KSPOther i) = fromIntegral i - toFFlag 0 = NoModify - toFFlag i = KSPOther (fromIntegral i) - -instance Hashable KSPFlag - -instance Pretty KSPFlag where - pretty NoModify = pretty "no-modify" - pretty (KSPOther o) = - pretty "unknown keyserver preference flag type" <+> pretty o - -$(ATH.deriveJSON ATH.defaultOptions ''KSPFlag) - -data KeyFlag - = GroupKey - | AuthKey - | SplitKey - | EncryptStorageKey - | EncryptCommunicationsKey - | SignDataKey - | CertifyKeysKey - | KFOther Int - deriving (Data, Generic, Show, Typeable) - -instance Eq KeyFlag where - (==) a b = fromFFlag a == fromFFlag b - -instance Ord KeyFlag where - compare = comparing fromFFlag - -instance FutureFlag KeyFlag where - fromFFlag GroupKey = 0 - fromFFlag AuthKey = 2 - fromFFlag SplitKey = 3 - fromFFlag EncryptStorageKey = 4 - fromFFlag EncryptCommunicationsKey = 5 - fromFFlag SignDataKey = 6 - fromFFlag CertifyKeysKey = 7 - fromFFlag (KFOther i) = fromIntegral i - toFFlag 0 = GroupKey - toFFlag 2 = AuthKey - toFFlag 3 = SplitKey - toFFlag 4 = EncryptStorageKey - toFFlag 5 = EncryptCommunicationsKey - toFFlag 6 = SignDataKey - toFFlag 7 = CertifyKeysKey - toFFlag i = KFOther (fromIntegral i) - -instance Hashable KeyFlag - -instance Pretty KeyFlag where - pretty GroupKey = pretty "group" - pretty AuthKey = pretty "auth" - pretty SplitKey = pretty "split" - pretty EncryptStorageKey = pretty "encrypt-storage" - pretty EncryptCommunicationsKey = pretty "encrypt-communications" - pretty SignDataKey = pretty "sign-data" - pretty CertifyKeysKey = pretty "certify-keys" - pretty (KFOther o) = pretty "unknown key flag type" <+> pretty o - -$(ATH.deriveJSON ATH.defaultOptions ''KeyFlag) - -data RevocationCode - = NoReason - | KeySuperseded - | KeyMaterialCompromised - | KeyRetiredAndNoLongerUsed - | UserIdInfoNoLongerValid - | RCoOther Word8 - deriving (Data, Generic, Show, Typeable) - -instance Eq RevocationCode where - (==) a b = fromFVal a == fromFVal b - -instance Ord RevocationCode where - compare = comparing fromFVal - -instance FutureVal RevocationCode where - fromFVal NoReason = 0 - fromFVal KeySuperseded = 1 - fromFVal KeyMaterialCompromised = 2 - fromFVal KeyRetiredAndNoLongerUsed = 3 - fromFVal UserIdInfoNoLongerValid = 32 - fromFVal (RCoOther o) = o - toFVal 0 = NoReason - toFVal 1 = KeySuperseded - toFVal 2 = KeyMaterialCompromised - toFVal 3 = KeyRetiredAndNoLongerUsed - toFVal 32 = UserIdInfoNoLongerValid - toFVal o = RCoOther o - -instance Hashable RevocationCode - -instance Pretty RevocationCode where - pretty NoReason = pretty "no reason" - pretty KeySuperseded = pretty "key superseded" - pretty KeyMaterialCompromised = pretty "key material compromised" - pretty KeyRetiredAndNoLongerUsed = pretty "key retired and no longer used" - pretty UserIdInfoNoLongerValid = pretty "user-ID info no longer valid" - pretty (RCoOther o) = pretty "unknown revocation code" <+> pretty o - -$(ATH.deriveJSON ATH.defaultOptions ''RevocationCode) - -data FeatureFlag - = FeatureSEIPDv1 - | FeatureSEIPDv2 - | FeatureOther Int - deriving (Data, Generic, Show, Typeable) - -instance Eq FeatureFlag where - (==) a b = fromFFlag a == fromFFlag b - -instance Ord FeatureFlag where - compare = comparing fromFFlag - -instance FutureFlag FeatureFlag where - fromFFlag FeatureSEIPDv1 = 7 - fromFFlag FeatureSEIPDv2 = 4 - fromFFlag (FeatureOther i) = fromIntegral i - toFFlag 7 = FeatureSEIPDv1 - toFFlag 4 = FeatureSEIPDv2 - toFFlag i = FeatureOther (fromIntegral i) - -instance Hashable FeatureFlag - -instance Pretty FeatureFlag where - pretty FeatureSEIPDv1 = pretty "seipd-v1" - pretty FeatureSEIPDv2 = pretty "seipd-v2" - pretty (FeatureOther o) = pretty "unknown feature flag type" <+> pretty o - -$(ATH.deriveJSON ATH.defaultOptions ''FeatureFlag) - -newtype URL = - URL - { unURL :: URI - } - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Wrapped URL - -instance Hashable URL where - hashWithSalt salt (URL (URI s a p q f)) = - salt `hashWithSalt` s `hashWithSalt` show a `hashWithSalt` p `hashWithSalt` - q `hashWithSalt` - f - -instance Pretty URL where - pretty = pretty . (\uri -> uriToString id uri "") . op URL - -instance A.ToJSON URL where - toJSON u = object [key "uri" .= (\uri -> uriToString id uri "") (op URL u)] - -instance A.FromJSON URL where - parseJSON (A.Object v) = - URL . fromMaybe nullURI . parseURI <$> v A..: key "uri" - parseJSON _ = mzero - -data SigType - = BinarySig - | CanonicalTextSig - | StandaloneSig - | GenericCert - | PersonaCert - | CasualCert - | PositiveCert - | SubkeyBindingSig - | PrimaryKeyBindingSig - | SignatureDirectlyOnAKey - | KeyRevocationSig - | SubkeyRevocationSig - | CertRevocationSig - | TimestampSig - | ThirdPartyConfirmationSig - | OtherSig Word8 - deriving (Data, Generic, Show, Typeable) - -instance Eq SigType where - (==) a b = fromFVal a == fromFVal b - -instance Ord SigType where - compare = comparing fromFVal - -instance FutureVal SigType where - fromFVal BinarySig = 0x00 - fromFVal CanonicalTextSig = 0x01 - fromFVal StandaloneSig = 0x02 - fromFVal GenericCert = 0x10 - fromFVal PersonaCert = 0x11 - fromFVal CasualCert = 0x12 - fromFVal PositiveCert = 0x13 - fromFVal SubkeyBindingSig = 0x18 - fromFVal PrimaryKeyBindingSig = 0x19 - fromFVal SignatureDirectlyOnAKey = 0x1F - fromFVal KeyRevocationSig = 0x20 - fromFVal SubkeyRevocationSig = 0x28 - fromFVal CertRevocationSig = 0x30 - fromFVal TimestampSig = 0x40 - fromFVal ThirdPartyConfirmationSig = 0x50 - fromFVal (OtherSig o) = o - toFVal 0x00 = BinarySig - toFVal 0x01 = CanonicalTextSig - toFVal 0x02 = StandaloneSig - toFVal 0x10 = GenericCert - toFVal 0x11 = PersonaCert - toFVal 0x12 = CasualCert - toFVal 0x13 = PositiveCert - toFVal 0x18 = SubkeyBindingSig - toFVal 0x19 = PrimaryKeyBindingSig - toFVal 0x1F = SignatureDirectlyOnAKey - toFVal 0x20 = KeyRevocationSig - toFVal 0x28 = SubkeyRevocationSig - toFVal 0x30 = CertRevocationSig - toFVal 0x40 = TimestampSig - toFVal 0x50 = ThirdPartyConfirmationSig - toFVal o = OtherSig o - -instance Hashable SigType - -instance Pretty SigType where - pretty BinarySig = pretty "binary" - pretty CanonicalTextSig = pretty "canonical-pretty" - pretty StandaloneSig = pretty "standalone" - pretty GenericCert = pretty "generic" - pretty PersonaCert = pretty "persona" - pretty CasualCert = pretty "casual" - pretty PositiveCert = pretty "positive" - pretty SubkeyBindingSig = pretty "subkey-binding" - pretty PrimaryKeyBindingSig = pretty "primary-key-binding" - pretty SignatureDirectlyOnAKey = pretty "signature directly on a key" - pretty KeyRevocationSig = pretty "key-revocation" - pretty SubkeyRevocationSig = pretty "subkey-revocation" - pretty CertRevocationSig = pretty "cert-revocation" - pretty TimestampSig = pretty "timestamp" - pretty ThirdPartyConfirmationSig = pretty "third-party-confirmation" - pretty (OtherSig o) = pretty "unknown signature type" <+> pretty o - -$(ATH.deriveJSON ATH.defaultOptions ''SigType) - -newtype MPI = - MPI - { unMPI :: Integer - } - deriving (Data, Eq, Generic, Show, Typeable) - -instance Wrapped MPI - -instance Ord MPI where - compare (MPI a) (MPI b) = compare a b - -instance Hashable MPI - -instance Pretty MPI where - pretty = pretty . op MPI - -$(ATH.deriveJSON ATH.defaultOptions ''MPI) - -newtype SignatureSalt = - SignatureSalt - { unSignatureSalt :: ByteString - } - deriving (Data, Eq, Generic, Show, Typeable) - -instance Ord SignatureSalt where - compare (SignatureSalt a) (SignatureSalt b) = compare a b - -instance Hashable SignatureSalt - -instance Pretty SignatureSalt where - pretty (SignatureSalt bs) = prettyLBS bs - -instance A.ToJSON SignatureSalt where - toJSON (SignatureSalt bs) = A.toJSON (BL.unpack bs) - -data SignaturePayloadVersion - = SigPayloadV3 - | SigPayloadV4 - | SigPayloadV6 - | SigPayloadVOther - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Hashable SignaturePayloadVersion - -data SignaturePayloadV (v :: SignaturePayloadVersion) where - SigPayloadV3Data :: - SigType - -> ThirtyTwoBitTimeStamp - -> EightOctetKeyId - -> PubKeyAlgorithm - -> HashAlgorithm - -> Word16 - -> NonEmpty MPI - -> SignaturePayloadV 'SigPayloadV3 - SigPayloadV4Data :: - SigType - -> PubKeyAlgorithm - -> HashAlgorithm - -> [SigSubPacket] - -> [SigSubPacket] - -> Word16 - -> NonEmpty MPI - -> SignaturePayloadV 'SigPayloadV4 - SigPayloadV6Data :: - SigType - -> PubKeyAlgorithm - -> HashAlgorithm - -> SignatureSalt - -> [SigSubPacket] - -> [SigSubPacket] - -> Word16 - -> NonEmpty MPI - -> SignaturePayloadV 'SigPayloadV6 - SigPayloadOtherData :: - Word8 - -> ByteString - -> SignaturePayloadV 'SigPayloadVOther - -deriving instance Eq (SignaturePayloadV v) -deriving instance Show (SignaturePayloadV v) - -data SomeSignaturePayload where - SomeSignaturePayload :: SignaturePayloadV v -> SomeSignaturePayload - -toSignaturePayload :: SignaturePayloadV v -> SignaturePayload -toSignaturePayload (SigPayloadV3Data st ts eoki pka ha w16 mpis) = - SigV3 st ts eoki pka ha w16 mpis -toSignaturePayload (SigPayloadV4Data st pka ha hsps usps w16 mpis) = - SigV4 st pka ha hsps usps w16 mpis -toSignaturePayload (SigPayloadV6Data st pka ha salt hsps usps w16 mpis) = - SigV6 st pka ha salt hsps usps w16 mpis -toSignaturePayload (SigPayloadOtherData v bs) = - SigVOther v bs - -toSomeSignaturePayload :: SignaturePayload -> SomeSignaturePayload -toSomeSignaturePayload (SigV3 st ts eoki pka ha w16 mpis) = - SomeSignaturePayload (SigPayloadV3Data st ts eoki pka ha w16 mpis) -toSomeSignaturePayload (SigV4 st pka ha hsps usps w16 mpis) = - SomeSignaturePayload (SigPayloadV4Data st pka ha hsps usps w16 mpis) -toSomeSignaturePayload (SigV6 st pka ha salt hsps usps w16 mpis) = - SomeSignaturePayload (SigPayloadV6Data st pka ha salt hsps usps w16 mpis) -toSomeSignaturePayload (SigVOther v bs) = - SomeSignaturePayload (SigPayloadOtherData v bs) - -signaturePayloadVersion :: SignaturePayload -> SignaturePayloadVersion -signaturePayloadVersion (SigV3 _ _ _ _ _ _ _) = SigPayloadV3 -signaturePayloadVersion (SigV4 _ _ _ _ _ _ _) = SigPayloadV4 -signaturePayloadVersion (SigV6 _ _ _ _ _ _ _ _) = SigPayloadV6 -signaturePayloadVersion (SigVOther _ _) = SigPayloadVOther - -asSignaturePayloadV3 :: SignaturePayload -> Either String (SignaturePayloadV 'SigPayloadV3) -asSignaturePayloadV3 (SigV3 st ts eoki pka ha w16 mpis) = - Right (SigPayloadV3Data st ts eoki pka ha w16 mpis) -asSignaturePayloadV3 _ = - Left "Cannot coerce non-v3 SignaturePayload to SignaturePayloadV3" - -asSignaturePayloadV4 :: SignaturePayload -> Either String (SignaturePayloadV 'SigPayloadV4) -asSignaturePayloadV4 (SigV4 st pka ha hsps usps w16 mpis) = - Right (SigPayloadV4Data st pka ha hsps usps w16 mpis) -asSignaturePayloadV4 _ = - Left "Cannot coerce non-v4 SignaturePayload to SignaturePayloadV4" - -asSignaturePayloadV6 :: SignaturePayload -> Either String (SignaturePayloadV 'SigPayloadV6) -asSignaturePayloadV6 (SigV6 st pka ha salt hsps usps w16 mpis) = - Right (SigPayloadV6Data st pka ha salt hsps usps w16 mpis) -asSignaturePayloadV6 _ = - Left "Cannot coerce non-v6 SignaturePayload to SignaturePayloadV6" - -asSignaturePayloadOther :: SignaturePayload -> Either String (SignaturePayloadV 'SigPayloadVOther) -asSignaturePayloadOther (SigVOther v bs) = - Right (SigPayloadOtherData v bs) -asSignaturePayloadOther _ = - Left "Cannot coerce known-version SignaturePayload to SignaturePayloadVOther" - -data SignaturePayload - = SigV3 - SigType - ThirtyTwoBitTimeStamp - EightOctetKeyId - PubKeyAlgorithm - HashAlgorithm - Word16 - (NonEmpty MPI) - | SigV4 - SigType - PubKeyAlgorithm - HashAlgorithm - [SigSubPacket] - [SigSubPacket] - Word16 - (NonEmpty MPI) - | SigV6 - SigType - PubKeyAlgorithm - HashAlgorithm - SignatureSalt - [SigSubPacket] - [SigSubPacket] - Word16 - (NonEmpty MPI) - | SigVOther Word8 ByteString - deriving (Data, Eq, Generic, Show, Typeable) - -instance Hashable SignaturePayload - -instance Ord SignaturePayload where - compare (SigV3 st1 ts1 eoki1 pka1 ha1 w161 mpis1) - (SigV3 st2 ts2 eoki2 pka2 ha2 w162 mpis2) = - compare st1 st2 <> compare ts1 ts2 <> compare eoki1 eoki2 <> - compare pka1 pka2 <> compare ha1 ha2 <> compare w161 w162 <> - compare (NE.toList mpis1) (NE.toList mpis2) - compare (SigV4 st1 pka1 ha1 hsp1 usp1 w161 mpis1) - (SigV4 st2 pka2 ha2 hsp2 usp2 w162 mpis2) = - compare st1 st2 <> compare pka1 pka2 <> compare ha1 ha2 <> - compare hsp1 hsp2 <> compare usp1 usp2 <> compare w161 w162 <> - compare (NE.toList mpis1) (NE.toList mpis2) - compare (SigV6 st1 pka1 ha1 salt1 hsp1 usp1 w161 mpis1) - (SigV6 st2 pka2 ha2 salt2 hsp2 usp2 w162 mpis2) = - compare st1 st2 <> compare pka1 pka2 <> compare ha1 ha2 <> - compare salt1 salt2 <> compare hsp1 hsp2 <> compare usp1 usp2 <> - compare w161 w162 <> compare (NE.toList mpis1) (NE.toList mpis2) - compare (SigVOther t1 bs1) (SigVOther t2 bs2) = compare t1 t2 <> compare bs1 bs2 - compare SigV3 {} SigV4 {} = LT - compare SigV3 {} SigV6 {} = LT - compare SigV3 {} SigVOther {} = LT - compare SigV4 {} SigV3 {} = GT - compare SigV4 {} SigV6 {} = LT - compare SigV4 {} SigVOther {} = LT - compare SigV6 {} SigV3 {} = GT - compare SigV6 {} SigV4 {} = GT - compare SigV6 {} SigVOther {} = LT - compare SigVOther {} SigV3 {} = GT - compare SigVOther {} SigV4 {} = GT - compare SigVOther {} SigV6 {} = GT - -instance Pretty SignaturePayload where - pretty (SigV3 st ts eoki pka ha w16 mpis) = - pretty "signature v3" <> pretty ':' <+> - pretty st <+> - pretty ts <+> - pretty eoki <+> - pretty pka <+> pretty ha <+> pretty w16 <+> (pretty . NE.toList) mpis - pretty (SigV4 st pka ha hsps usps w16 mpis) = - pretty "signature v4" <> pretty ':' <+> - pretty st <+> - pretty pka <+> - pretty ha <+> - pretty hsps <+> pretty usps <+> pretty w16 <+> (pretty . NE.toList) mpis - pretty (SigV6 st pka ha salt hsps usps w16 mpis) = - pretty "signature v6" <> pretty ':' <+> - pretty st <+> - pretty pka <+> - pretty ha <+> - pretty salt <+> - pretty hsps <+> pretty usps <+> pretty w16 <+> (pretty . NE.toList) mpis - pretty (SigVOther t bs) = - pretty "unknown signature v" <> pretty t <> pretty ':' <+> - pretty (BL.unpack bs) - -instance A.ToJSON SignaturePayload where - toJSON (SigV3 st ts eoki pka ha w16 mpis) = - A.toJSON (st, ts, eoki, pka, ha, w16, NE.toList mpis) - toJSON (SigV4 st pka ha hsps usps w16 mpis) = - A.toJSON (st, pka, ha, hsps, usps, w16, NE.toList mpis) - toJSON (SigV6 st pka ha salt hsps usps w16 mpis) = - A.toJSON (st, pka, ha, salt, hsps, usps, w16, NE.toList mpis) - toJSON (SigVOther t bs) = A.toJSON (t, BL.unpack bs) - -data IssuerFingerprintVersion - = IssuerFingerprintV4 - | IssuerFingerprintV6 - deriving (Data, Eq, Generic, Show, Typeable) - -instance Ord IssuerFingerprintVersion where - IssuerFingerprintV4 `compare` IssuerFingerprintV4 = EQ - IssuerFingerprintV4 `compare` IssuerFingerprintV6 = LT - IssuerFingerprintV6 `compare` IssuerFingerprintV4 = GT - IssuerFingerprintV6 `compare` IssuerFingerprintV6 = EQ - -instance Hashable IssuerFingerprintVersion - -instance Pretty IssuerFingerprintVersion where - pretty IssuerFingerprintV4 = pretty "4" - pretty IssuerFingerprintV6 = pretty "6" - -instance A.ToJSON IssuerFingerprintVersion where - toJSON IssuerFingerprintV4 = A.toJSON (4 :: Word8) - toJSON IssuerFingerprintV6 = A.toJSON (6 :: Word8) - -instance A.FromJSON IssuerFingerprintVersion where - parseJSON (A.Number n) = case round n of - 4 -> pure IssuerFingerprintV4 - 6 -> pure IssuerFingerprintV6 - _ -> mzero - parseJSON _ = mzero - -issuerFingerprintVersionToPacketVersion :: IssuerFingerprintVersion -> PacketVersion -issuerFingerprintVersionToPacketVersion IssuerFingerprintV4 = 4 -issuerFingerprintVersionToPacketVersion IssuerFingerprintV6 = 6 - -packetVersionToIssuerFingerprintVersion :: PacketVersion -> Maybe IssuerFingerprintVersion -packetVersionToIssuerFingerprintVersion 4 = Just IssuerFingerprintV4 -packetVersionToIssuerFingerprintVersion 6 = Just IssuerFingerprintV6 -packetVersionToIssuerFingerprintVersion _ = Nothing - -data SigSubPacketPayload - = SigCreationTime ThirtyTwoBitTimeStamp - | SigExpirationTime ThirtyTwoBitDuration - | ExportableCertification Exportability - | TrustSignature TrustLevel TrustAmount - | RegularExpression AlmostPublicDomainRegex - | Revocable Revocability - | KeyExpirationTime ThirtyTwoBitDuration - | PreferredSymmetricAlgorithms [SymmetricAlgorithm] - | RevocationKey (Set RevocationClass) PubKeyAlgorithm Fingerprint - | Issuer EightOctetKeyId - | NotationData (Set NotationFlag) NotationName NotationValue - | PreferredHashAlgorithms [HashAlgorithm] - | PreferredCompressionAlgorithms [CompressionAlgorithm] - | KeyServerPreferences (Set KSPFlag) - | PreferredKeyServer KeyServer - | PrimaryUserId Bool - | PolicyURL URL - | KeyFlags (Set KeyFlag) - | SignersUserId Text - | ReasonForRevocation RevocationCode RevocationReason - | Features (Set FeatureFlag) - | SignatureTarget PubKeyAlgorithm HashAlgorithm SignatureHash - | EmbeddedSignature SignaturePayload - | IssuerFingerprint IssuerFingerprintVersion Fingerprint - | UserDefinedSigSub Word8 ByteString - | OtherSigSub Word8 ByteString - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Hashable SigSubPacketPayload - -instance Pretty SigSubPacketPayload where - pretty (SigCreationTime ts) = pretty "creation-time" <+> pretty ts - pretty (SigExpirationTime d) = pretty "sig expiration time" <+> pretty d - pretty (ExportableCertification e) = - pretty "exportable certification" <+> pretty e - pretty (TrustSignature tl ta) = - pretty "trust signature" <+> pretty tl <+> pretty ta - pretty (RegularExpression apdre) = - pretty "regular expression" <+> prettyLBS apdre - pretty (Revocable r) = pretty "revocable" <+> pretty r - pretty (KeyExpirationTime d) = pretty "key expiration time" <+> pretty d - pretty (PreferredSymmetricAlgorithms sas) = - pretty "preferred symmetric algorithms" <+> pretty sas - pretty (RevocationKey rcs pka tof) = - pretty "revocation key" <+> - pretty (Set.toList rcs) <+> pretty pka <+> pretty tof - pretty (Issuer eoki) = pretty "issuer" <+> pretty eoki - pretty (NotationData nfs nn nv) = - pretty "notation data" <+> - pretty (Set.toList nfs) <+> pretty nn <+> pretty nv - pretty (PreferredHashAlgorithms phas) = - pretty "preferred hash algorithms" <+> pretty phas - pretty (PreferredCompressionAlgorithms pcas) = - pretty "preferred compression algorithms" <+> pretty pcas - pretty (KeyServerPreferences kspfs) = - pretty "keyserver preferences" <+> pretty (Set.toList kspfs) - pretty (PreferredKeyServer ks) = pretty "preferred keyserver" <+> prettyLBS ks - pretty (PrimaryUserId p) = - (if p - then mempty - else pretty "NOT ") <> - pretty "primary user-ID" - pretty (PolicyURL u) = pretty "policy URL" <+> pretty u - pretty (KeyFlags kfs) = pretty "key flags" <+> pretty (Set.toList kfs) - pretty (SignersUserId u) = pretty "signer's user-ID" <+> pretty u - pretty (ReasonForRevocation rc rr) = - pretty "reason for revocation" <+> pretty rc <+> pretty rr - pretty (Features ffs) = pretty "features" <+> pretty (Set.toList ffs) - pretty (SignatureTarget pka ha sh) = - pretty "signature target" <+> pretty pka <+> pretty ha <+> prettyLBS sh - pretty (EmbeddedSignature sp) = pretty "embedded signature" <+> pretty sp - pretty (IssuerFingerprint kv ifp) = - pretty "issuer fingerprint (v" <> pretty kv <> pretty ")" <+> pretty ifp - pretty (UserDefinedSigSub t bs) = - pretty "user-defined signature subpacket type" <+> - pretty t <+> pretty (BL.unpack bs) - pretty (OtherSigSub t bs) = - pretty "unknown signature subpacket type" <+> pretty t <+> prettyLBS bs - -instance A.ToJSON SigSubPacketPayload where - toJSON (SigCreationTime ts) = object [key "sigCreationTime" .= ts] - toJSON (SigExpirationTime d) = object [key "sigExpirationTime" .= d] - toJSON (ExportableCertification e) = - object [key "exportableCertification" .= e] - toJSON (TrustSignature tl ta) = object [key "trustSignature" .= (tl, ta)] - toJSON (RegularExpression apdre) = - object [key "regularExpression" .= BL.unpack apdre] - toJSON (Revocable r) = object [key "revocable" .= r] - toJSON (KeyExpirationTime d) = object [key "keyExpirationTime" .= d] - toJSON (PreferredSymmetricAlgorithms sas) = - object [key "preferredSymmetricAlgorithms" .= sas] - toJSON (RevocationKey rcs pka tof) = - object [key "revocationKey" .= (rcs, pka, tof)] - toJSON (Issuer eoki) = object [key "issuer" .= eoki] - toJSON (NotationData nfs (NotationName nn) (NotationValue nv)) = - object [key "notationData" .= (nfs, BL.unpack nn, BL.unpack nv)] - toJSON (PreferredHashAlgorithms phas) = - object [key "preferredHashAlgorithms" .= phas] - toJSON (PreferredCompressionAlgorithms pcas) = - object [key "preferredCompressionAlgorithms" .= pcas] - toJSON (KeyServerPreferences kspfs) = - object [key "keyServerPreferences" .= kspfs] - toJSON (PreferredKeyServer ks) = - object [key "preferredKeyServer" .= show ks] - toJSON (PrimaryUserId p) = object [key "primaryUserId" .= p] - toJSON (PolicyURL u) = object [key "policyURL" .= u] - toJSON (KeyFlags kfs) = object [key "keyFlags" .= kfs] - toJSON (SignersUserId u) = object [key "signersUserId" .= u] - toJSON (ReasonForRevocation rc rr) = - object [key "reasonForRevocation" .= (rc, rr)] - toJSON (Features ffs) = object [key "features" .= ffs] - toJSON (SignatureTarget pka ha sh) = - object [key "signatureTarget" .= (pka, ha, BL.unpack sh)] - toJSON (EmbeddedSignature sp) = object [key "embeddedSignature" .= sp] - toJSON (IssuerFingerprint kv ifp) = - object [key "issuerFingerprint" .= (kv, ifp)] - toJSON (UserDefinedSigSub t bs) = - object [key "userDefinedSigSub" .= (t, BL.unpack bs)] - toJSON (OtherSigSub t bs) = object [key "otherSigSub" .= (t, BL.unpack bs)] - -uc3 :: (a -> b -> c -> d) -> (a, b, c) -> d -uc3 f ~(a, b, c) = f a b c - -instance A.FromJSON SigSubPacketPayload where - parseJSON (A.Object v) = - (SigCreationTime <$> v A..: key "sigCreationTime") <|> - (SigExpirationTime <$> v A..: key "sigExpirationTime") <|> - (ExportableCertification <$> v A..: key "exportableCertification") <|> - (uncurry TrustSignature <$> v A..: key "trustSignature") <|> - (RegularExpression . BL.pack <$> v A..: key "regularExpression") <|> - (Revocable <$> v A..: key "revocable") <|> - (KeyExpirationTime <$> v A..: key "keyExpirationTime") <|> - (PreferredSymmetricAlgorithms <$> - v A..: key "preferredSymmetricAlgorithms") <|> - (uc3 RevocationKey <$> v A..: key "revocationKey") <|> - (Issuer <$> v A..: key "issuer") <|> - (uc3 NotationData <$> v A..: key "notationData") - parseJSON _ = mzero - -data SigSubPacket = - SigSubPacket - { _sspCriticality :: Bool - , _sspPayload :: SigSubPacketPayload - } - deriving (Data, Eq, Generic, Show, Typeable) - -instance Ord SigSubPacket where - compare (SigSubPacket crit1 payload1) (SigSubPacket crit2 payload2) = - compare crit1 crit2 <> compare payload1 payload2 - -instance Pretty SigSubPacket where - pretty x = - (if _sspCriticality x - then pretty '*' - else mempty) <> - (pretty . _sspPayload) x - -instance Hashable SigSubPacket - -instance A.ToJSON SigSubPacket -instance A.FromJSON SigSubPacket - -$(makeLenses ''SigSubPacket) - --- | Type-safe subpacket list with phantom types to distinguish hashed vs unhashed --- and signature version constraints (v4 vs v6). --- The type parameters erase at runtime; they exist purely for compile-time safety. -newtype SubpacketList (hashedness :: Type) (version :: Type) = SubpacketList [SigSubPacket] - deriving (Show, Eq, Ord, Generic, Data, Typeable) - -instance Functor (SubpacketList h) where - fmap _ (SubpacketList sps) = SubpacketList sps - --- | Extract the underlying list from a phantom-typed SubpacketList --- This is typically used internally during serialization/deserialization -fromSubpacketList :: SubpacketList h v -> [SigSubPacket] -fromSubpacketList (SubpacketList sps) = sps - --- | Wrap a plain list into a phantom-typed SubpacketList --- Warning: This circumvents type safety; use only for trusted sources (e.g., parsing) -toSubpacketList :: [SigSubPacket] -> SubpacketList h v -toSubpacketList = SubpacketList - --- | Create an empty hashed subpacket list for a given signature version -emptyHashedSubpackets :: SubpacketList Hashed v -emptyHashedSubpackets = SubpacketList [] - --- | Create an empty unhashed subpacket list for a given signature version -emptyUnhashedSubpackets :: SubpacketList Unhashed v -emptyUnhashedSubpackets = SubpacketList [] - --- | Append a subpacket to a hashed list, preserving phantom type -consHashedSubpacket :: SigSubPacket -> SubpacketList Hashed v -> SubpacketList Hashed v -consHashedSubpacket sp (SubpacketList sps) = SubpacketList (sp : sps) - --- | Append a subpacket to an unhashed list, preserving phantom type -consUnhashedSubpacket :: SigSubPacket -> SubpacketList Unhashed v -> SubpacketList Unhashed v -consUnhashedSubpacket sp (SubpacketList sps) = SubpacketList (sp : sps) - -data KeyVersion - = DeprecatedV3 - | V4 - | V6 - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Hashable KeyVersion - -instance Pretty KeyVersion where - pretty DeprecatedV3 = pretty "(deprecated) v3" - pretty V4 = pretty "v4" - pretty V6 = pretty "v6" - -$(ATH.deriveJSON ATH.defaultOptions ''KeyVersion) - -newtype IV = - IV - { unIV :: B.ByteString - } - deriving ( ByteArrayAccess - , Data - , Eq - , Generic - , Hashable - , Semigroup - , Monoid - , Show - , Typeable - ) - -instance Wrapped IV - -instance Ord IV where - compare (IV b1) (IV b2) = compare b1 b2 - -instance Pretty IV where - pretty = pretty . ("iv:" ++) . bsToHexUpper . BL.fromStrict . op IV - -instance A.ToJSON IV where - toJSON = A.toJSON . show . op IV - -data DataType - = BinaryData - | TextData - | UTF8Data - | OtherData Word8 - deriving (Show, Data, Generic, Typeable) - -instance Hashable DataType - -instance Eq DataType where - (==) a b = fromFVal a == fromFVal b - -instance Ord DataType where - compare = comparing fromFVal - -instance FutureVal DataType where - fromFVal BinaryData = fromIntegral . fromEnum $ 'b' - fromFVal TextData = fromIntegral . fromEnum $ 't' - fromFVal UTF8Data = fromIntegral . fromEnum $ 'u' - fromFVal (OtherData o) = o - toFVal 0x62 = BinaryData - toFVal 0x74 = TextData - toFVal 0x75 = UTF8Data - toFVal o = OtherData o - -instance Pretty DataType where - pretty BinaryData = pretty "binary" - pretty TextData = pretty "text" - pretty UTF8Data = pretty "UTF-8" - pretty (OtherData o) = pretty "other data type " <+> pretty o - -$(ATH.deriveJSON ATH.defaultOptions ''DataType) - -newtype SessionKey = - SessionKey - { unSessionKey :: B.ByteString - } - deriving (Data, Eq, Generic, Hashable, Show, Typeable) - -instance Wrapped SessionKey - -instance Ord SessionKey where - compare (SessionKey b1) (SessionKey b2) = compare b1 b2 - -newtype Salt = - Salt - { unSalt :: B.ByteString - } - deriving (Data, Eq, Generic, Hashable, Show, Typeable) - -instance Wrapped Salt - -instance Ord Salt where - compare (Salt b1) (Salt b2) = compare b1 b2 - -instance Pretty Salt where - pretty = pretty . ("salt:" ++) . bsToHexUpper . BL.fromStrict . op Salt - -instance A.ToJSON Salt where - toJSON = A.toJSON . show . op Salt - -newtype Salt8 = - Salt8 - { unSalt8 :: B.ByteString - } - deriving (Data, Eq, Generic, Hashable, Show, Typeable) - -instance Wrapped Salt8 - -instance Ord Salt8 where - compare (Salt8 b1) (Salt8 b2) = compare b1 b2 - -instance Pretty Salt8 where - pretty = pretty . ("salt8:" ++) . bsToHexUpper . BL.fromStrict . op Salt8 - -instance A.ToJSON Salt8 where - toJSON = A.toJSON . show . op Salt8 - -newtype Salt16 = - Salt16 - { unSalt16 :: B.ByteString - } - deriving (Data, Eq, Generic, Hashable, Show, Typeable) - -instance Wrapped Salt16 - -instance Ord Salt16 where - compare (Salt16 b1) (Salt16 b2) = compare b1 b2 - -instance Pretty Salt16 where - pretty = pretty . ("salt16:" ++) . bsToHexUpper . BL.fromStrict . op Salt16 - -instance A.ToJSON Salt16 where - toJSON = A.toJSON . show . op Salt16 - -salt8FromSalt :: Salt -> Maybe Salt8 -salt8FromSalt (Salt bs) - | B.length bs == 8 = Just (Salt8 bs) - | otherwise = Nothing - -salt16FromSalt :: Salt -> Maybe Salt16 -salt16FromSalt (Salt bs) - | B.length bs == 16 = Just (Salt16 bs) - | otherwise = Nothing - -saltFromSalt8 :: Salt8 -> Salt -saltFromSalt8 (Salt8 bs) = Salt bs - -saltFromSalt16 :: Salt16 -> Salt -saltFromSalt16 (Salt16 bs) = Salt bs - -newtype IterationCount = - IterationCount - { unIterationCount :: Int - } - deriving ( Bounded - , Data - , Enum - , Eq - , Generic - , Hashable - , Integral - , Num - , Ord - , Real - , Show - , Typeable - ) - -instance Wrapped IterationCount - -instance Pretty IterationCount where - pretty = pretty . op IterationCount - -$(ATH.deriveJSON ATH.defaultOptions ''IterationCount) - -data S2K - = Simple HashAlgorithm - | Salted HashAlgorithm Salt8 - | IteratedSalted HashAlgorithm Salt8 IterationCount - | Argon2 Salt16 Word8 Word8 Word8 - | OtherS2K Word8 ByteString - deriving (Data, Eq, Generic, Show, Typeable) - -instance Hashable S2K - -instance Ord S2K where - compare (Simple ha1) (Simple ha2) = compare ha1 ha2 - compare (Salted ha1 s1) (Salted ha2 s2) = compare ha1 ha2 <> compare s1 s2 - compare (IteratedSalted ha1 s1 ic1) (IteratedSalted ha2 s2 ic2) = - compare ha1 ha2 <> compare s1 s2 <> compare ic1 ic2 - compare (Argon2 salt1 t1 p1 em1) (Argon2 salt2 t2 p2 em2) = - compare salt1 salt2 <> compare t1 t2 <> compare p1 p2 <> compare em1 em2 - compare (OtherS2K t1 bs1) (OtherS2K t2 bs2) = compare t1 t2 <> compare bs1 bs2 - compare Simple {} Salted {} = LT - compare Simple {} IteratedSalted {} = LT - compare Simple {} Argon2 {} = LT - compare Simple {} OtherS2K {} = LT - compare Salted {} Simple {} = GT - compare Salted {} IteratedSalted {} = LT - compare Salted {} Argon2 {} = LT - compare Salted {} OtherS2K {} = LT - compare IteratedSalted {} Simple {} = GT - compare IteratedSalted {} Salted {} = GT - compare IteratedSalted {} Argon2 {} = LT - compare IteratedSalted {} OtherS2K {} = LT - compare Argon2 {} Simple {} = GT - compare Argon2 {} Salted {} = GT - compare Argon2 {} IteratedSalted {} = GT - compare Argon2 {} OtherS2K {} = LT - compare OtherS2K {} _ = GT - -instance Pretty S2K where - pretty (Simple ha) = pretty "simple S2K," <+> pretty ha - pretty (Salted ha salt) = pretty "salted S2K," <+> pretty ha <+> pretty salt - pretty (IteratedSalted ha salt icount) = - pretty "iterated-salted S2K," <+> - pretty ha <+> pretty salt <+> pretty icount - pretty (Argon2 salt t p em) = - pretty "Argon2 S2K," <+> - pretty salt <+> pretty t <+> pretty p <+> pretty em - pretty (OtherS2K t bs) = - pretty "unknown S2K type" <+> pretty t <+> pretty (bsToHexUpper bs) - -instance A.ToJSON S2K where - toJSON (Simple ha) = A.toJSON ha - toJSON (Salted ha salt) = A.toJSON (ha, salt) - toJSON (IteratedSalted ha salt icount) = A.toJSON (ha, salt, icount) - toJSON (Argon2 salt t p em) = A.toJSON (salt, t, p, em) - toJSON (OtherS2K t bs) = A.toJSON (t, BL.unpack bs) - -data ImageFormat - = JPEG - | OtherImage Word8 - deriving (Data, Generic, Show, Typeable) - -instance Eq ImageFormat where - (==) a b = fromFVal a == fromFVal b - -instance Ord ImageFormat where - compare = comparing fromFVal - -instance FutureVal ImageFormat where - fromFVal JPEG = 1 - fromFVal (OtherImage o) = o - toFVal 1 = JPEG - toFVal o = OtherImage o - -instance Hashable ImageFormat - -instance Pretty ImageFormat where - pretty JPEG = pretty "JPEG" - pretty (OtherImage o) = pretty "unknown image format" <+> pretty o - -$(ATH.deriveJSON ATH.defaultOptions ''ImageFormat) - -newtype ImageHeader = - ImageHV1 ImageFormat - deriving (Data, Eq, Generic, Show, Typeable) - -instance Ord ImageHeader where - compare (ImageHV1 a) (ImageHV1 b) = compare a b - -instance Hashable ImageHeader - -instance Pretty ImageHeader where - pretty (ImageHV1 f) = pretty "imghdr v1" <+> pretty f - -$(ATH.deriveJSON ATH.defaultOptions ''ImageHeader) - -data UserAttrSubPacket - = ImageAttribute ImageHeader ImageData - | OtherUASub Word8 ByteString - deriving (Data, Eq, Generic, Show, Typeable) - -instance Hashable UserAttrSubPacket - -instance Ord UserAttrSubPacket where - compare (ImageAttribute h1 d1) (ImageAttribute h2 d2) = - compare h1 h2 <> compare d1 d2 - compare (ImageAttribute _ _) (OtherUASub _ _) = LT - compare (OtherUASub _ _) (ImageAttribute _ _) = GT - compare (OtherUASub t1 b1) (OtherUASub t2 b2) = compare t1 t2 <> compare b1 b2 - -instance Pretty UserAttrSubPacket where - pretty (ImageAttribute ih d) = - pretty "image-attribute" <+> pretty ih <+> pretty (BL.unpack d) - pretty (OtherUASub t bs) = - pretty "unknown attribute type" <> pretty t <+> pretty (BL.unpack bs) - -instance A.ToJSON UserAttrSubPacket where - toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack d) - toJSON (OtherUASub t bs) = A.toJSON (t, BL.unpack bs) - -data ECCCurve - = NISTP256 - | NISTP384 - | NISTP521 - | Curve25519 - | Curve448 - deriving (Data, Eq, Generic, Ord, Show, Typeable) - -instance Pretty ECCCurve where - pretty NISTP256 = pretty "NIST P-256" - pretty NISTP384 = pretty "NIST P-384" - pretty NISTP521 = pretty "NIST P-521" - pretty Curve25519 = pretty "Curve25519" - pretty Curve448 = pretty "Curve448" - -instance Hashable ECCCurve - --- Packet stream wrapper used to provide an EOF-delimited Binary instance. -newtype Block a = - Block - { unBlock :: [a] - } -- intentionally not encoded as a list length prefix - deriving (Show, Eq) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +module Codec.Encryption.OpenPGP.Types.Internal.Base + ( KeyVersion (..) + , IV (..) + , S2K (..) + , SymmetricAlgorithm (..) + , AEADAlgorithm (..) + , PubKeyAlgorithm (..) + , ThirtyTwoBitTimeStamp (..) + , ThirtyTwoBitDuration (..) + , Exportability + , TrustLevel + , TrustAmount + , AlmostPublicDomainRegex + , Revocability + , RevocationReason + , KeyServer + , SignatureHash + , PacketVersion + , V3Expiration + , CompressedDataPayload + , FileName + , ImageData + , NestedFlag + , HashAlgorithm (..) + , bsToHexUpper + , Hashed + , Unhashed + , V4Sig + , V6Sig + , ByteRange (..) + , WireRepSourceId (..) + , WireRepRef (..) + , WireRepRefs + , wireRepRef + , namedWireRepRef + , mkWireRepRefWithLength + , mkWireRepRef + , SignaturePayload (..) + , Fingerprint (..) + , SessionKey (..) + , SigType (..) + , SignatureSalt (..) + , Salt (..) + , Salt8 (..) + , Salt16 (..) + , CompressionAlgorithm (..) + , LiteralDataType (..) + , UserAttrSubPacket (..) + , EightOctetKeyId (..) + , MPI (..) + , SignaturePayloadVersion (..) + , SignaturePayloadV (..) + , SomeSignaturePayload (..) + , toSignaturePayload + , toSomeSignaturePayload + , signaturePayloadVersion + , asSignaturePayloadV3 + , asSignaturePayloadV4 + , asSignaturePayloadV6 + , asSignaturePayloadOther + , FutureVal (..) + , SigSubPacket (..) + , SigSubPacketPayload (..) + , ECCCurve (..) + , IssuerFingerprintVersion (..) + , IterationCount (..) + , salt8FromSalt + , salt16FromSalt + , saltFromSalt8 + , saltFromSalt16 + , Block (..) + , FutureFlag (..) + , ImageHeader (..) + , issuerFingerprintVersionToPacketVersion + , packetVersionToIssuerFingerprintVersion + , NotationName (..) + , NotationValue (..) + , URL (..) + , RevocationClass (..) + , SubpacketList (..) + , fromSubpacketList + , toSubpacketList + , emptyHashedSubpackets + , emptyUnhashedSubpackets + , consHashedSubpacket + , consUnhashedSubpacket + , spanByteRanges + , RevocationCode (..) + , KeyFlag (..) + , KeyIdentifier (..) + , FeatureFlag (..) + , NotationFlag (..) + , KSPFlag (..) + , mkRevocationClass + , mkNotationFlag + , SpacedFingerprint (..) + , ImageFormat (..) + ) where + +import Control.Applicative ((<|>)) +import Control.Arrow ((***)) +import Control.Lens (Wrapped, makeLenses, op) +import Control.Monad (mzero) +import Data.Aeson (object, (.=)) +import qualified Data.Aeson as A +import qualified Data.Aeson.Key as AK +import qualified Data.Aeson.TH as ATH +import Data.Bits ((.&.)) +import Data.ByteArray (ByteArrayAccess) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16.Lazy as B16L +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import Data.Char (toLower, toUpper) +import Data.Data (Data) +import Data.Hashable (Hashable (..)) +import Data.IORef (IORef, atomicModifyIORef', newIORef) +import Data.Int (Int64) +import Data.Kind (Type) +import Data.List (unfoldr) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import Data.List.Split (chunksOf) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Time.Format (formatTime) +import Data.Time.Locale.Compat (defaultTimeLocale) +import Data.Typeable (Typeable) +import Data.Word (Word16, Word32, Word8) +import GHC.Generics (Generic) +import Network.URI (URI (..), nullURI, parseURI, uriToString) +import Numeric (readHex) +import Prettyprinter (Pretty (..), hsep, punctuate, space, (<+>)) +import System.IO.Unsafe (unsafePerformIO) + +import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils + ( prettyLBS + ) + +type Exportability = Bool + +type TrustLevel = Word8 + +type TrustAmount = Word8 + +type AlmostPublicDomainRegex = ByteString + +type Revocability = Bool + +type RevocationReason = Text + +type KeyServer = ByteString + +type SignatureHash = ByteString + +type PacketVersion = Word8 + +type V3Expiration = Word16 + +type CompressedDataPayload = ByteString + +type FileName = ByteString + +type ImageData = ByteString + +type NestedFlag = Bool + +{- | Phantom types for tracking subpacket classification and signature version +These types are never instantiated; they exist purely for compile-time type safety. +-} + +-- | Phantom marker for hashed subpackets (included in signature hash computation) +data Hashed + +-- | Phantom marker for unhashed subpackets (not included in signature hash computation) +data Unhashed + +-- | Phantom marker for v4 signatures (8-octet issuer, no salt) +data V4Sig + +-- | Phantom marker for v6 signatures (fingerprint issuer, requires salt) +data V6Sig + +data ByteRange + = ByteRange + { _rangeOffset :: Int64 + , _rangeLength :: Int64 + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +newtype WireRepSourceId + = WireRepSourceId + { _unWireRepSourceId :: Int64 + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +data WireRepRef + = WireRepRef + { _wireRepSourceId :: WireRepSourceId + , _wireRepLength :: Int64 + , _wireRepName :: Maybe Text + , _wireRepWasOriginallyArmored :: Bool + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +type WireRepRefs = NonEmpty WireRepRef + +-- FIXME: these functions should be moved into a separate module +wireRepRef :: ByteString -> WireRepRef +wireRepRef = mkWireRepRefWithLength Nothing False . BL.length + +namedWireRepRef :: Text -> ByteString -> WireRepRef +namedWireRepRef name = mkWireRepRefWithLength (Just name) False . BL.length + +mkWireRepRefWithLength + :: Maybe Text -> Bool -> Int64 -> WireRepRef +mkWireRepRefWithLength mname wasOriginallyArmored payloadLen = + WireRepRef + { _wireRepSourceId = freshWireRepSourceId payloadLen + , _wireRepLength = payloadLen + , _wireRepName = mname + , _wireRepWasOriginallyArmored = wasOriginallyArmored + } + +mkWireRepRef :: Maybe Text -> Bool -> ByteString -> WireRepRef +mkWireRepRef mname wasOriginallyArmored = + mkWireRepRefWithLength mname wasOriginallyArmored . BL.length + +wireRepSourceCounter :: IORef Int64 +wireRepSourceCounter = unsafePerformIO (newIORef 0) +{-# NOINLINE wireRepSourceCounter #-} +freshWireRepSourceId :: Int64 -> WireRepSourceId +freshWireRepSourceId !_ = + unsafePerformIO $ + atomicModifyIORef' + wireRepSourceCounter + ( \n -> + let n' = n + 1 + in (n', WireRepSourceId n') + ) +{-# NOINLINE freshWireRepSourceId #-} +rangeEnd :: ByteRange -> Int64 +rangeEnd r = _rangeOffset r + _rangeLength r + +spanByteRanges :: [ByteRange] -> Maybe ByteRange +spanByteRanges [] = Nothing +spanByteRanges (r : rs) = + let start = minimum (_rangeOffset <$> (r : rs)) + ending = maximum (rangeEnd <$> (r : rs)) + in Just (ByteRange start (ending - start)) + +$(makeLenses ''ByteRange) + +$(makeLenses ''WireRepRef) + +class + (Eq a, Ord a) => + FutureFlag a + where + fromFFlag :: a -> Int + toFFlag :: Int -> a + +class + (Eq a, Ord a) => + FutureVal a + where + fromFVal :: a -> Word8 + toFVal :: Word8 -> a + +data SymmetricAlgorithm + = Plaintext + | IDEA + | TripleDES + | CAST5 + | Blowfish + | ReservedSAFER + | ReservedDES + | AES128 + | AES192 + | AES256 + | Twofish + | Camellia128 + | Camellia192 + | Camellia256 + | OtherSA Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq SymmetricAlgorithm where + (==) a b = fromFVal a == fromFVal b + +instance Ord SymmetricAlgorithm where + compare = comparing fromFVal + +instance FutureVal SymmetricAlgorithm where + fromFVal Plaintext = 0 + fromFVal IDEA = 1 + fromFVal TripleDES = 2 + fromFVal CAST5 = 3 + fromFVal Blowfish = 4 + fromFVal ReservedSAFER = 5 + fromFVal ReservedDES = 6 + fromFVal AES128 = 7 + fromFVal AES192 = 8 + fromFVal AES256 = 9 + fromFVal Twofish = 10 + fromFVal Camellia128 = 11 + fromFVal Camellia192 = 12 + fromFVal Camellia256 = 13 + fromFVal (OtherSA o) = o + toFVal 0 = Plaintext + toFVal 1 = IDEA + toFVal 2 = TripleDES + toFVal 3 = CAST5 + toFVal 4 = Blowfish + toFVal 5 = ReservedSAFER + toFVal 6 = ReservedDES + toFVal 7 = AES128 + toFVal 8 = AES192 + toFVal 9 = AES256 + toFVal 10 = Twofish + toFVal 11 = Camellia128 + toFVal 12 = Camellia192 + toFVal 13 = Camellia256 + toFVal o = OtherSA o + +instance Hashable SymmetricAlgorithm + +instance Pretty SymmetricAlgorithm where + pretty Plaintext = pretty "plaintext" + pretty IDEA = pretty "IDEA" + pretty TripleDES = pretty "3DES" + pretty CAST5 = pretty "CAST-128" + pretty Blowfish = pretty "Blowfish" + pretty ReservedSAFER = pretty "(reserved) SAFER" + pretty ReservedDES = pretty "(reserved) DES" + pretty AES128 = pretty "AES-128" + pretty AES192 = pretty "AES-192" + pretty AES256 = pretty "AES-256" + pretty Twofish = pretty "Twofish" + pretty Camellia128 = pretty "Camellia-128" + pretty Camellia192 = pretty "Camellia-192" + pretty Camellia256 = pretty "Camellia-256" + pretty (OtherSA sa) = pretty "unknown symmetric algorithm" <+> pretty sa + +$(ATH.deriveJSON ATH.defaultOptions ''SymmetricAlgorithm) + +data NotationFlag + = HumanReadable + | OtherNF Word8 + deriving (Data, Generic, Show, Typeable) + +mkNotationFlag :: Word8 -> NotationFlag +mkNotationFlag o + | o' == 0 = HumanReadable + | otherwise = OtherNF o' + where + o' = o .&. 0x0f + +instance Eq NotationFlag where + (==) a b = fromFFlag a == fromFFlag b + +instance Ord NotationFlag where + compare = comparing fromFFlag + +instance FutureFlag NotationFlag where + fromFFlag HumanReadable = 0 + fromFFlag (OtherNF o) = fromIntegral (o .&. 0x0f) + toFFlag 0 = HumanReadable + toFFlag o = mkNotationFlag (fromIntegral o) + +instance Hashable NotationFlag + +instance Pretty NotationFlag where + pretty HumanReadable = pretty "human-readable" + pretty (OtherNF o) = pretty "unknown notation flag type" <+> pretty o + +$(ATH.deriveJSON ATH.defaultOptions ''NotationFlag) + +newtype ThirtyTwoBitTimeStamp + = ThirtyTwoBitTimeStamp + { unThirtyTwoBitTimeStamp :: Word32 + } + deriving + ( Bounded + , Data + , Enum + , Eq + , Generic + , Hashable + , Integral + , Num + , Ord + , Real + , Show + , Typeable + ) + +instance Wrapped ThirtyTwoBitTimeStamp + +instance Pretty ThirtyTwoBitTimeStamp where + pretty = + pretty + . formatTime defaultTimeLocale "%Y%m%d-%H%M%S" + . posixSecondsToUTCTime + . realToFrac + +$(ATH.deriveJSON ATH.defaultOptions ''ThirtyTwoBitTimeStamp) + +durU :: (Integral a, Show a) => a -> Maybe (String, a) +durU x + | x >= 31557600 = + Just ((++ "y") . show $ x `div` 31557600, x `mod` 31557600) + | x >= 2629800 = + Just ((++ "m") . show $ x `div` 2629800, x `mod` 2629800) + | x >= 86400 = + Just ((++ "d") . show $ x `div` 86400, x `mod` 86400) + | x > 0 = Just ((++ "s") . show $ x, 0) + | otherwise = Nothing + +newtype ThirtyTwoBitDuration + = ThirtyTwoBitDuration + { unThirtyTwoBitDuration :: Word32 + } + deriving + ( Bounded + , Data + , Enum + , Eq + , Generic + , Hashable + , Integral + , Num + , Ord + , Real + , Show + , Typeable + ) + +instance Wrapped ThirtyTwoBitDuration + +instance Pretty ThirtyTwoBitDuration where + pretty = pretty . concat . unfoldr durU . op ThirtyTwoBitDuration + +$(ATH.deriveJSON ATH.defaultOptions ''ThirtyTwoBitDuration) + +data RevocationClass + = SensitiveRK + | RClOther Word8 + deriving (Data, Generic, Show, Typeable) + +mkRevocationClass :: Word8 -> RevocationClass +mkRevocationClass i + | i' == 1 = SensitiveRK + | otherwise = RClOther i' + where + i' = i .&. 0x07 + +instance Eq RevocationClass where + (==) a b = fromFFlag a == fromFFlag b + +instance Ord RevocationClass where + compare = comparing fromFFlag + +instance FutureFlag RevocationClass where + fromFFlag SensitiveRK = 1 + fromFFlag (RClOther i) = fromIntegral (i .&. 0x07) + toFFlag 1 = SensitiveRK + toFFlag i = mkRevocationClass (fromIntegral i) + +instance Hashable RevocationClass + +instance Pretty RevocationClass where + pretty SensitiveRK = pretty "sensitive" + pretty (RClOther o) = pretty "unknown revocation class" <+> pretty o + +$(ATH.deriveJSON ATH.defaultOptions ''RevocationClass) + +data PubKeyAlgorithm + = RSA + | DeprecatedRSAEncryptOnly + | DeprecatedRSASignOnly + | ElgamalEncryptOnly + | DSA + | ECDH + | ECDSA + | ForbiddenElgamal + | DH + | EdDSA + | X25519 + | X448 + | Ed25519 + | Ed448 + | MLDSA65Ed25519 -- ID 30: ML-DSA-65+Ed25519 + | MLDSA87Ed448 -- ID 31: ML-DSA-87+Ed448 + | SLHDSASHAKE128s -- ID 32: SLH-DSA-SHAKE-128s + | SLHDSASHAKE128f -- ID 33: SLH-DSA-SHAKE-128f + | SLHDSASHAKE256s -- ID 34: SLH-DSA-SHAKE-256s + | MLKEM768X25519 -- ID 35: ML-KEM-768+X25519 + | MLKEM1024X448 -- ID 36: ML-KEM-1024+X448 + | OtherPKA Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq PubKeyAlgorithm where + (==) a b = fromFVal a == fromFVal b + +instance Ord PubKeyAlgorithm where + compare = comparing fromFVal + +instance FutureVal PubKeyAlgorithm where + fromFVal RSA = 1 + fromFVal DeprecatedRSAEncryptOnly = 2 + fromFVal DeprecatedRSASignOnly = 3 + fromFVal ElgamalEncryptOnly = 16 + fromFVal DSA = 17 + fromFVal ECDH = 18 + fromFVal ECDSA = 19 + fromFVal ForbiddenElgamal = 20 + fromFVal DH = 21 + fromFVal EdDSA = 22 + fromFVal X25519 = 25 + fromFVal X448 = 26 + fromFVal Ed25519 = 27 + fromFVal Ed448 = 28 + fromFVal MLDSA65Ed25519 = 30 + fromFVal MLDSA87Ed448 = 31 + fromFVal SLHDSASHAKE128s = 32 + fromFVal SLHDSASHAKE128f = 33 + fromFVal SLHDSASHAKE256s = 34 + fromFVal MLKEM768X25519 = 35 + fromFVal MLKEM1024X448 = 36 + fromFVal (OtherPKA o) = o + toFVal 1 = RSA + toFVal 2 = DeprecatedRSAEncryptOnly + toFVal 3 = DeprecatedRSASignOnly + toFVal 16 = ElgamalEncryptOnly + toFVal 17 = DSA + toFVal 18 = ECDH + toFVal 19 = ECDSA + toFVal 20 = ForbiddenElgamal + toFVal 21 = DH + toFVal 22 = EdDSA + toFVal 25 = X25519 + toFVal 26 = X448 + toFVal 27 = Ed25519 + toFVal 28 = Ed448 + toFVal 30 = MLDSA65Ed25519 + toFVal 31 = MLDSA87Ed448 + toFVal 32 = SLHDSASHAKE128s + toFVal 33 = SLHDSASHAKE128f + toFVal 34 = SLHDSASHAKE256s + toFVal 35 = MLKEM768X25519 + toFVal 36 = MLKEM1024X448 + toFVal o = OtherPKA o + +instance Hashable PubKeyAlgorithm + +instance Pretty PubKeyAlgorithm where + pretty RSA = pretty "RSA" + pretty DeprecatedRSAEncryptOnly = pretty "(deprecated) RSA encrypt-only" + pretty DeprecatedRSASignOnly = pretty "(deprecated) RSA sign-only" + pretty ElgamalEncryptOnly = pretty "Elgamal encrypt-only" + pretty DSA = pretty "DSA" + pretty ECDH = pretty "ECDH" + pretty ECDSA = pretty "ECDSA" + pretty ForbiddenElgamal = pretty "(forbidden) Elgamal" + pretty DH = pretty "DH" + pretty EdDSA = pretty "EdDSA" + pretty X25519 = pretty "X25519" + pretty X448 = pretty "X448" + pretty Ed25519 = pretty "Ed25519" + pretty Ed448 = pretty "Ed448" + pretty MLDSA65Ed25519 = pretty "ML-DSA-65+Ed25519" + pretty MLDSA87Ed448 = pretty "ML-DSA-87+Ed448" + pretty SLHDSASHAKE128s = pretty "SLH-DSA-SHAKE-128s" + pretty SLHDSASHAKE128f = pretty "SLH-DSA-SHAKE-128f" + pretty SLHDSASHAKE256s = pretty "SLH-DSA-SHAKE-256s" + pretty MLKEM768X25519 = pretty "ML-KEM-768+X25519" + pretty MLKEM1024X448 = pretty "ML-KEM-1024+X448" + pretty (OtherPKA pka) = pretty "unknown pubkey algorithm type" <+> pretty pka + +$(ATH.deriveJSON ATH.defaultOptions ''PubKeyAlgorithm) + +{- | An OpenPGP fingerprint. Length depends on key version: +16 bytes (v3/MD5), 20 bytes (v4/SHA-1), or 32 bytes (v6/SHA-256). +-} +newtype Fingerprint + = Fingerprint + { unFingerprint :: ByteString + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Wrapped Fingerprint + +instance Read Fingerprint where + readsPrec _ s = + let ws = hexToW8s (filter (/= ' ') s) + in if null ws + then [] + else [(Fingerprint (BL.pack (map fst ws)), snd (last ws))] + +instance Hashable Fingerprint + +instance Pretty Fingerprint where + pretty = pretty . bsToHexUpper . unFingerprint + +instance A.ToJSON Fingerprint where + toJSON e = object [AK.fromString "fpr" .= (A.toJSON . show . pretty) e] + +instance A.FromJSON Fingerprint where + parseJSON (A.Object v) = Fingerprint . read <$> v A..: AK.fromString "fpr" + parseJSON _ = mzero + +newtype SpacedFingerprint + = SpacedFingerprint + { unSpacedFingerprint :: Fingerprint + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Wrapped SpacedFingerprint + +instance Pretty SpacedFingerprint where + pretty = + hsep + . punctuate space + . map hsep + . chunksOf 5 + . map pretty + . chunksOf 4 + . bsToHexUpper + . unFingerprint + . op SpacedFingerprint + +bsToHexUpper :: ByteString -> String +bsToHexUpper = map toUpper . BLC8.unpack . B16L.encode + +hexToW8s :: ReadS Word8 +hexToW8s = concatMap readHex . chunksOf 2 . map toLower + +newtype EightOctetKeyId + = EightOctetKeyId + { unEOKI :: ByteString + } + deriving (Data, Eq, Generic, Ord, Typeable) + +instance Wrapped EightOctetKeyId + +instance Pretty EightOctetKeyId where + pretty = pretty . bsToHexUpper . op EightOctetKeyId + +instance Show EightOctetKeyId where + show = bsToHexUpper . op EightOctetKeyId + +instance Read EightOctetKeyId where + readsPrec _ = + map ((EightOctetKeyId . BL.pack *** concat) . unzip) + . chunksOf 8 + . hexToW8s + +instance Hashable EightOctetKeyId + +instance A.ToJSON EightOctetKeyId where + toJSON e = + object + [AK.fromString "eoki" .= (bsToHexUpper . op EightOctetKeyId) e] + +instance A.FromJSON EightOctetKeyId where + parseJSON (A.Object v) = + EightOctetKeyId . read <$> v A..: AK.fromString "eoki" + parseJSON _ = mzero + +data KeyIdentifier + = KeyIdentifierWildcard + | KeyIdentifierEightOctet EightOctetKeyId + | KeyIdentifierFingerprint Fingerprint + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Pretty KeyIdentifier where + pretty KeyIdentifierWildcard = pretty "wildcard" + pretty (KeyIdentifierEightOctet kid) = pretty "key-id" <+> pretty kid + pretty (KeyIdentifierFingerprint fp) = pretty "fingerprint" <+> pretty fp + +instance A.ToJSON KeyIdentifier where + toJSON KeyIdentifierWildcard = + object [AK.fromString "wildcard" .= A.Bool True] + toJSON (KeyIdentifierEightOctet kid) = object [AK.fromString "keyId" .= kid] + toJSON (KeyIdentifierFingerprint fp) = + object [AK.fromString "fingerprint" .= fp] + +instance A.FromJSON KeyIdentifier where + parseJSON (A.Object v) = + ( (v A..: AK.fromString "wildcard") >>= \isWildcard -> + if isWildcard + then pure KeyIdentifierWildcard + else mzero + ) + <|> (KeyIdentifierEightOctet <$> v A..: AK.fromString "keyId") + <|> (KeyIdentifierFingerprint <$> v A..: AK.fromString "fingerprint") + parseJSON _ = mzero + +newtype NotationName + = NotationName + { unNotationName :: ByteString + } + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +instance Pretty NotationName where + pretty = prettyLBS . unNotationName + +instance Wrapped NotationName + +instance A.ToJSON NotationName where + toJSON nn = + object + [AK.fromString "notationname" .= show (op NotationName nn)] + +instance A.FromJSON NotationName where + parseJSON (A.Object v) = + NotationName . read <$> v A..: AK.fromString "notationname" + parseJSON _ = mzero + +newtype NotationValue + = NotationValue + { unNotationValue :: ByteString + } + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + +instance Pretty NotationValue where + pretty = prettyLBS . unNotationValue + +instance Wrapped NotationValue + +instance A.ToJSON NotationValue where + toJSON nv = + object + [AK.fromString "notationvalue" .= show (op NotationValue nv)] + +instance A.FromJSON NotationValue where + parseJSON (A.Object v) = + NotationValue . read <$> v A..: AK.fromString "notationvalue" + parseJSON _ = mzero + +data HashAlgorithm + = DeprecatedMD5 + | SHA1 + | RIPEMD160 + | SHA256 + | SHA384 + | SHA512 + | SHA224 + | SHA3_256 + | SHA3_512 + | OtherHA Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq HashAlgorithm where + (==) a b = fromFVal a == fromFVal b + +instance Ord HashAlgorithm where + compare = comparing fromFVal + +instance FutureVal HashAlgorithm where + fromFVal DeprecatedMD5 = 1 + fromFVal SHA1 = 2 + fromFVal RIPEMD160 = 3 + fromFVal SHA256 = 8 + fromFVal SHA384 = 9 + fromFVal SHA512 = 10 + fromFVal SHA224 = 11 + fromFVal SHA3_256 = 12 + fromFVal SHA3_512 = 14 + fromFVal (OtherHA o) = o + toFVal 1 = DeprecatedMD5 + toFVal 2 = SHA1 + toFVal 3 = RIPEMD160 + toFVal 8 = SHA256 + toFVal 9 = SHA384 + toFVal 10 = SHA512 + toFVal 11 = SHA224 + toFVal 12 = SHA3_256 + toFVal 14 = SHA3_512 + toFVal o = OtherHA o + +instance Hashable HashAlgorithm + +instance Pretty HashAlgorithm where + pretty DeprecatedMD5 = pretty "(deprecated) MD5" + pretty SHA1 = pretty "SHA-1" + pretty RIPEMD160 = pretty "RIPEMD-160" + pretty SHA256 = pretty "SHA-256" + pretty SHA384 = pretty "SHA-384" + pretty SHA512 = pretty "SHA-512" + pretty SHA224 = pretty "SHA-224" + pretty SHA3_256 = pretty "SHA3-256" + pretty SHA3_512 = pretty "SHA3-512" + pretty (OtherHA ha) = pretty "unknown hash algorithm type" <+> pretty ha + +$(ATH.deriveJSON ATH.defaultOptions ''HashAlgorithm) + +data CompressionAlgorithm + = Uncompressed + | ZIP + | ZLIB + | BZip2 + | OtherCA Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq CompressionAlgorithm where + (==) a b = fromFVal a == fromFVal b + +instance Ord CompressionAlgorithm where + compare = comparing fromFVal + +instance FutureVal CompressionAlgorithm where + fromFVal Uncompressed = 0 + fromFVal ZIP = 1 + fromFVal ZLIB = 2 + fromFVal BZip2 = 3 + fromFVal (OtherCA o) = o + toFVal 0 = Uncompressed + toFVal 1 = ZIP + toFVal 2 = ZLIB + toFVal 3 = BZip2 + toFVal o = OtherCA o + +instance Hashable CompressionAlgorithm + +instance Pretty CompressionAlgorithm where + pretty Uncompressed = pretty "uncompressed" + pretty ZIP = pretty "ZIP" + pretty ZLIB = pretty "zlib" + pretty BZip2 = pretty "bzip2" + pretty (OtherCA ca) = + pretty "unknown compression algorithm type" <+> pretty ca + +$(ATH.deriveJSON ATH.defaultOptions ''CompressionAlgorithm) + +data AEADAlgorithm + = EAX + | OCB + | GCM + | OtherAEADAlgo Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq AEADAlgorithm where + (==) a b = fromFVal a == fromFVal b + +instance Ord AEADAlgorithm where + compare = comparing fromFVal + +instance FutureVal AEADAlgorithm where + fromFVal EAX = 1 + fromFVal OCB = 2 + fromFVal GCM = 3 + fromFVal (OtherAEADAlgo o) = o + toFVal 1 = EAX + toFVal 2 = OCB + toFVal 3 = GCM + toFVal o = OtherAEADAlgo o + +instance Hashable AEADAlgorithm + +instance Pretty AEADAlgorithm where + pretty EAX = pretty "EAX" + pretty OCB = pretty "OCB" + pretty GCM = pretty "GCM" + pretty (OtherAEADAlgo aa) = pretty "unknown AEAD algorithm type" <+> pretty aa + +$(ATH.deriveJSON ATH.defaultOptions ''AEADAlgorithm) + +data KSPFlag + = NoModify + | KSPOther Int + deriving (Data, Generic, Show, Typeable) + +instance Eq KSPFlag where + (==) a b = fromFFlag a == fromFFlag b + +instance Ord KSPFlag where + compare = comparing fromFFlag + +instance FutureFlag KSPFlag where + fromFFlag NoModify = 0 + fromFFlag (KSPOther i) = fromIntegral i + toFFlag 0 = NoModify + toFFlag i = KSPOther (fromIntegral i) + +instance Hashable KSPFlag + +instance Pretty KSPFlag where + pretty NoModify = pretty "no-modify" + pretty (KSPOther o) = + pretty "unknown keyserver preference flag type" <+> pretty o + +$(ATH.deriveJSON ATH.defaultOptions ''KSPFlag) + +data KeyFlag + = GroupKey + | AuthKey + | SplitKey + | EncryptStorageKey + | EncryptCommunicationsKey + | SignDataKey + | CertifyKeysKey + | KFOther Int + deriving (Data, Generic, Show, Typeable) + +instance Eq KeyFlag where + (==) a b = fromFFlag a == fromFFlag b + +instance Ord KeyFlag where + compare = comparing fromFFlag + +instance FutureFlag KeyFlag where + fromFFlag GroupKey = 0 + fromFFlag AuthKey = 2 + fromFFlag SplitKey = 3 + fromFFlag EncryptStorageKey = 4 + fromFFlag EncryptCommunicationsKey = 5 + fromFFlag SignDataKey = 6 + fromFFlag CertifyKeysKey = 7 + fromFFlag (KFOther i) = fromIntegral i + toFFlag 0 = GroupKey + toFFlag 2 = AuthKey + toFFlag 3 = SplitKey + toFFlag 4 = EncryptStorageKey + toFFlag 5 = EncryptCommunicationsKey + toFFlag 6 = SignDataKey + toFFlag 7 = CertifyKeysKey + toFFlag i = KFOther (fromIntegral i) + +instance Hashable KeyFlag + +instance Pretty KeyFlag where + pretty GroupKey = pretty "group" + pretty AuthKey = pretty "auth" + pretty SplitKey = pretty "split" + pretty EncryptStorageKey = pretty "encrypt-storage" + pretty EncryptCommunicationsKey = pretty "encrypt-communications" + pretty SignDataKey = pretty "sign-data" + pretty CertifyKeysKey = pretty "certify-keys" + pretty (KFOther o) = pretty "unknown key flag type" <+> pretty o + +$(ATH.deriveJSON ATH.defaultOptions ''KeyFlag) + +data RevocationCode + = NoReason + | KeySuperseded + | KeyMaterialCompromised + | KeyRetiredAndNoLongerUsed + | UserIdInfoNoLongerValid + | RCoOther Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq RevocationCode where + (==) a b = fromFVal a == fromFVal b + +instance Ord RevocationCode where + compare = comparing fromFVal + +instance FutureVal RevocationCode where + fromFVal NoReason = 0 + fromFVal KeySuperseded = 1 + fromFVal KeyMaterialCompromised = 2 + fromFVal KeyRetiredAndNoLongerUsed = 3 + fromFVal UserIdInfoNoLongerValid = 32 + fromFVal (RCoOther o) = o + toFVal 0 = NoReason + toFVal 1 = KeySuperseded + toFVal 2 = KeyMaterialCompromised + toFVal 3 = KeyRetiredAndNoLongerUsed + toFVal 32 = UserIdInfoNoLongerValid + toFVal o = RCoOther o + +instance Hashable RevocationCode + +instance Pretty RevocationCode where + pretty NoReason = pretty "no reason" + pretty KeySuperseded = pretty "key superseded" + pretty KeyMaterialCompromised = pretty "key material compromised" + pretty KeyRetiredAndNoLongerUsed = pretty "key retired and no longer used" + pretty UserIdInfoNoLongerValid = pretty "user-ID info no longer valid" + pretty (RCoOther o) = pretty "unknown revocation code" <+> pretty o + +$(ATH.deriveJSON ATH.defaultOptions ''RevocationCode) + +data FeatureFlag + = FeatureSEIPDv1 + | FeatureSEIPDv2 + | FeatureOther Int + deriving (Data, Generic, Show, Typeable) + +instance Eq FeatureFlag where + (==) a b = fromFFlag a == fromFFlag b + +instance Ord FeatureFlag where + compare = comparing fromFFlag + +instance FutureFlag FeatureFlag where + fromFFlag FeatureSEIPDv1 = 7 + fromFFlag FeatureSEIPDv2 = 4 + fromFFlag (FeatureOther i) = fromIntegral i + toFFlag 7 = FeatureSEIPDv1 + toFFlag 4 = FeatureSEIPDv2 + toFFlag i = FeatureOther (fromIntegral i) + +instance Hashable FeatureFlag + +instance Pretty FeatureFlag where + pretty FeatureSEIPDv1 = pretty "seipd-v1" + pretty FeatureSEIPDv2 = pretty "seipd-v2" + pretty (FeatureOther o) = pretty "unknown feature flag type" <+> pretty o + +$(ATH.deriveJSON ATH.defaultOptions ''FeatureFlag) + +newtype URL + = URL + { unURL :: URI + } + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Wrapped URL + +instance Hashable URL where + hashWithSalt salt (URL (URI s a p q f)) = + salt + `hashWithSalt` s + `hashWithSalt` show a + `hashWithSalt` p + `hashWithSalt` q + `hashWithSalt` f + +instance Pretty URL where + pretty = pretty . (\uri -> uriToString id uri "") . op URL + +instance A.ToJSON URL where + toJSON u = + object + [ AK.fromString "uri" .= (\uri -> uriToString id uri "") (op URL u) + ] + +instance A.FromJSON URL where + parseJSON (A.Object v) = + URL . fromMaybe nullURI . parseURI <$> v A..: AK.fromString "uri" + parseJSON _ = mzero + +data SigType + = BinarySig + | CanonicalTextSig + | StandaloneSig + | GenericCert + | PersonaCert + | CasualCert + | PositiveCert + | SubkeyBindingSig + | PrimaryKeyBindingSig + | SignatureDirectlyOnAKey + | KeyRevocationSig + | SubkeyRevocationSig + | CertRevocationSig + | TimestampSig + | ThirdPartyConfirmationSig + | OtherSig Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq SigType where + (==) a b = fromFVal a == fromFVal b + +instance Ord SigType where + compare = comparing fromFVal + +instance FutureVal SigType where + fromFVal BinarySig = 0x00 + fromFVal CanonicalTextSig = 0x01 + fromFVal StandaloneSig = 0x02 + fromFVal GenericCert = 0x10 + fromFVal PersonaCert = 0x11 + fromFVal CasualCert = 0x12 + fromFVal PositiveCert = 0x13 + fromFVal SubkeyBindingSig = 0x18 + fromFVal PrimaryKeyBindingSig = 0x19 + fromFVal SignatureDirectlyOnAKey = 0x1F + fromFVal KeyRevocationSig = 0x20 + fromFVal SubkeyRevocationSig = 0x28 + fromFVal CertRevocationSig = 0x30 + fromFVal TimestampSig = 0x40 + fromFVal ThirdPartyConfirmationSig = 0x50 + fromFVal (OtherSig o) = o + toFVal 0x00 = BinarySig + toFVal 0x01 = CanonicalTextSig + toFVal 0x02 = StandaloneSig + toFVal 0x10 = GenericCert + toFVal 0x11 = PersonaCert + toFVal 0x12 = CasualCert + toFVal 0x13 = PositiveCert + toFVal 0x18 = SubkeyBindingSig + toFVal 0x19 = PrimaryKeyBindingSig + toFVal 0x1F = SignatureDirectlyOnAKey + toFVal 0x20 = KeyRevocationSig + toFVal 0x28 = SubkeyRevocationSig + toFVal 0x30 = CertRevocationSig + toFVal 0x40 = TimestampSig + toFVal 0x50 = ThirdPartyConfirmationSig + toFVal o = OtherSig o + +instance Hashable SigType + +instance Pretty SigType where + pretty BinarySig = pretty "binary" + pretty CanonicalTextSig = pretty "canonical-pretty" + pretty StandaloneSig = pretty "standalone" + pretty GenericCert = pretty "generic" + pretty PersonaCert = pretty "persona" + pretty CasualCert = pretty "casual" + pretty PositiveCert = pretty "positive" + pretty SubkeyBindingSig = pretty "subkey-binding" + pretty PrimaryKeyBindingSig = pretty "primary-key-binding" + pretty SignatureDirectlyOnAKey = pretty "signature directly on a key" + pretty KeyRevocationSig = pretty "key-revocation" + pretty SubkeyRevocationSig = pretty "subkey-revocation" + pretty CertRevocationSig = pretty "cert-revocation" + pretty TimestampSig = pretty "timestamp" + pretty ThirdPartyConfirmationSig = pretty "third-party-confirmation" + pretty (OtherSig o) = pretty "unknown signature type" <+> pretty o + +$(ATH.deriveJSON ATH.defaultOptions ''SigType) + +newtype MPI + = MPI + { unMPI :: Integer + } + deriving (Data, Eq, Generic, Show, Typeable) + +instance Wrapped MPI + +instance Ord MPI where + compare (MPI a) (MPI b) = compare a b + +instance Hashable MPI + +instance Pretty MPI where + pretty = pretty . op MPI + +$(ATH.deriveJSON ATH.defaultOptions ''MPI) + +newtype SignatureSalt + = SignatureSalt + { unSignatureSalt :: ByteString + } + deriving (Data, Eq, Generic, Show, Typeable) + +instance Ord SignatureSalt where + compare (SignatureSalt a) (SignatureSalt b) = compare a b + +instance Hashable SignatureSalt + +instance Pretty SignatureSalt where + pretty (SignatureSalt bs) = prettyLBS bs + +instance A.ToJSON SignatureSalt where + toJSON (SignatureSalt bs) = A.toJSON (BL.unpack bs) + +data SignaturePayloadVersion + = SigPayloadV3 + | SigPayloadV4 + | SigPayloadV6 + | SigPayloadVOther + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Hashable SignaturePayloadVersion + +data SignaturePayloadV (v :: SignaturePayloadVersion) where + SigPayloadV3Data + :: SigType + -> ThirtyTwoBitTimeStamp + -> EightOctetKeyId + -> PubKeyAlgorithm + -> HashAlgorithm + -> Word16 + -> NonEmpty MPI + -> SignaturePayloadV 'SigPayloadV3 + SigPayloadV4Data + :: SigType + -> PubKeyAlgorithm + -> HashAlgorithm + -> [SigSubPacket] + -> [SigSubPacket] + -> Word16 + -> NonEmpty MPI + -> SignaturePayloadV 'SigPayloadV4 + SigPayloadV6Data + :: SigType + -> PubKeyAlgorithm + -> HashAlgorithm + -> SignatureSalt + -> [SigSubPacket] + -> [SigSubPacket] + -> Word16 + -> NonEmpty MPI + -> SignaturePayloadV 'SigPayloadV6 + SigPayloadOtherData + :: Word8 -> ByteString -> SignaturePayloadV 'SigPayloadVOther + +deriving instance Eq (SignaturePayloadV v) + +deriving instance Show (SignaturePayloadV v) + +data SomeSignaturePayload where + SomeSignaturePayload + :: SignaturePayloadV v -> SomeSignaturePayload + +-- FIXME: these functions belong in a separate module +toSignaturePayload :: SignaturePayloadV v -> SignaturePayload +toSignaturePayload (SigPayloadV3Data st ts eoki pka ha w16 mpis) = + SigV3 st ts eoki pka ha w16 mpis +toSignaturePayload (SigPayloadV4Data st pka ha hsps usps w16 mpis) = + SigV4 st pka ha hsps usps w16 mpis +toSignaturePayload (SigPayloadV6Data st pka ha salt hsps usps w16 mpis) = + SigV6 st pka ha salt hsps usps w16 mpis +toSignaturePayload (SigPayloadOtherData v bs) = SigVOther v bs + +toSomeSignaturePayload + :: SignaturePayload -> SomeSignaturePayload +toSomeSignaturePayload (SigV3 st ts eoki pka ha w16 mpis) = + SomeSignaturePayload + (SigPayloadV3Data st ts eoki pka ha w16 mpis) +toSomeSignaturePayload (SigV4 st pka ha hsps usps w16 mpis) = + SomeSignaturePayload + (SigPayloadV4Data st pka ha hsps usps w16 mpis) +toSomeSignaturePayload (SigV6 st pka ha salt hsps usps w16 mpis) = + SomeSignaturePayload + (SigPayloadV6Data st pka ha salt hsps usps w16 mpis) +toSomeSignaturePayload (SigVOther v bs) = + SomeSignaturePayload (SigPayloadOtherData v bs) + +signaturePayloadVersion + :: SignaturePayload -> SignaturePayloadVersion +signaturePayloadVersion (SigV3 _ _ _ _ _ _ _) = SigPayloadV3 +signaturePayloadVersion (SigV4 _ _ _ _ _ _ _) = SigPayloadV4 +signaturePayloadVersion (SigV6 _ _ _ _ _ _ _ _) = SigPayloadV6 +signaturePayloadVersion (SigVOther _ _) = SigPayloadVOther + +asSignaturePayloadV3 + :: SignaturePayload + -> Either String (SignaturePayloadV 'SigPayloadV3) +asSignaturePayloadV3 (SigV3 st ts eoki pka ha w16 mpis) = + Right (SigPayloadV3Data st ts eoki pka ha w16 mpis) +asSignaturePayloadV3 _ = + Left + "Cannot coerce non-v3 SignaturePayload to SignaturePayloadV3" + +asSignaturePayloadV4 + :: SignaturePayload + -> Either String (SignaturePayloadV 'SigPayloadV4) +asSignaturePayloadV4 (SigV4 st pka ha hsps usps w16 mpis) = + Right (SigPayloadV4Data st pka ha hsps usps w16 mpis) +asSignaturePayloadV4 _ = + Left + "Cannot coerce non-v4 SignaturePayload to SignaturePayloadV4" + +asSignaturePayloadV6 + :: SignaturePayload + -> Either String (SignaturePayloadV 'SigPayloadV6) +asSignaturePayloadV6 (SigV6 st pka ha salt hsps usps w16 mpis) = + Right (SigPayloadV6Data st pka ha salt hsps usps w16 mpis) +asSignaturePayloadV6 _ = + Left + "Cannot coerce non-v6 SignaturePayload to SignaturePayloadV6" + +asSignaturePayloadOther + :: SignaturePayload + -> Either String (SignaturePayloadV 'SigPayloadVOther) +asSignaturePayloadOther (SigVOther v bs) = Right (SigPayloadOtherData v bs) +asSignaturePayloadOther _ = + Left + "Cannot coerce known-version SignaturePayload to SignaturePayloadVOther" + +data SignaturePayload + = SigV3 + SigType + ThirtyTwoBitTimeStamp + EightOctetKeyId + PubKeyAlgorithm + HashAlgorithm + Word16 + (NonEmpty MPI) + | SigV4 + SigType + PubKeyAlgorithm + HashAlgorithm + [SigSubPacket] + [SigSubPacket] + Word16 + (NonEmpty MPI) + | SigV6 + SigType + PubKeyAlgorithm + HashAlgorithm + SignatureSalt + [SigSubPacket] + [SigSubPacket] + Word16 + (NonEmpty MPI) + | SigVOther Word8 ByteString + deriving (Data, Eq, Generic, Show, Typeable) + +instance Hashable SignaturePayload + +instance Ord SignaturePayload where + compare (SigV3 st1 ts1 eoki1 pka1 ha1 w161 mpis1) (SigV3 st2 ts2 eoki2 pka2 ha2 w162 mpis2) = + compare st1 st2 + <> compare ts1 ts2 + <> compare eoki1 eoki2 + <> compare pka1 pka2 + <> compare ha1 ha2 + <> compare w161 w162 + <> compare (NE.toList mpis1) (NE.toList mpis2) + compare (SigV4 st1 pka1 ha1 hsp1 usp1 w161 mpis1) (SigV4 st2 pka2 ha2 hsp2 usp2 w162 mpis2) = + compare st1 st2 + <> compare pka1 pka2 + <> compare ha1 ha2 + <> compare hsp1 hsp2 + <> compare usp1 usp2 + <> compare w161 w162 + <> compare (NE.toList mpis1) (NE.toList mpis2) + compare (SigV6 st1 pka1 ha1 salt1 hsp1 usp1 w161 mpis1) (SigV6 st2 pka2 ha2 salt2 hsp2 usp2 w162 mpis2) = + compare st1 st2 + <> compare pka1 pka2 + <> compare ha1 ha2 + <> compare salt1 salt2 + <> compare hsp1 hsp2 + <> compare usp1 usp2 + <> compare w161 w162 + <> compare (NE.toList mpis1) (NE.toList mpis2) + compare (SigVOther t1 bs1) (SigVOther t2 bs2) = + compare t1 t2 <> compare bs1 bs2 + compare SigV3 {} SigV4 {} = LT + compare SigV3 {} SigV6 {} = LT + compare SigV3 {} SigVOther {} = LT + compare SigV4 {} SigV3 {} = GT + compare SigV4 {} SigV6 {} = LT + compare SigV4 {} SigVOther {} = LT + compare SigV6 {} SigV3 {} = GT + compare SigV6 {} SigV4 {} = GT + compare SigV6 {} SigVOther {} = LT + compare SigVOther {} SigV3 {} = GT + compare SigVOther {} SigV4 {} = GT + compare SigVOther {} SigV6 {} = GT + +instance Pretty SignaturePayload where + pretty (SigV3 st ts eoki pka ha w16 mpis) = + pretty "signature v3" + <> pretty ':' + <+> pretty st + <+> pretty ts + <+> pretty eoki + <+> pretty pka + <+> pretty ha + <+> pretty w16 + <+> (pretty . NE.toList) mpis + pretty (SigV4 st pka ha hsps usps w16 mpis) = + pretty "signature v4" + <> pretty ':' + <+> pretty st + <+> pretty pka + <+> pretty ha + <+> pretty hsps + <+> pretty usps + <+> pretty w16 + <+> (pretty . NE.toList) mpis + pretty (SigV6 st pka ha salt hsps usps w16 mpis) = + pretty "signature v6" + <> pretty ':' + <+> pretty st + <+> pretty pka + <+> pretty ha + <+> pretty salt + <+> pretty hsps + <+> pretty usps + <+> pretty w16 + <+> (pretty . NE.toList) mpis + pretty (SigVOther t bs) = + pretty "unknown signature v" + <> pretty t + <> pretty ':' + <+> pretty (BL.unpack bs) + +instance A.ToJSON SignaturePayload where + toJSON (SigV3 st ts eoki pka ha w16 mpis) = + A.toJSON (st, ts, eoki, pka, ha, w16, NE.toList mpis) + toJSON (SigV4 st pka ha hsps usps w16 mpis) = + A.toJSON (st, pka, ha, hsps, usps, w16, NE.toList mpis) + toJSON (SigV6 st pka ha salt hsps usps w16 mpis) = + A.toJSON (st, pka, ha, salt, hsps, usps, w16, NE.toList mpis) + toJSON (SigVOther t bs) = A.toJSON (t, BL.unpack bs) + +data IssuerFingerprintVersion + = IssuerFingerprintV4 + | IssuerFingerprintV6 + deriving (Data, Eq, Generic, Show, Typeable) + +instance Ord IssuerFingerprintVersion where + IssuerFingerprintV4 `compare` IssuerFingerprintV4 = EQ + IssuerFingerprintV4 `compare` IssuerFingerprintV6 = LT + IssuerFingerprintV6 `compare` IssuerFingerprintV4 = GT + IssuerFingerprintV6 `compare` IssuerFingerprintV6 = EQ + +instance Hashable IssuerFingerprintVersion + +instance Pretty IssuerFingerprintVersion where + pretty IssuerFingerprintV4 = pretty "4" + pretty IssuerFingerprintV6 = pretty "6" + +instance A.ToJSON IssuerFingerprintVersion where + toJSON IssuerFingerprintV4 = A.toJSON (4 :: Word8) + toJSON IssuerFingerprintV6 = A.toJSON (6 :: Word8) + +instance A.FromJSON IssuerFingerprintVersion where + parseJSON (A.Number n) = + case round n of + 4 -> pure IssuerFingerprintV4 + 6 -> pure IssuerFingerprintV6 + _ -> mzero + parseJSON _ = mzero + +-- FIXME: these functions should be in a separate module +issuerFingerprintVersionToPacketVersion + :: IssuerFingerprintVersion -> PacketVersion +issuerFingerprintVersionToPacketVersion IssuerFingerprintV4 = 4 +issuerFingerprintVersionToPacketVersion IssuerFingerprintV6 = 6 + +packetVersionToIssuerFingerprintVersion + :: PacketVersion -> Maybe IssuerFingerprintVersion +packetVersionToIssuerFingerprintVersion 4 = Just IssuerFingerprintV4 +packetVersionToIssuerFingerprintVersion 6 = Just IssuerFingerprintV6 +packetVersionToIssuerFingerprintVersion _ = Nothing + +data SigSubPacketPayload + = SigCreationTime ThirtyTwoBitTimeStamp + | SigExpirationTime ThirtyTwoBitDuration + | ExportableCertification Exportability + | TrustSignature TrustLevel TrustAmount + | RegularExpression AlmostPublicDomainRegex + | Revocable Revocability + | KeyExpirationTime ThirtyTwoBitDuration + | PreferredSymmetricAlgorithms [SymmetricAlgorithm] + | RevocationKey (Set RevocationClass) PubKeyAlgorithm Fingerprint + | Issuer EightOctetKeyId + | NotationData (Set NotationFlag) NotationName NotationValue + | PreferredHashAlgorithms [HashAlgorithm] + | PreferredCompressionAlgorithms [CompressionAlgorithm] + | KeyServerPreferences (Set KSPFlag) + | PreferredKeyServer KeyServer + | PrimaryUserId Bool + | PolicyURL URL + | KeyFlags (Set KeyFlag) + | SignersUserId Text + | ReasonForRevocation RevocationCode RevocationReason + | Features (Set FeatureFlag) + | SignatureTarget PubKeyAlgorithm HashAlgorithm SignatureHash + | EmbeddedSignature SignaturePayload + | IssuerFingerprint IssuerFingerprintVersion Fingerprint + | IntendedRecipient IssuerFingerprintVersion Fingerprint + | PreferredAEADCiphersuites [(SymmetricAlgorithm, AEADAlgorithm)] + | UserDefinedSigSub Word8 ByteString + | OtherSigSub Word8 ByteString + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Hashable SigSubPacketPayload + +instance Pretty SigSubPacketPayload where + pretty (SigCreationTime ts) = pretty "creation-time" <+> pretty ts + pretty (SigExpirationTime d) = pretty "sig expiration time" <+> pretty d + pretty (ExportableCertification e) = + pretty "exportable certification" <+> pretty e + pretty (TrustSignature tl ta) = + pretty "trust signature" <+> pretty tl <+> pretty ta + pretty (RegularExpression apdre) = + pretty "regular expression" <+> prettyLBS apdre + pretty (Revocable r) = pretty "revocable" <+> pretty r + pretty (KeyExpirationTime d) = pretty "key expiration time" <+> pretty d + pretty (PreferredSymmetricAlgorithms sas) = + pretty "preferred symmetric algorithms" <+> pretty sas + pretty (IntendedRecipient kv fp) = + pretty "intended recipient (v" + <> pretty kv + <> pretty ")" + <+> pretty fp + pretty (RevocationKey rcs pka tof) = + pretty "revocation key" + <+> pretty (Set.toList rcs) + <+> pretty pka + <+> pretty tof + pretty (Issuer eoki) = pretty "issuer" <+> pretty eoki + pretty (NotationData nfs nn nv) = + pretty "notation data" + <+> pretty (Set.toList nfs) + <+> pretty nn + <+> pretty nv + pretty (PreferredHashAlgorithms phas) = + pretty "preferred hash algorithms" <+> pretty phas + pretty (PreferredCompressionAlgorithms pcas) = + pretty "preferred compression algorithms" <+> pretty pcas + pretty (KeyServerPreferences kspfs) = + pretty "keyserver preferences" <+> pretty (Set.toList kspfs) + pretty (PreferredKeyServer ks) = pretty "preferred keyserver" <+> prettyLBS ks + pretty (PrimaryUserId p) = + ( if p + then mempty + else pretty "NOT " + ) + <> pretty "primary user-ID" + pretty (PolicyURL u) = pretty "policy URL" <+> pretty u + pretty (KeyFlags kfs) = pretty "key flags" <+> pretty (Set.toList kfs) + pretty (SignersUserId u) = pretty "signer's user-ID" <+> pretty u + pretty (ReasonForRevocation rc rr) = + pretty "reason for revocation" <+> pretty rc <+> pretty rr + pretty (Features ffs) = pretty "features" <+> pretty (Set.toList ffs) + pretty (SignatureTarget pka ha sh) = + pretty "signature target" + <+> pretty pka + <+> pretty ha + <+> prettyLBS sh + pretty (EmbeddedSignature sp) = pretty "embedded signature" <+> pretty sp + pretty (IssuerFingerprint kv ifp) = + pretty "issuer fingerprint (v" + <> pretty kv + <> pretty ")" + <+> pretty ifp + pretty (PreferredAEADCiphersuites ps) = + pretty "preferred AEAD ciphersuites" + <+> pretty ps + pretty (UserDefinedSigSub t bs) = + pretty "user-defined signature subpacket type" + <+> pretty t + <+> pretty (BL.unpack bs) + pretty (OtherSigSub t bs) = + pretty "unknown signature subpacket type" + <+> pretty t + <+> prettyLBS bs + +instance A.ToJSON SigSubPacketPayload where + toJSON (SigCreationTime ts) = object [AK.fromString "sigCreationTime" .= ts] + toJSON (SigExpirationTime d) = object [AK.fromString "sigExpirationTime" .= d] + toJSON (ExportableCertification e) = + object [AK.fromString "exportableCertification" .= e] + toJSON (TrustSignature tl ta) = + object [AK.fromString "trustSignature" .= (tl, ta)] + toJSON (RegularExpression apdre) = + object [AK.fromString "regularExpression" .= BL.unpack apdre] + toJSON (Revocable r) = object [AK.fromString "revocable" .= r] + toJSON (KeyExpirationTime d) = object [AK.fromString "keyExpirationTime" .= d] + toJSON (PreferredSymmetricAlgorithms sas) = + object [AK.fromString "preferredSymmetricAlgorithms" .= sas] + toJSON (RevocationKey rcs pka tof) = + object [AK.fromString "revocationKey" .= (rcs, pka, tof)] + toJSON (Issuer eoki) = object [AK.fromString "issuer" .= eoki] + toJSON (NotationData nfs (NotationName nn) (NotationValue nv)) = + object + [ AK.fromString "notationData" .= (nfs, BL.unpack nn, BL.unpack nv) + ] + toJSON (PreferredHashAlgorithms phas) = + object [AK.fromString "preferredHashAlgorithms" .= phas] + toJSON (PreferredCompressionAlgorithms pcas) = + object [AK.fromString "preferredCompressionAlgorithms" .= pcas] + toJSON (KeyServerPreferences kspfs) = + object [AK.fromString "keyServerPreferences" .= kspfs] + toJSON (PreferredKeyServer ks) = + object [AK.fromString "preferredKeyServer" .= show ks] + toJSON (PrimaryUserId p) = object [AK.fromString "primaryUserId" .= p] + toJSON (PolicyURL u) = object [AK.fromString "policyURL" .= u] + toJSON (KeyFlags kfs) = object [AK.fromString "keyFlags" .= kfs] + toJSON (SignersUserId u) = object [AK.fromString "signersUserId" .= u] + toJSON (ReasonForRevocation rc rr) = + object [AK.fromString "reasonForRevocation" .= (rc, rr)] + toJSON (Features ffs) = object [AK.fromString "features" .= ffs] + toJSON (SignatureTarget pka ha sh) = + object + [AK.fromString "signatureTarget" .= (pka, ha, BL.unpack sh)] + toJSON (EmbeddedSignature sp) = + object [AK.fromString "embeddedSignature" .= sp] + toJSON (IssuerFingerprint kv ifp) = + object [AK.fromString "issuerFingerprint" .= (kv, ifp)] + toJSON (IntendedRecipient kv ifp) = + object [AK.fromString "intendedRecipient" .= (kv, ifp)] + toJSON (PreferredAEADCiphersuites ps) = + object [AK.fromString "preferredAEADCiphersuites" .= ps] + toJSON (UserDefinedSigSub t bs) = + object [AK.fromString "userDefinedSigSub" .= (t, BL.unpack bs)] + toJSON (OtherSigSub t bs) = + object [AK.fromString "otherSigSub" .= (t, BL.unpack bs)] + +uc3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uc3 f ~(a, b, c) = f a b c + +instance A.FromJSON SigSubPacketPayload where + parseJSON (A.Object v) = + (SigCreationTime <$> v A..: AK.fromString "sigCreationTime") + <|> (SigExpirationTime <$> v A..: AK.fromString "sigExpirationTime") + <|> ( ExportableCertification + <$> v A..: AK.fromString "exportableCertification" + ) + <|> (uncurry TrustSignature <$> v A..: AK.fromString "trustSignature") + <|> ( RegularExpression . BL.pack + <$> v A..: AK.fromString "regularExpression" + ) + <|> (Revocable <$> v A..: AK.fromString "revocable") + <|> (KeyExpirationTime <$> v A..: AK.fromString "keyExpirationTime") + <|> ( PreferredSymmetricAlgorithms + <$> v A..: AK.fromString "preferredSymmetricAlgorithms" + ) + <|> (uc3 RevocationKey <$> v A..: AK.fromString "revocationKey") + <|> (Issuer <$> v A..: AK.fromString "issuer") + <|> (uc3 NotationData <$> v A..: AK.fromString "notationData") + <|> ( uncurry IssuerFingerprint + <$> v A..: AK.fromString "issuerFingerprint" + ) + <|> ( uncurry IntendedRecipient + <$> v A..: AK.fromString "intendedRecipient" + ) + <|> ( PreferredAEADCiphersuites + <$> v A..: AK.fromString "preferredAEADCiphersuites" + ) + parseJSON _ = mzero + +data SigSubPacket + = SigSubPacket + { _sspCriticality :: Bool + , _sspPayload :: SigSubPacketPayload + } + deriving (Data, Eq, Generic, Show, Typeable) + +instance Ord SigSubPacket where + compare (SigSubPacket crit1 payload1) (SigSubPacket crit2 payload2) = + compare crit1 crit2 <> compare payload1 payload2 + +instance Pretty SigSubPacket where + pretty x = + ( if _sspCriticality x + then pretty '*' + else mempty + ) + <> (pretty . _sspPayload) x + +instance Hashable SigSubPacket + +instance A.ToJSON SigSubPacket + +instance A.FromJSON SigSubPacket + +$(makeLenses ''SigSubPacket) + +-- FIXME: the SubpacketList type and associated functions should be moved into a separate module + +{- | Type-safe subpacket list with phantom types to distinguish hashed vs unhashed +and signature version constraints (v4 vs v6). +-} +newtype SubpacketList (hashedness :: Type) (version :: Type) + = SubpacketList [SigSubPacket] + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Functor (SubpacketList h) where + fmap _ (SubpacketList sps) = SubpacketList sps + +-- | Extract the underlying list from a phantom-typed SubpacketList +fromSubpacketList :: SubpacketList h v -> [SigSubPacket] +fromSubpacketList (SubpacketList sps) = sps + +-- | Wrap a plain list into a phantom-typed SubpacketList +toSubpacketList :: [SigSubPacket] -> SubpacketList h v +toSubpacketList = SubpacketList + +-- | Create an empty hashed subpacket list for a given signature version +emptyHashedSubpackets :: SubpacketList Hashed v +emptyHashedSubpackets = SubpacketList [] + +-- | Create an empty unhashed subpacket list for a given signature version +emptyUnhashedSubpackets :: SubpacketList Unhashed v +emptyUnhashedSubpackets = SubpacketList [] + +-- | Append a subpacket to a hashed list, preserving phantom type +consHashedSubpacket + :: SigSubPacket -> SubpacketList Hashed v -> SubpacketList Hashed v +consHashedSubpacket sp (SubpacketList sps) = SubpacketList (sp : sps) + +-- | Append a subpacket to an unhashed list, preserving phantom type +consUnhashedSubpacket + :: SigSubPacket + -> SubpacketList Unhashed v + -> SubpacketList Unhashed v +consUnhashedSubpacket sp (SubpacketList sps) = SubpacketList (sp : sps) + +data KeyVersion + = DeprecatedV3 + | V4 + | V6 + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Hashable KeyVersion + +instance Pretty KeyVersion where + pretty DeprecatedV3 = pretty "(deprecated) v3" + pretty V4 = pretty "v4" + pretty V6 = pretty "v6" + +$(ATH.deriveJSON ATH.defaultOptions ''KeyVersion) + +newtype IV + = IV + { unIV :: B.ByteString + } + deriving + ( ByteArrayAccess + , Data + , Eq + , Generic + , Hashable + , Monoid + , Semigroup + , Show + , Typeable + ) + +instance Wrapped IV + +instance Ord IV where + compare (IV b1) (IV b2) = compare b1 b2 + +instance Pretty IV where + pretty = pretty . ("iv:" ++) . bsToHexUpper . BL.fromStrict . op IV + +instance A.ToJSON IV where + toJSON = A.toJSON . show . op IV + +data LiteralDataType + = BinaryData + | TextData + | UTF8Data + | OtherData Word8 + deriving (Data, Generic, Show, Typeable) + +instance Hashable LiteralDataType + +instance Eq LiteralDataType where + (==) a b = fromFVal a == fromFVal b + +instance Ord LiteralDataType where + compare = comparing fromFVal + +instance FutureVal LiteralDataType where + fromFVal BinaryData = fromIntegral . fromEnum $ 'b' + fromFVal TextData = fromIntegral . fromEnum $ 't' + fromFVal UTF8Data = fromIntegral . fromEnum $ 'u' + fromFVal (OtherData o) = o + toFVal 0x62 = BinaryData + toFVal 0x74 = TextData + toFVal 0x75 = UTF8Data + toFVal o = OtherData o + +instance Pretty LiteralDataType where + pretty BinaryData = pretty "binary" + pretty TextData = pretty "text" + pretty UTF8Data = pretty "UTF-8" + pretty (OtherData o) = pretty "other data type " <+> pretty o + +$(ATH.deriveJSON ATH.defaultOptions ''LiteralDataType) + +newtype SessionKey + = SessionKey + { unSessionKey :: B.ByteString + } + deriving (Data, Eq, Generic, Hashable, Show, Typeable) + +instance Wrapped SessionKey + +instance Ord SessionKey where + compare (SessionKey b1) (SessionKey b2) = compare b1 b2 + +newtype Salt + = Salt + { unSalt :: B.ByteString + } + deriving (Data, Eq, Generic, Hashable, Show, Typeable) + +instance Wrapped Salt + +instance Ord Salt where + compare (Salt b1) (Salt b2) = compare b1 b2 + +instance Pretty Salt where + pretty = pretty . ("salt:" ++) . bsToHexUpper . BL.fromStrict . op Salt + +instance A.ToJSON Salt where + toJSON = A.toJSON . show . op Salt + +newtype Salt8 + = Salt8 + { unSalt8 :: B.ByteString + } + deriving (Data, Eq, Generic, Hashable, Show, Typeable) + +instance Wrapped Salt8 + +instance Ord Salt8 where + compare (Salt8 b1) (Salt8 b2) = compare b1 b2 + +instance Pretty Salt8 where + pretty = + pretty . ("salt8:" ++) . bsToHexUpper . BL.fromStrict . op Salt8 + +instance A.ToJSON Salt8 where + toJSON = A.toJSON . show . op Salt8 + +newtype Salt16 + = Salt16 + { unSalt16 :: B.ByteString + } + deriving (Data, Eq, Generic, Hashable, Show, Typeable) + +instance Wrapped Salt16 + +instance Ord Salt16 where + compare (Salt16 b1) (Salt16 b2) = compare b1 b2 + +instance Pretty Salt16 where + pretty = + pretty + . ("salt16:" ++) + . bsToHexUpper + . BL.fromStrict + . op Salt16 + +instance A.ToJSON Salt16 where + toJSON = A.toJSON . show . op Salt16 + +-- FIXME: these functions should be in a separate module +salt8FromSalt :: Salt -> Maybe Salt8 +salt8FromSalt (Salt bs) + | B.length bs == 8 = Just (Salt8 bs) + | otherwise = Nothing + +salt16FromSalt :: Salt -> Maybe Salt16 +salt16FromSalt (Salt bs) + | B.length bs == 16 = Just (Salt16 bs) + | otherwise = Nothing + +saltFromSalt8 :: Salt8 -> Salt +saltFromSalt8 (Salt8 bs) = Salt bs + +saltFromSalt16 :: Salt16 -> Salt +saltFromSalt16 (Salt16 bs) = Salt bs + +newtype IterationCount + = IterationCount + { unIterationCount :: Int + } + deriving + ( Bounded + , Data + , Enum + , Eq + , Generic + , Hashable + , Integral + , Num + , Ord + , Real + , Show + , Typeable + ) + +instance Wrapped IterationCount + +instance Pretty IterationCount where + pretty = pretty . op IterationCount + +$(ATH.deriveJSON ATH.defaultOptions ''IterationCount) + +data S2K + = Simple HashAlgorithm + | Salted HashAlgorithm Salt8 + | IteratedSalted HashAlgorithm Salt8 IterationCount + | Argon2 Salt16 Word8 Word8 Word8 + | OtherS2K Word8 ByteString + deriving (Data, Eq, Generic, Show, Typeable) + +instance Hashable S2K + +instance Ord S2K where + compare (Simple ha1) (Simple ha2) = compare ha1 ha2 + compare (Salted ha1 s1) (Salted ha2 s2) = compare ha1 ha2 <> compare s1 s2 + compare (IteratedSalted ha1 s1 ic1) (IteratedSalted ha2 s2 ic2) = + compare ha1 ha2 <> compare s1 s2 <> compare ic1 ic2 + compare (Argon2 salt1 t1 p1 em1) (Argon2 salt2 t2 p2 em2) = + compare salt1 salt2 + <> compare t1 t2 + <> compare p1 p2 + <> compare em1 em2 + compare (OtherS2K t1 bs1) (OtherS2K t2 bs2) = compare t1 t2 <> compare bs1 bs2 + compare Simple {} Salted {} = LT + compare Simple {} IteratedSalted {} = LT + compare Simple {} Argon2 {} = LT + compare Simple {} OtherS2K {} = LT + compare Salted {} Simple {} = GT + compare Salted {} IteratedSalted {} = LT + compare Salted {} Argon2 {} = LT + compare Salted {} OtherS2K {} = LT + compare IteratedSalted {} Simple {} = GT + compare IteratedSalted {} Salted {} = GT + compare IteratedSalted {} Argon2 {} = LT + compare IteratedSalted {} OtherS2K {} = LT + compare Argon2 {} Simple {} = GT + compare Argon2 {} Salted {} = GT + compare Argon2 {} IteratedSalted {} = GT + compare Argon2 {} OtherS2K {} = LT + compare OtherS2K {} _ = GT + +instance Pretty S2K where + pretty (Simple ha) = pretty "simple S2K," <+> pretty ha + pretty (Salted ha salt) = pretty "salted S2K," <+> pretty ha <+> pretty salt + pretty (IteratedSalted ha salt icount) = + pretty "iterated-salted S2K," + <+> pretty ha + <+> pretty salt + <+> pretty icount + pretty (Argon2 salt t p em) = + pretty "Argon2 S2K," + <+> pretty salt + <+> pretty t + <+> pretty p + <+> pretty em + pretty (OtherS2K t bs) = + pretty "unknown S2K type" + <+> pretty t + <+> pretty (bsToHexUpper bs) + +instance A.ToJSON S2K where + toJSON (Simple ha) = A.toJSON ha + toJSON (Salted ha salt) = A.toJSON (ha, salt) + toJSON (IteratedSalted ha salt icount) = A.toJSON (ha, salt, icount) + toJSON (Argon2 salt t p em) = A.toJSON (salt, t, p, em) + toJSON (OtherS2K t bs) = A.toJSON (t, BL.unpack bs) + +data ImageFormat + = JPEG + | OtherImage Word8 + deriving (Data, Generic, Show, Typeable) + +instance Eq ImageFormat where + (==) a b = fromFVal a == fromFVal b + +instance Ord ImageFormat where + compare = comparing fromFVal + +instance FutureVal ImageFormat where + fromFVal JPEG = 1 + fromFVal (OtherImage o) = o + toFVal 1 = JPEG + toFVal o = OtherImage o + +instance Hashable ImageFormat + +instance Pretty ImageFormat where + pretty JPEG = pretty "JPEG" + pretty (OtherImage o) = pretty "unknown image format" <+> pretty o + +$(ATH.deriveJSON ATH.defaultOptions ''ImageFormat) + +newtype ImageHeader + = ImageHV1 ImageFormat + deriving (Data, Eq, Generic, Show, Typeable) + +instance Ord ImageHeader where + compare (ImageHV1 a) (ImageHV1 b) = compare a b + +instance Hashable ImageHeader + +instance Pretty ImageHeader where + pretty (ImageHV1 f) = pretty "imghdr v1" <+> pretty f + +$(ATH.deriveJSON ATH.defaultOptions ''ImageHeader) + +data UserAttrSubPacket + = ImageAttribute ImageHeader ImageData + | OtherUASub Word8 ByteString + deriving (Data, Eq, Generic, Show, Typeable) + +instance Hashable UserAttrSubPacket + +instance Ord UserAttrSubPacket where + compare (ImageAttribute h1 d1) (ImageAttribute h2 d2) = + compare h1 h2 <> compare d1 d2 + compare (ImageAttribute _ _) (OtherUASub _ _) = LT + compare (OtherUASub _ _) (ImageAttribute _ _) = GT + compare (OtherUASub t1 b1) (OtherUASub t2 b2) = compare t1 t2 <> compare b1 b2 + +instance Pretty UserAttrSubPacket where + pretty (ImageAttribute ih d) = + pretty "image-attribute" <+> pretty ih <+> pretty (BL.unpack d) + pretty (OtherUASub t bs) = + pretty "unknown attribute type" + <> pretty t + <+> pretty (BL.unpack bs) + +instance A.ToJSON UserAttrSubPacket where + toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack d) + toJSON (OtherUASub t bs) = A.toJSON (t, BL.unpack bs) + +-- FIXME: should this be merged with EdSigningCurve somehow? +data ECCCurve + = NISTP256 + | NISTP384 + | NISTP521 + | Curve25519 + | Curve448 + deriving (Data, Eq, Generic, Ord, Show, Typeable) + +instance Pretty ECCCurve where + pretty NISTP256 = pretty "NIST P-256" + pretty NISTP384 = pretty "NIST P-384" + pretty NISTP521 = pretty "NIST P-521" + pretty Curve25519 = pretty "Curve25519" + pretty Curve448 = pretty "Curve448" + +instance Hashable ECCCurve + +-- Packet stream wrapper used to provide an EOF-delimited Binary instance. +newtype Block a + = Block + { unBlock :: [a] + } -- intentionally not encoded as a list length prefix + deriving (Eq, Show) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs b/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs @@ -2,58 +2,56 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} module Codec.Encryption.OpenPGP.Types.Internal.PKITypes where -import GHC.Generics (Generic) - -import Codec.Encryption.OpenPGP.Types.Internal.Base hiding (Ed25519, Ed448) -import Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes - import qualified Data.Aeson as A import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL -import Data.Data (Data(..)) +import Data.Data (Data (..)) import qualified Data.Data as DData -import Data.Hashable (Hashable(..)) +import Data.Hashable (Hashable (..)) import Data.Ord (comparing) import Data.Typeable (Typeable) import Data.Word (Word16) -import Prettyprinter (Pretty(..), (<+>)) +import GHC.Generics (Generic) +import Prettyprinter (Pretty (..), (<+>)) -data EdSigningCurve = - Ed25519 - | Ed448 - deriving (Data, Eq, Generic, Ord, Show, Typeable) +import Codec.Encryption.OpenPGP.Types.Internal.Base +import Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes +data EdSigningCurve + = EdSigningCurve25519 + | EdSigningCurve448 + deriving (Data, Eq, Generic, Ord, Show, Typeable) + instance Hashable EdSigningCurve instance Pretty EdSigningCurve where - pretty Ed25519 = pretty "Ed25519" - pretty Ed448 = pretty "Ed448" + pretty EdSigningCurve25519 = pretty "Ed25519" + pretty EdSigningCurve448 = pretty "Ed448" instance A.FromJSON EdSigningCurve instance A.ToJSON EdSigningCurve -newtype EPoint = - EPoint +newtype EPoint + = EPoint { unEPoint :: Integer } - deriving (Data, Eq, Generic, Ord, Pretty, Show, Typeable) + deriving (Data, Eq, Generic, Ord, Pretty, Show, Typeable) instance Hashable EPoint @@ -62,263 +60,228 @@ instance A.ToJSON EPoint data EdPoint - = PrefixedNativeEPoint EPoint - | NativeEPoint EPoint - deriving (Data, Eq, Generic, Ord, Show, Typeable) + = PrefixedNativeEPoint EPoint + | NativeEPoint EPoint + deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable EdPoint instance Pretty EdPoint where - pretty (PrefixedNativeEPoint ep) = pretty "prefixed-native" <+> pretty ep - pretty (NativeEPoint ep) = pretty "native" <+> pretty ep + pretty (PrefixedNativeEPoint ep) = pretty "prefixed-native" <+> pretty ep + pretty (NativeEPoint ep) = pretty "native" <+> pretty ep instance A.FromJSON EdPoint instance A.ToJSON EdPoint data PKey - = RSAPubKey RSA_PublicKey - | DSAPubKey DSA_PublicKey - | ElGamalPubKey Integer Integer Integer - | ECDHPubKey PKey HashAlgorithm SymmetricAlgorithm - | ECDSAPubKey ECDSA_PublicKey - | EdDSAPubKey EdSigningCurve EdPoint - | UnknownPKey ByteString - deriving (Data, Eq, Generic, Ord, Show, Typeable) + = RSAPubKey RSA_PublicKey + | DSAPubKey DSA_PublicKey + | ElGamalPubKey Integer Integer Integer + | ECDHPubKey PKey HashAlgorithm SymmetricAlgorithm + | ECDSAPubKey ECDSA_PublicKey + | EdDSAPubKey EdSigningCurve EdPoint + | MLKEMPubKey B.ByteString + | MLDSAPubKey B.ByteString + | SLHDSAPubKey B.ByteString + | UnknownPKey ByteString + deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable PKey instance Pretty PKey where - pretty (RSAPubKey p) = pretty "RSA" <+> pretty p - pretty (DSAPubKey p) = pretty "DSA" <+> pretty p - pretty (ElGamalPubKey p g y) = - pretty "Elgamal" <+> pretty p <+> pretty g <+> pretty y - pretty (ECDHPubKey p ha sa) = - pretty "ECDH" <+> pretty p <+> pretty ha <+> pretty sa - pretty (ECDSAPubKey p) = pretty "ECDSA" <+> pretty p - pretty (EdDSAPubKey c ep) = pretty c <+> pretty ep - pretty (UnknownPKey bs) = pretty "" <+> pretty (bsToHexUpper bs) + pretty (RSAPubKey p) = pretty "RSA" <+> pretty p + pretty (DSAPubKey p) = pretty "DSA" <+> pretty p + pretty (ElGamalPubKey p g y) = + pretty "Elgamal" <+> pretty p <+> pretty g <+> pretty y + pretty (ECDHPubKey p ha sa) = + pretty "ECDH" <+> pretty p <+> pretty ha <+> pretty sa + pretty (ECDSAPubKey p) = pretty "ECDSA" <+> pretty p + pretty (EdDSAPubKey c ep) = pretty c <+> pretty ep + pretty (MLKEMPubKey bs) = pretty "ML-KEM" <+> pretty (bsToHexUpper (BL.fromStrict bs)) + pretty (MLDSAPubKey bs) = pretty "ML-DSA" <+> pretty (bsToHexUpper (BL.fromStrict bs)) + pretty (SLHDSAPubKey bs) = pretty "SLH-DSA" <+> pretty (bsToHexUpper (BL.fromStrict bs)) + pretty (UnknownPKey bs) = pretty "" <+> pretty (bsToHexUpper bs) instance A.ToJSON PKey where - toJSON (RSAPubKey p) = A.toJSON p - toJSON (DSAPubKey p) = A.toJSON p - toJSON (ElGamalPubKey p g y) = A.toJSON (p, g, y) - toJSON (ECDHPubKey p ha sa) = A.toJSON (p, ha, sa) - toJSON (ECDSAPubKey p) = A.toJSON p - toJSON (EdDSAPubKey c ep) = A.toJSON (c, ep) - toJSON (UnknownPKey bs) = A.toJSON (BL.unpack bs) + toJSON (RSAPubKey p) = A.toJSON p + toJSON (DSAPubKey p) = A.toJSON p + toJSON (ElGamalPubKey p g y) = A.toJSON (p, g, y) + toJSON (ECDHPubKey p ha sa) = A.toJSON (p, ha, sa) + toJSON (ECDSAPubKey p) = A.toJSON p + toJSON (EdDSAPubKey c ep) = A.toJSON (c, ep) + toJSON (MLKEMPubKey bs) = A.toJSON (B.unpack bs) + toJSON (MLDSAPubKey bs) = A.toJSON (B.unpack bs) + toJSON (SLHDSAPubKey bs) = A.toJSON (B.unpack bs) + toJSON (UnknownPKey bs) = A.toJSON (BL.unpack bs) data SKey - = RSAPrivateKey RSA_PrivateKey - | DSAPrivateKey DSA_PrivateKey - | ElGamalPrivateKey Integer - | ECDHPrivateKey ECDSA_PrivateKey - | ECDSAPrivateKey ECDSA_PrivateKey - | EdDSAPrivateKey EdSigningCurve B.ByteString - | X25519PrivateKey B.ByteString - | X448PrivateKey B.ByteString - | UnknownSKey ByteString - deriving (Data, Eq, Generic, Show, Typeable) + = RSAPrivateKey RSA_PrivateKey + | DSAPrivateKey DSA_PrivateKey + | ElGamalPrivateKey Integer + | ECDHPrivateKey ECDSA_PrivateKey + | ECDSAPrivateKey ECDSA_PrivateKey + | EdDSAPrivateKey EdSigningCurve B.ByteString + | X25519PrivateKey B.ByteString + | X448PrivateKey B.ByteString + | MLKEMPrivateKey B.ByteString + | MLDSAPrivateKey B.ByteString + | SLHDSAPrivateKey B.ByteString + | UnknownSKey ByteString + deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable SKey -instance Ord SKey where - compare (RSAPrivateKey rsa1) (RSAPrivateKey rsa2) = compare rsa1 rsa2 - compare (DSAPrivateKey dsa1) (DSAPrivateKey dsa2) = compare dsa1 dsa2 - compare (ElGamalPrivateKey x1) (ElGamalPrivateKey x2) = compare x1 x2 - compare (ECDHPrivateKey ecdsa1) (ECDHPrivateKey ecdsa2) = compare ecdsa1 ecdsa2 - compare (ECDSAPrivateKey ecdsa1) (ECDSAPrivateKey ecdsa2) = compare ecdsa1 ecdsa2 - compare (EdDSAPrivateKey curve1 bs1) (EdDSAPrivateKey curve2 bs2) = - compare curve1 curve2 <> compare bs1 bs2 - compare (X25519PrivateKey bs1) (X25519PrivateKey bs2) = compare bs1 bs2 - compare (X448PrivateKey bs1) (X448PrivateKey bs2) = compare bs1 bs2 - compare (UnknownSKey bs1) (UnknownSKey bs2) = compare bs1 bs2 - compare RSAPrivateKey {} DSAPrivateKey {} = LT - compare RSAPrivateKey {} ElGamalPrivateKey {} = LT - compare RSAPrivateKey {} ECDHPrivateKey {} = LT - compare RSAPrivateKey {} ECDSAPrivateKey {} = LT - compare RSAPrivateKey {} EdDSAPrivateKey {} = LT - compare RSAPrivateKey {} X25519PrivateKey {} = LT - compare RSAPrivateKey {} X448PrivateKey {} = LT - compare RSAPrivateKey {} UnknownSKey {} = LT - compare DSAPrivateKey {} RSAPrivateKey {} = GT - compare DSAPrivateKey {} ElGamalPrivateKey {} = LT - compare DSAPrivateKey {} ECDHPrivateKey {} = LT - compare DSAPrivateKey {} ECDSAPrivateKey {} = LT - compare DSAPrivateKey {} EdDSAPrivateKey {} = LT - compare DSAPrivateKey {} X25519PrivateKey {} = LT - compare DSAPrivateKey {} X448PrivateKey {} = LT - compare DSAPrivateKey {} UnknownSKey {} = LT - compare ElGamalPrivateKey {} RSAPrivateKey {} = GT - compare ElGamalPrivateKey {} DSAPrivateKey {} = GT - compare ElGamalPrivateKey {} ECDHPrivateKey {} = LT - compare ElGamalPrivateKey {} ECDSAPrivateKey {} = LT - compare ElGamalPrivateKey {} EdDSAPrivateKey {} = LT - compare ElGamalPrivateKey {} X25519PrivateKey {} = LT - compare ElGamalPrivateKey {} X448PrivateKey {} = LT - compare ElGamalPrivateKey {} UnknownSKey {} = LT - compare ECDHPrivateKey {} RSAPrivateKey {} = GT - compare ECDHPrivateKey {} DSAPrivateKey {} = GT - compare ECDHPrivateKey {} ElGamalPrivateKey {} = GT - compare ECDHPrivateKey {} ECDSAPrivateKey {} = LT - compare ECDHPrivateKey {} EdDSAPrivateKey {} = LT - compare ECDHPrivateKey {} X25519PrivateKey {} = LT - compare ECDHPrivateKey {} X448PrivateKey {} = LT - compare ECDHPrivateKey {} UnknownSKey {} = LT - compare ECDSAPrivateKey {} RSAPrivateKey {} = GT - compare ECDSAPrivateKey {} DSAPrivateKey {} = GT - compare ECDSAPrivateKey {} ElGamalPrivateKey {} = GT - compare ECDSAPrivateKey {} ECDHPrivateKey {} = GT - compare ECDSAPrivateKey {} EdDSAPrivateKey {} = LT - compare ECDSAPrivateKey {} X25519PrivateKey {} = LT - compare ECDSAPrivateKey {} X448PrivateKey {} = LT - compare ECDSAPrivateKey {} UnknownSKey {} = LT - compare EdDSAPrivateKey {} RSAPrivateKey {} = GT - compare EdDSAPrivateKey {} DSAPrivateKey {} = GT - compare EdDSAPrivateKey {} ElGamalPrivateKey {} = GT - compare EdDSAPrivateKey {} ECDHPrivateKey {} = GT - compare EdDSAPrivateKey {} ECDSAPrivateKey {} = GT - compare EdDSAPrivateKey {} X25519PrivateKey {} = LT - compare EdDSAPrivateKey {} X448PrivateKey {} = LT - compare EdDSAPrivateKey {} UnknownSKey {} = LT - compare X25519PrivateKey {} RSAPrivateKey {} = GT - compare X25519PrivateKey {} DSAPrivateKey {} = GT - compare X25519PrivateKey {} ElGamalPrivateKey {} = GT - compare X25519PrivateKey {} ECDHPrivateKey {} = GT - compare X25519PrivateKey {} ECDSAPrivateKey {} = GT - compare X25519PrivateKey {} EdDSAPrivateKey {} = GT - compare X25519PrivateKey {} X448PrivateKey {} = LT - compare X25519PrivateKey {} UnknownSKey {} = LT - compare X448PrivateKey {} RSAPrivateKey {} = GT - compare X448PrivateKey {} DSAPrivateKey {} = GT - compare X448PrivateKey {} ElGamalPrivateKey {} = GT - compare X448PrivateKey {} ECDHPrivateKey {} = GT - compare X448PrivateKey {} ECDSAPrivateKey {} = GT - compare X448PrivateKey {} EdDSAPrivateKey {} = GT - compare X448PrivateKey {} X25519PrivateKey {} = GT - compare X448PrivateKey {} UnknownSKey {} = LT - compare UnknownSKey {} _ = GT - instance Pretty SKey where - pretty (RSAPrivateKey p) = pretty "RSA" <+> pretty p - pretty (DSAPrivateKey p) = pretty "DSA" <+> pretty p - pretty (ElGamalPrivateKey p) = pretty "Elgamal" <+> pretty p - pretty (ECDHPrivateKey p) = pretty "ECDH" <+> pretty p - pretty (ECDSAPrivateKey p) = pretty "ECDSA" <+> pretty p - pretty (EdDSAPrivateKey c bs) = - pretty c <+> pretty (bsToHexUpper (BL.fromStrict bs)) - pretty (X25519PrivateKey bs) = pretty "X25519" <+> pretty (bsToHexUpper (BL.fromStrict bs)) - pretty (X448PrivateKey bs) = pretty "X448" <+> pretty (bsToHexUpper (BL.fromStrict bs)) - pretty (UnknownSKey bs) = pretty "" <+> pretty (bsToHexUpper bs) + pretty (RSAPrivateKey p) = pretty "RSA" <+> pretty p + pretty (DSAPrivateKey p) = pretty "DSA" <+> pretty p + pretty (ElGamalPrivateKey p) = pretty "Elgamal" <+> pretty p + pretty (ECDHPrivateKey p) = pretty "ECDH" <+> pretty p + pretty (ECDSAPrivateKey p) = pretty "ECDSA" <+> pretty p + pretty (EdDSAPrivateKey c bs) = + pretty c <+> pretty (bsToHexUpper (BL.fromStrict bs)) + pretty (X25519PrivateKey bs) = pretty "X25519" <+> pretty (bsToHexUpper (BL.fromStrict bs)) + pretty (X448PrivateKey bs) = pretty "X448" <+> pretty (bsToHexUpper (BL.fromStrict bs)) + pretty (MLKEMPrivateKey bs) = + pretty "ML-KEM-priv" <+> pretty (bsToHexUpper (BL.fromStrict bs)) + pretty (MLDSAPrivateKey bs) = + pretty "ML-DSA-priv" <+> pretty (bsToHexUpper (BL.fromStrict bs)) + pretty (SLHDSAPrivateKey bs) = + pretty "SLH-DSA-priv" + <+> pretty (bsToHexUpper (BL.fromStrict bs)) + pretty (UnknownSKey bs) = pretty "" <+> pretty (bsToHexUpper bs) instance A.ToJSON SKey where - toJSON (RSAPrivateKey k) = A.toJSON k - toJSON (DSAPrivateKey k) = A.toJSON k - toJSON (ElGamalPrivateKey k) = A.toJSON k - toJSON (ECDHPrivateKey k) = A.toJSON k - toJSON (ECDSAPrivateKey k) = A.toJSON k - toJSON (EdDSAPrivateKey c bs) = A.toJSON (c, B.unpack bs) - toJSON (X25519PrivateKey bs) = A.toJSON (B.unpack bs) - toJSON (X448PrivateKey bs) = A.toJSON (B.unpack bs) - toJSON (UnknownSKey bs) = A.toJSON (BL.unpack bs) + toJSON (RSAPrivateKey k) = A.toJSON k + toJSON (DSAPrivateKey k) = A.toJSON k + toJSON (ElGamalPrivateKey k) = A.toJSON k + toJSON (ECDHPrivateKey k) = A.toJSON k + toJSON (ECDSAPrivateKey k) = A.toJSON k + toJSON (EdDSAPrivateKey c bs) = A.toJSON (c, B.unpack bs) + toJSON (X25519PrivateKey bs) = A.toJSON (B.unpack bs) + toJSON (X448PrivateKey bs) = A.toJSON (B.unpack bs) + toJSON (MLKEMPrivateKey bs) = A.toJSON (B.unpack bs) + toJSON (MLDSAPrivateKey bs) = A.toJSON (B.unpack bs) + toJSON (SLHDSAPrivateKey bs) = A.toJSON (B.unpack bs) + toJSON (UnknownSKey bs) = A.toJSON (BL.unpack bs) data PKPayload (v :: KeyVersion) where - PKPayloadV3 :: - ThirtyTwoBitTimeStamp - -> V3Expiration - -> PubKeyAlgorithm - -> PKey - -> PKPayload 'DeprecatedV3 - PKPayloadV4 :: - ThirtyTwoBitTimeStamp - -> PubKeyAlgorithm - -> PKey - -> PKPayload 'V4 - PKPayloadV6 :: - ThirtyTwoBitTimeStamp - -> PubKeyAlgorithm - -> PKey - -> PKPayload 'V6 + PKPayloadV3 + :: ThirtyTwoBitTimeStamp + -> V3Expiration + -> PubKeyAlgorithm + -> PKey + -> PKPayload 'DeprecatedV3 + PKPayloadV4 + :: ThirtyTwoBitTimeStamp + -> PubKeyAlgorithm + -> PKey + -> PKPayload 'V4 + PKPayloadV6 + :: ThirtyTwoBitTimeStamp + -> PubKeyAlgorithm + -> PKey + -> PKPayload 'V6 deriving instance Eq (PKPayload v) deriving instance Ord (PKPayload v) deriving instance Show (PKPayload v) instance Hashable (PKPayload v) where - hashWithSalt s = hashWithSalt s . pkPayloadFields + hashWithSalt s = hashWithSalt s . pkPayloadFields instance Pretty (PKPayload v) where - pretty pkp = - let (kv, ts, v3e, pka, p) = pkPayloadFields pkp - in pretty kv <+> pretty ts <+> pretty v3e <+> pretty pka <+> pretty p + pretty pkp = + let (kv, ts, v3e, pka, p) = pkPayloadFields pkp + in pretty kv + <+> pretty ts + <+> pretty v3e + <+> pretty pka + <+> pretty p instance A.ToJSON (PKPayload v) where - toJSON = A.toJSON . pkPayloadFields + toJSON = A.toJSON . pkPayloadFields data SomePKPayload where - SomePKPayload :: PKPayload v -> SomePKPayload + SomePKPayload :: PKPayload v -> SomePKPayload deriving instance Show SomePKPayload deriving instance Typeable SomePKPayload pkPayloadDataType :: DData.DataType pkPayloadDataType = - DData.mkDataType - "Codec.Encryption.OpenPGP.Types.Internal.PKITypes.SomePKPayload" - [pkPayloadConstr] + DData.mkDataType + "Codec.Encryption.OpenPGP.Types.Internal.PKITypes.SomePKPayload" + [pkPayloadConstr] pkPayloadConstr :: DData.Constr pkPayloadConstr = DData.mkConstr pkPayloadDataType "PKPayload" [] DData.Prefix instance Data SomePKPayload where - gfoldl f z (PKPayload kv ts v3e pka p) = - z PKPayload `f` kv `f` ts `f` v3e `f` pka `f` p - gunfold k z c - | c == pkPayloadConstr = k (k (k (k (k (z PKPayload))))) - | otherwise = error "gunfold: invalid constructor for SomePKPayload" - toConstr _ = pkPayloadConstr - dataTypeOf _ = pkPayloadDataType + gfoldl f z (PKPayload kv ts v3e pka p) = + z PKPayload `f` kv `f` ts `f` v3e `f` pka `f` p + gunfold k z c + | c == pkPayloadConstr = k (k (k (k (k (z PKPayload))))) + | otherwise = + error "gunfold: invalid constructor for SomePKPayload" + toConstr _ = pkPayloadConstr + dataTypeOf _ = pkPayloadDataType instance Eq SomePKPayload where - a == b = somePKPayloadFields a == somePKPayloadFields b + a == b = somePKPayloadFields a == somePKPayloadFields b instance Ord SomePKPayload where - compare = comparing somePKPayloadFields + compare = comparing somePKPayloadFields instance Hashable SomePKPayload where - hashWithSalt s = hashWithSalt s . somePKPayloadFields + hashWithSalt s = hashWithSalt s . somePKPayloadFields instance Pretty SomePKPayload where - pretty (PKPayload kv ts v3e pka p) = - pretty kv <+> pretty ts <+> pretty v3e <+> pretty pka <+> pretty p + pretty (PKPayload kv ts v3e pka p) = + pretty kv + <+> pretty ts + <+> pretty v3e + <+> pretty pka + <+> pretty p instance A.ToJSON SomePKPayload where - toJSON = A.toJSON . somePKPayloadFields + toJSON = A.toJSON . somePKPayloadFields -pkPayloadFields :: - PKPayload v - -> (KeyVersion, ThirtyTwoBitTimeStamp, V3Expiration, PubKeyAlgorithm, PKey) +pkPayloadFields + :: PKPayload v + -> ( KeyVersion + , ThirtyTwoBitTimeStamp + , V3Expiration + , PubKeyAlgorithm + , PKey + ) pkPayloadFields (PKPayloadV3 ts v3e pka p) = (DeprecatedV3, ts, v3e, pka, p) pkPayloadFields (PKPayloadV4 ts pka p) = (V4, ts, 0, pka, p) pkPayloadFields (PKPayloadV6 ts pka p) = (V6, ts, 0, pka, p) -somePKPayloadFields :: - SomePKPayload - -> (KeyVersion, ThirtyTwoBitTimeStamp, V3Expiration, PubKeyAlgorithm, PKey) +somePKPayloadFields + :: SomePKPayload + -> ( KeyVersion + , ThirtyTwoBitTimeStamp + , V3Expiration + , PubKeyAlgorithm + , PKey + ) somePKPayloadFields (SomePKPayload pkp) = pkPayloadFields pkp -pattern PKPayload :: - KeyVersion - -> ThirtyTwoBitTimeStamp - -> V3Expiration - -> PubKeyAlgorithm - -> PKey - -> SomePKPayload -pattern PKPayload kv ts v3e pka p <- (somePKPayloadFields -> (kv, ts, v3e, pka, p)) - where - PKPayload DeprecatedV3 ts v3e pka p = SomePKPayload (PKPayloadV3 ts v3e pka p) - PKPayload V4 ts _ pka p = SomePKPayload (PKPayloadV4 ts pka p) - PKPayload V6 ts _ pka p = SomePKPayload (PKPayloadV6 ts pka p) +pattern PKPayload + :: KeyVersion + -> ThirtyTwoBitTimeStamp + -> V3Expiration + -> PubKeyAlgorithm + -> PKey + -> SomePKPayload +pattern PKPayload kv ts v3e pka p <- + (somePKPayloadFields -> (kv, ts, v3e, pka, p)) + where + PKPayload DeprecatedV3 ts v3e pka p = SomePKPayload (PKPayloadV3 ts v3e pka p) + PKPayload V4 ts _ pka p = SomePKPayload (PKPayloadV4 ts pka p) + PKPayload V6 ts _ pka p = SomePKPayload (PKPayloadV6 ts pka p) {-# COMPLETE PKPayload #-} @@ -338,67 +301,88 @@ _pubkey (PKPayload _ _ _ _ p) = p data SKAddendum - = SUS16bit SymmetricAlgorithm S2K IV ByteString - | SUSSHA1 SymmetricAlgorithm S2K IV ByteString - | SUSAEAD SymmetricAlgorithm AEADAlgorithm S2K IV ByteString - | SUSym SymmetricAlgorithm IV ByteString - | SUUnencrypted SKey Word16 - deriving (Data, Eq, Generic, Show, Typeable) + = SUS16bit SymmetricAlgorithm S2K IV ByteString + | SUSSHA1 SymmetricAlgorithm S2K IV ByteString + | SUSAEAD SymmetricAlgorithm AEADAlgorithm S2K IV ByteString + | SUSym SymmetricAlgorithm IV ByteString + | SUUnencrypted SKey Word16 + deriving (Data, Eq, Generic, Show, Typeable) instance Ord SKAddendum where - compare (SUS16bit sa1 s2k1 iv1 bs1) (SUS16bit sa2 s2k2 iv2 bs2) = - compare sa1 sa2 <> compare s2k1 s2k2 <> compare iv1 iv2 <> compare bs1 bs2 - compare (SUSSHA1 sa1 s2k1 iv1 bs1) (SUSSHA1 sa2 s2k2 iv2 bs2) = - compare sa1 sa2 <> compare s2k1 s2k2 <> compare iv1 iv2 <> compare bs1 bs2 - compare (SUSAEAD sa1 aa1 s2k1 iv1 bs1) (SUSAEAD sa2 aa2 s2k2 iv2 bs2) = - compare sa1 sa2 <> compare aa1 aa2 <> compare s2k1 s2k2 <> compare iv1 iv2 <> - compare bs1 bs2 - compare (SUSym sa1 iv1 bs1) (SUSym sa2 iv2 bs2) = - compare sa1 sa2 <> compare iv1 iv2 <> compare bs1 bs2 - compare (SUUnencrypted sk1 ck1) (SUUnencrypted sk2 ck2) = - compare sk1 sk2 <> compare ck1 ck2 - compare SUS16bit {} SUSSHA1 {} = LT - compare SUS16bit {} SUSAEAD {} = LT - compare SUS16bit {} SUSym {} = LT - compare SUS16bit {} SUUnencrypted {} = LT - compare SUSSHA1 {} SUS16bit {} = GT - compare SUSSHA1 {} SUSAEAD {} = LT - compare SUSSHA1 {} SUSym {} = LT - compare SUSSHA1 {} SUUnencrypted {} = LT - compare SUSAEAD {} SUS16bit {} = GT - compare SUSAEAD {} SUSSHA1 {} = GT - compare SUSAEAD {} SUSym {} = LT - compare SUSAEAD {} SUUnencrypted {} = LT - compare SUSym {} SUS16bit {} = GT - compare SUSym {} SUSSHA1 {} = GT - compare SUSym {} SUSAEAD {} = GT - compare SUSym {} SUUnencrypted {} = LT - compare SUUnencrypted {} _ = GT + compare (SUS16bit sa1 s2k1 iv1 bs1) (SUS16bit sa2 s2k2 iv2 bs2) = + compare sa1 sa2 + <> compare s2k1 s2k2 + <> compare iv1 iv2 + <> compare bs1 bs2 + compare (SUSSHA1 sa1 s2k1 iv1 bs1) (SUSSHA1 sa2 s2k2 iv2 bs2) = + compare sa1 sa2 + <> compare s2k1 s2k2 + <> compare iv1 iv2 + <> compare bs1 bs2 + compare (SUSAEAD sa1 aa1 s2k1 iv1 bs1) (SUSAEAD sa2 aa2 s2k2 iv2 bs2) = + compare sa1 sa2 + <> compare aa1 aa2 + <> compare s2k1 s2k2 + <> compare iv1 iv2 + <> compare bs1 bs2 + compare (SUSym sa1 iv1 bs1) (SUSym sa2 iv2 bs2) = + compare sa1 sa2 <> compare iv1 iv2 <> compare bs1 bs2 + compare (SUUnencrypted sk1 ck1) (SUUnencrypted sk2 ck2) = + compare sk1 sk2 <> compare ck1 ck2 + compare SUS16bit {} SUSSHA1 {} = LT + compare SUS16bit {} SUSAEAD {} = LT + compare SUS16bit {} SUSym {} = LT + compare SUS16bit {} SUUnencrypted {} = LT + compare SUSSHA1 {} SUS16bit {} = GT + compare SUSSHA1 {} SUSAEAD {} = LT + compare SUSSHA1 {} SUSym {} = LT + compare SUSSHA1 {} SUUnencrypted {} = LT + compare SUSAEAD {} SUS16bit {} = GT + compare SUSAEAD {} SUSSHA1 {} = GT + compare SUSAEAD {} SUSym {} = LT + compare SUSAEAD {} SUUnencrypted {} = LT + compare SUSym {} SUS16bit {} = GT + compare SUSym {} SUSSHA1 {} = GT + compare SUSym {} SUSAEAD {} = GT + compare SUSym {} SUUnencrypted {} = LT + compare SUUnencrypted {} _ = GT instance Hashable SKAddendum instance Pretty SKAddendum where - pretty (SUS16bit sa s2k iv bs) = - pretty "SUS16bit" <+> - pretty sa <+> pretty s2k <+> pretty iv <+> pretty (bsToHexUpper bs) - pretty (SUSSHA1 sa s2k iv bs) = - pretty "SUSSHA1" <+> - pretty sa <+> pretty s2k <+> pretty iv <+> pretty (bsToHexUpper bs) - pretty (SUSAEAD sa aa s2k iv bs) = - pretty "SUSAEAD" <+> - pretty sa <+> pretty aa <+> pretty s2k <+> pretty iv <+> - pretty (bsToHexUpper bs) - pretty (SUSym sa iv bs) = - pretty "SUSym" <+> pretty sa <+> pretty iv <+> pretty (bsToHexUpper bs) - pretty (SUUnencrypted s ck) = - pretty "SUUnencrypted" <+> pretty s <+> pretty ck + pretty (SUS16bit sa s2k iv bs) = + pretty "SUS16bit" + <+> pretty sa + <+> pretty s2k + <+> pretty iv + <+> pretty (bsToHexUpper bs) + pretty (SUSSHA1 sa s2k iv bs) = + pretty "SUSSHA1" + <+> pretty sa + <+> pretty s2k + <+> pretty iv + <+> pretty (bsToHexUpper bs) + pretty (SUSAEAD sa aa s2k iv bs) = + pretty "SUSAEAD" + <+> pretty sa + <+> pretty aa + <+> pretty s2k + <+> pretty iv + <+> pretty (bsToHexUpper bs) + pretty (SUSym sa iv bs) = + pretty "SUSym" + <+> pretty sa + <+> pretty iv + <+> pretty (bsToHexUpper bs) + pretty (SUUnencrypted s ck) = + pretty "SUUnencrypted" <+> pretty s <+> pretty ck instance A.ToJSON SKAddendum where - toJSON (SUS16bit sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs) - toJSON (SUSSHA1 sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs) - toJSON (SUSAEAD sa aa s2k iv bs) = A.toJSON (sa, aa, s2k, iv, BL.unpack bs) - toJSON (SUSym sa iv bs) = A.toJSON (sa, iv, BL.unpack bs) - toJSON (SUUnencrypted s ck) = A.toJSON (s, ck) + toJSON (SUS16bit sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs) + toJSON (SUSSHA1 sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs) + toJSON (SUSAEAD sa aa s2k iv bs) = A.toJSON (sa, aa, s2k, iv, BL.unpack bs) + toJSON (SUSym sa iv bs) = A.toJSON (sa, iv, BL.unpack bs) + toJSON (SUUnencrypted s ck) = A.toJSON (s, ck) class LegacyKeyVersion (v :: KeyVersion) @@ -407,65 +391,65 @@ instance LegacyKeyVersion 'V4 data SKAddendumV (v :: KeyVersion) where - SKA16bit :: - LegacyKeyVersion v - => SymmetricAlgorithm - -> S2K - -> IV - -> ByteString - -> SKAddendumV v - SKASHA1Legacy :: - LegacyKeyVersion v - => SymmetricAlgorithm - -> S2K - -> IV - -> ByteString - -> SKAddendumV v - SKASHA1V6 :: - SymmetricAlgorithm - -> S2K - -> IV - -> ByteString - -> SKAddendumV 'V6 - SKAAEADV6 :: - SymmetricAlgorithm - -> AEADAlgorithm - -> S2K - -> IV - -> ByteString - -> SKAddendumV 'V6 - SKAAEADLegacy :: - LegacyKeyVersion v - => SymmetricAlgorithm - -> AEADAlgorithm - -> S2K - -> IV - -> ByteString - -> SKAddendumV v - SKASymLegacy :: - LegacyKeyVersion v - => SymmetricAlgorithm - -> IV - -> ByteString - -> SKAddendumV v - SKASymV6 :: - SymmetricAlgorithm - -> IV - -> ByteString - -> SKAddendumV 'V6 - SKAUnencryptedLegacy :: - LegacyKeyVersion v - => SKey - -> Word16 - -> SKAddendumV v - SKAUnencryptedV6 :: - SKey - -> SKAddendumV 'V6 + SKA16bit + :: (LegacyKeyVersion v) + => SymmetricAlgorithm + -> S2K + -> IV + -> ByteString + -> SKAddendumV v + SKASHA1Legacy + :: (LegacyKeyVersion v) + => SymmetricAlgorithm + -> S2K + -> IV + -> ByteString + -> SKAddendumV v + SKASHA1V6 + :: SymmetricAlgorithm + -> S2K + -> IV + -> ByteString + -> SKAddendumV 'V6 + SKAAEADV6 + :: SymmetricAlgorithm + -> AEADAlgorithm + -> S2K + -> IV + -> ByteString + -> SKAddendumV 'V6 + SKAAEADLegacy + :: (LegacyKeyVersion v) + => SymmetricAlgorithm + -> AEADAlgorithm + -> S2K + -> IV + -> ByteString + -> SKAddendumV v + SKASymLegacy + :: (LegacyKeyVersion v) + => SymmetricAlgorithm + -> IV + -> ByteString + -> SKAddendumV v + SKASymV6 + :: SymmetricAlgorithm + -> IV + -> ByteString + -> SKAddendumV 'V6 + SKAUnencryptedLegacy + :: (LegacyKeyVersion v) + => SKey + -> Word16 + -> SKAddendumV v + SKAUnencryptedV6 + :: SKey + -> SKAddendumV 'V6 deriving instance Show (SKAddendumV v) data SomeSKAddendumV where - SomeSKAddendumV :: SKAddendumV v -> SomeSKAddendumV + SomeSKAddendumV :: SKAddendumV v -> SomeSKAddendumV deriving instance Show SomeSKAddendumV @@ -480,44 +464,69 @@ toSKAddendum (SKAUnencryptedLegacy sk checksum) = SUUnencrypted sk checksum toSKAddendum (SKAUnencryptedV6 sk) = SUUnencrypted sk 0 -fromSKAddendumForKeyVersion :: - KeyVersion - -> SKAddendum - -> Either String SomeSKAddendumV +fromSKAddendumForKeyVersion + :: KeyVersion + -> SKAddendum + -> Either String SomeSKAddendumV fromSKAddendumForKeyVersion DeprecatedV3 (SUS16bit sa s2k iv bs) = - Right (SomeSKAddendumV (SKA16bit sa s2k iv bs :: SKAddendumV 'DeprecatedV3)) + Right + ( SomeSKAddendumV + (SKA16bit sa s2k iv bs :: SKAddendumV 'DeprecatedV3) + ) fromSKAddendumForKeyVersion DeprecatedV3 (SUSSHA1 sa s2k iv bs) = - Right (SomeSKAddendumV (SKASHA1Legacy sa s2k iv bs :: SKAddendumV 'DeprecatedV3)) + Right + ( SomeSKAddendumV + (SKASHA1Legacy sa s2k iv bs :: SKAddendumV 'DeprecatedV3) + ) fromSKAddendumForKeyVersion DeprecatedV3 (SUSym sa iv bs) = - Right (SomeSKAddendumV (SKASymLegacy sa iv bs :: SKAddendumV 'DeprecatedV3)) + Right + ( SomeSKAddendumV + (SKASymLegacy sa iv bs :: SKAddendumV 'DeprecatedV3) + ) fromSKAddendumForKeyVersion DeprecatedV3 (SUUnencrypted sk checksum) = - Right (SomeSKAddendumV (SKAUnencryptedLegacy sk checksum :: SKAddendumV 'DeprecatedV3)) + Right + ( SomeSKAddendumV + (SKAUnencryptedLegacy sk checksum :: SKAddendumV 'DeprecatedV3) + ) fromSKAddendumForKeyVersion DeprecatedV3 (SUSAEAD sa aa s2k iv bs) = - Right (SomeSKAddendumV (SKAAEADLegacy sa aa s2k iv bs :: SKAddendumV 'DeprecatedV3)) + Right + ( SomeSKAddendumV + (SKAAEADLegacy sa aa s2k iv bs :: SKAddendumV 'DeprecatedV3) + ) fromSKAddendumForKeyVersion V4 (SUS16bit sa s2k iv bs) = - Right (SomeSKAddendumV (SKA16bit sa s2k iv bs :: SKAddendumV 'V4)) + Right + (SomeSKAddendumV (SKA16bit sa s2k iv bs :: SKAddendumV 'V4)) fromSKAddendumForKeyVersion V4 (SUSSHA1 sa s2k iv bs) = - Right (SomeSKAddendumV (SKASHA1Legacy sa s2k iv bs :: SKAddendumV 'V4)) + Right + (SomeSKAddendumV (SKASHA1Legacy sa s2k iv bs :: SKAddendumV 'V4)) fromSKAddendumForKeyVersion V4 (SUSym sa iv bs) = - Right (SomeSKAddendumV (SKASymLegacy sa iv bs :: SKAddendumV 'V4)) + Right + (SomeSKAddendumV (SKASymLegacy sa iv bs :: SKAddendumV 'V4)) fromSKAddendumForKeyVersion V4 (SUUnencrypted sk checksum) = - Right (SomeSKAddendumV (SKAUnencryptedLegacy sk checksum :: SKAddendumV 'V4)) + Right + ( SomeSKAddendumV + (SKAUnencryptedLegacy sk checksum :: SKAddendumV 'V4) + ) fromSKAddendumForKeyVersion V4 (SUSAEAD sa aa s2k iv bs) = - Right (SomeSKAddendumV (SKAAEADLegacy sa aa s2k iv bs :: SKAddendumV 'V4)) + Right + ( SomeSKAddendumV + (SKAAEADLegacy sa aa s2k iv bs :: SKAddendumV 'V4) + ) fromSKAddendumForKeyVersion V6 (SUS16bit _ _ _ _) = - Left "v6 secret keys must not use 16-bit checksum protected secret key addendums" + Left + "v6 secret keys must not use 16-bit checksum protected secret key addendums" fromSKAddendumForKeyVersion V6 (SUSSHA1 sa s2k iv bs) = - Right (SomeSKAddendumV (SKASHA1V6 sa s2k iv bs)) + Right (SomeSKAddendumV (SKASHA1V6 sa s2k iv bs)) fromSKAddendumForKeyVersion V6 (SUSAEAD sa aa s2k iv bs) = - Right (SomeSKAddendumV (SKAAEADV6 sa aa s2k iv bs)) + Right (SomeSKAddendumV (SKAAEADV6 sa aa s2k iv bs)) fromSKAddendumForKeyVersion V6 (SUSym sa iv bs) = - Right (SomeSKAddendumV (SKASymV6 sa iv bs)) + Right (SomeSKAddendumV (SKASymV6 sa iv bs)) fromSKAddendumForKeyVersion V6 (SUUnencrypted sk _) = - Right (SomeSKAddendumV (SKAUnencryptedV6 sk)) + Right (SomeSKAddendumV (SKAUnencryptedV6 sk)) -fromSKAddendumForPKPayload :: - SomePKPayload - -> SKAddendum - -> Either String SomeSKAddendumV +fromSKAddendumForPKPayload + :: SomePKPayload + -> SKAddendum + -> Either String SomeSKAddendumV fromSKAddendumForPKPayload pkp = - fromSKAddendumForKeyVersion (_keyVersion pkp) + fromSKAddendumForKeyVersion (_keyVersion pkp) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs b/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs @@ -2,7 +2,6 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -16,588 +15,645 @@ module Codec.Encryption.OpenPGP.Types.Internal.PacketClass where -import Codec.Encryption.OpenPGP.Types.Internal.Base -import Codec.Encryption.OpenPGP.Types.Internal.PKITypes -import Codec.Encryption.OpenPGP.Types.Internal.Pkt - import Control.Lens (makeLenses) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Data (Data) +import qualified Data.Kind import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Word (Word8) -import qualified Data.Kind -import Prettyprinter (Pretty(..)) +import Prettyprinter (Pretty (..)) +import Codec.Encryption.OpenPGP.Types.Internal.Base +import Codec.Encryption.OpenPGP.Types.Internal.PKITypes +import Codec.Encryption.OpenPGP.Types.Internal.Pkt + class Packet a where - data PacketType a :: Data.Kind.Type - packetType :: a -> PacketType a - packetCode :: PacketType a -> Word8 - dynamicPacketCode :: a -> Word8 - toPkt :: a -> Pkt - fromPktMaybe :: Pkt -> Maybe a - fromPktEither :: Pkt -> Either String a - - fromPktMaybe = either (const Nothing) Just . fromPktEither - dynamicPacketCode = packetCode . packetType + data PacketType a :: Data.Kind.Type + packetType :: a -> PacketType a + packetCode :: PacketType a -> Word8 + dynamicPacketCode :: a -> Word8 + toPkt :: a -> Pkt + fromPktMaybe :: Pkt -> Maybe a + fromPktEither :: Pkt -> Either String a + fromPktMaybe = either (const Nothing) Just . fromPktEither + dynamicPacketCode = packetCode . packetType + coercionError :: String -> Pkt -> Either String a coercionError expected pkt = - Left - ("Cannot coerce non-" ++ - expected ++ " packet (tag " ++ show (pktTag pkt) ++ ")") + Left + ( "Cannot coerce non-" + ++ expected + ++ " packet (tag " + ++ show (pktTag pkt) + ++ ")" + ) data PKESK (v :: PKESKPayloadVersion) where - PKESK3Packet :: - PacketVersion - -> EightOctetKeyId - -> PubKeyAlgorithm - -> NonEmpty MPI - -> PKESK 'PKESKV3 - PKESK6Packet :: - BL.ByteString - -> PubKeyAlgorithm - -> BL.ByteString - -> PKESK 'PKESKV6 + PKESK3Packet + :: PacketVersion + -> EightOctetKeyId + -> PubKeyAlgorithm + -> NonEmpty MPI + -> PKESK 'PKESKV3 + PKESK6Packet + :: BL.ByteString + -> PubKeyAlgorithm + -> BL.ByteString + -> PKESK 'PKESKV6 deriving instance Eq (PKESK v) deriving instance Show (PKESK v) instance Packet (PKESK 'PKESKV3) where - data PacketType (PKESK 'PKESKV3) = PKESKType - deriving (Show, Eq) - packetType _ = PKESKType - packetCode _ = 1 - toPkt (PKESK3Packet version keyid pka mpis) = - PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 version keyid pka mpis)) - fromPktEither (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ keyid pka mpis))) = - Right (PKESK3Packet 3 keyid pka mpis) - fromPktEither (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ _ _))) = - Left "Cannot coerce PKESKv6 packet to PKESKv3" - fromPktEither pkt = coercionError "PKESK" pkt + data PacketType (PKESK 'PKESKV3) = PKESKType + deriving (Eq, Show) + packetType _ = PKESKType + packetCode _ = 1 + toPkt (PKESK3Packet version keyid pka mpis) = + PKESKPkt + (PKESKPayloadV3Packet (PKESKPayloadV3 version keyid pka mpis)) + fromPktEither (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ keyid pka mpis))) = + Right (PKESK3Packet 3 keyid pka mpis) + fromPktEither (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ _ _))) = + Left "Cannot coerce PKESKv6 packet to PKESKv3" + fromPktEither pkt = coercionError "PKESK" pkt instance Pretty (PKESK 'PKESKV3) where - pretty = pretty . toPkt + pretty = pretty . toPkt instance Packet (PKESK 'PKESKV6) where - data PacketType (PKESK 'PKESKV6) = PKESK6Type - deriving (Show, Eq) - packetType _ = PKESK6Type - packetCode _ = 1 - toPkt (PKESK6Packet recipientKeyIdentifier pka esk) = - PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier pka esk)) - fromPktEither (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier pka esk))) = - Right (PKESK6Packet recipientKeyIdentifier pka esk) - fromPktEither (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ _ _))) = - Left "Cannot coerce PKESKv3 packet to PKESKv6" - fromPktEither pkt = coercionError "PKESKv6" pkt + data PacketType (PKESK 'PKESKV6) = PKESK6Type + deriving (Eq, Show) + packetType _ = PKESK6Type + packetCode _ = 1 + toPkt (PKESK6Packet recipientKeyIdentifier pka esk) = + PKESKPkt + ( PKESKPayloadV6Packet + (PKESKPayloadV6 recipientKeyIdentifier pka esk) + ) + fromPktEither + ( PKESKPkt + ( PKESKPayloadV6Packet + (PKESKPayloadV6 recipientKeyIdentifier pka esk) + ) + ) = + Right (PKESK6Packet recipientKeyIdentifier pka esk) + fromPktEither (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ _ _))) = + Left "Cannot coerce PKESKv3 packet to PKESKv6" + fromPktEither pkt = coercionError "PKESKv6" pkt instance Pretty (PKESK 'PKESKV6) where - pretty = pretty . toPkt + pretty = pretty . toPkt -newtype Signature = - Signature +newtype Signature + = Signature { _signaturePayload :: SignaturePayload } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet Signature where - data PacketType Signature = SignatureType - deriving (Show, Eq) - packetType _ = SignatureType - packetCode _ = 2 - toPkt (Signature a) = SignaturePkt a - fromPktMaybe (SignaturePkt a) = Just (Signature a) - fromPktMaybe _ = Nothing - fromPktEither (SignaturePkt a) = Right (Signature a) - fromPktEither pkt = coercionError "Signature" pkt + data PacketType Signature = SignatureType + deriving (Eq, Show) + packetType _ = SignatureType + packetCode _ = 2 + toPkt (Signature a) = SignaturePkt a + fromPktMaybe (SignaturePkt a) = Just (Signature a) + fromPktMaybe _ = Nothing + fromPktEither (SignaturePkt a) = Right (Signature a) + fromPktEither pkt = coercionError "Signature" pkt instance Pretty Signature where - pretty = pretty . toPkt + pretty = pretty . toPkt data SignatureV (v :: SignaturePayloadVersion) where - SignatureV3Packet :: SignaturePayloadV 'SigPayloadV3 -> SignatureV 'SigPayloadV3 - SignatureV4Packet :: SignaturePayloadV 'SigPayloadV4 -> SignatureV 'SigPayloadV4 - SignatureV6Packet :: SignaturePayloadV 'SigPayloadV6 -> SignatureV 'SigPayloadV6 - SignatureVOtherPacket :: SignaturePayloadV 'SigPayloadVOther -> SignatureV 'SigPayloadVOther + SignatureV3Packet + :: SignaturePayloadV 'SigPayloadV3 -> SignatureV 'SigPayloadV3 + SignatureV4Packet + :: SignaturePayloadV 'SigPayloadV4 -> SignatureV 'SigPayloadV4 + SignatureV6Packet + :: SignaturePayloadV 'SigPayloadV6 -> SignatureV 'SigPayloadV6 + SignatureVOtherPacket + :: SignaturePayloadV 'SigPayloadVOther + -> SignatureV 'SigPayloadVOther deriving instance Eq (SignatureV v) deriving instance Show (SignatureV v) data SomeSignatureV where - SomeSignatureV :: SignatureV v -> SomeSignatureV + SomeSignatureV :: SignatureV v -> SomeSignatureV -signaturePayloadFromSignatureV :: SignatureV v -> SignaturePayload +signaturePayloadFromSignatureV + :: SignatureV v -> SignaturePayload signaturePayloadFromSignatureV (SignatureV3Packet payload) = toSignaturePayload payload signaturePayloadFromSignatureV (SignatureV4Packet payload) = toSignaturePayload payload signaturePayloadFromSignatureV (SignatureV6Packet payload) = toSignaturePayload payload signaturePayloadFromSignatureV (SignatureVOtherPacket payload) = toSignaturePayload payload -fromPktEitherSomeSignatureV :: Pkt -> Either String SomeSignatureV +fromPktEitherSomeSignatureV + :: Pkt -> Either String SomeSignatureV fromPktEitherSomeSignatureV (SignaturePkt payload) = - Right (someSignatureVFromPayload payload) + Right (someSignatureVFromPayload payload) fromPktEitherSomeSignatureV pkt = - coercionError "Signature" pkt + coercionError "Signature" pkt someSignatureVFromPayload :: SignaturePayload -> SomeSignatureV someSignatureVFromPayload payload = - case toSomeSignaturePayload payload of - SomeSignaturePayload (typedPayload@SigPayloadV3Data {}) -> - SomeSignatureV (SignatureV3Packet typedPayload) - SomeSignaturePayload (typedPayload@SigPayloadV4Data {}) -> - SomeSignatureV (SignatureV4Packet typedPayload) - SomeSignaturePayload (typedPayload@SigPayloadV6Data {}) -> - SomeSignatureV (SignatureV6Packet typedPayload) - SomeSignaturePayload (typedPayload@SigPayloadOtherData {}) -> - SomeSignatureV (SignatureVOtherPacket typedPayload) + case toSomeSignaturePayload payload of + SomeSignaturePayload (typedPayload@SigPayloadV3Data {}) -> + SomeSignatureV (SignatureV3Packet typedPayload) + SomeSignaturePayload (typedPayload@SigPayloadV4Data {}) -> + SomeSignatureV (SignatureV4Packet typedPayload) + SomeSignaturePayload (typedPayload@SigPayloadV6Data {}) -> + SomeSignatureV (SignatureV6Packet typedPayload) + SomeSignaturePayload (typedPayload@SigPayloadOtherData {}) -> + SomeSignatureV (SignatureVOtherPacket typedPayload) instance Packet (SignatureV 'SigPayloadV3) where - data PacketType (SignatureV 'SigPayloadV3) = SignatureV3Type - deriving (Show, Eq) - packetType _ = SignatureV3Type - packetCode _ = 2 - toPkt = SignaturePkt . signaturePayloadFromSignatureV - fromPktEither (SignaturePkt payload) = - SignatureV3Packet <$> asSignaturePayloadV3 payload - fromPktEither pkt = coercionError "SignatureV3" pkt + data PacketType (SignatureV 'SigPayloadV3) = SignatureV3Type + deriving (Eq, Show) + packetType _ = SignatureV3Type + packetCode _ = 2 + toPkt = SignaturePkt . signaturePayloadFromSignatureV + fromPktEither (SignaturePkt payload) = + SignatureV3Packet <$> asSignaturePayloadV3 payload + fromPktEither pkt = coercionError "SignatureV3" pkt instance Pretty (SignatureV 'SigPayloadV3) where - pretty = pretty . toPkt + pretty = pretty . toPkt instance Packet (SignatureV 'SigPayloadV4) where - data PacketType (SignatureV 'SigPayloadV4) = SignatureV4Type - deriving (Show, Eq) - packetType _ = SignatureV4Type - packetCode _ = 2 - toPkt = SignaturePkt . signaturePayloadFromSignatureV - fromPktEither (SignaturePkt payload) = - SignatureV4Packet <$> asSignaturePayloadV4 payload - fromPktEither pkt = coercionError "SignatureV4" pkt + data PacketType (SignatureV 'SigPayloadV4) = SignatureV4Type + deriving (Eq, Show) + packetType _ = SignatureV4Type + packetCode _ = 2 + toPkt = SignaturePkt . signaturePayloadFromSignatureV + fromPktEither (SignaturePkt payload) = + SignatureV4Packet <$> asSignaturePayloadV4 payload + fromPktEither pkt = coercionError "SignatureV4" pkt instance Pretty (SignatureV 'SigPayloadV4) where - pretty = pretty . toPkt + pretty = pretty . toPkt instance Packet (SignatureV 'SigPayloadV6) where - data PacketType (SignatureV 'SigPayloadV6) = SignatureV6Type - deriving (Show, Eq) - packetType _ = SignatureV6Type - packetCode _ = 2 - toPkt = SignaturePkt . signaturePayloadFromSignatureV - fromPktEither (SignaturePkt payload) = - SignatureV6Packet <$> asSignaturePayloadV6 payload - fromPktEither pkt = coercionError "SignatureV6" pkt + data PacketType (SignatureV 'SigPayloadV6) = SignatureV6Type + deriving (Eq, Show) + packetType _ = SignatureV6Type + packetCode _ = 2 + toPkt = SignaturePkt . signaturePayloadFromSignatureV + fromPktEither (SignaturePkt payload) = + SignatureV6Packet <$> asSignaturePayloadV6 payload + fromPktEither pkt = coercionError "SignatureV6" pkt instance Pretty (SignatureV 'SigPayloadV6) where - pretty = pretty . toPkt + pretty = pretty . toPkt instance Packet (SignatureV 'SigPayloadVOther) where - data PacketType (SignatureV 'SigPayloadVOther) = SignatureVOtherType - deriving (Show, Eq) - packetType _ = SignatureVOtherType - packetCode _ = 2 - toPkt = SignaturePkt . signaturePayloadFromSignatureV - fromPktEither (SignaturePkt payload) = - SignatureVOtherPacket <$> asSignaturePayloadOther payload - fromPktEither pkt = coercionError "SignatureVOther" pkt + data PacketType (SignatureV 'SigPayloadVOther) = SignatureVOtherType + deriving (Eq, Show) + packetType _ = SignatureVOtherType + packetCode _ = 2 + toPkt = SignaturePkt . signaturePayloadFromSignatureV + fromPktEither (SignaturePkt payload) = + SignatureVOtherPacket <$> asSignaturePayloadOther payload + fromPktEither pkt = coercionError "SignatureVOther" pkt instance Pretty (SignatureV 'SigPayloadVOther) where - pretty = pretty . toPkt + pretty = pretty . toPkt data SKESK (v :: SKESKPayloadVersion) where - SKESK4Packet :: - SymmetricAlgorithm - -> S2K - -> Maybe BL.ByteString - -> SKESK 'SKESKV4 - SKESK6Packet :: - SymmetricAlgorithm - -> AEADAlgorithm - -> S2K - -> BL.ByteString - -> BL.ByteString - -> BL.ByteString - -> SKESK 'SKESKV6 + SKESK4Packet + :: SymmetricAlgorithm + -> S2K + -> Maybe BL.ByteString + -> SKESK 'SKESKV4 + SKESK6Packet + :: SymmetricAlgorithm + -> AEADAlgorithm + -> S2K + -> BL.ByteString + -> BL.ByteString + -> BL.ByteString + -> SKESK 'SKESKV6 deriving instance Eq (SKESK v) deriving instance Show (SKESK v) instance Packet (SKESK 'SKESKV4) where - data PacketType (SKESK 'SKESKV4) = SKESKType - deriving (Show, Eq) - packetType _ = SKESKType - packetCode _ = 3 - toPkt (SKESK4Packet symalgo s2k esk) = - SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 symalgo s2k esk)) - fromPktEither (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 symalgo s2k esk))) = - Right (SKESK4Packet symalgo s2k esk) - fromPktEither (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ _ _ _ _))) = - Left "Cannot coerce SKESKv6 packet to SKESKv4" - fromPktEither pkt = coercionError "SKESK" pkt + data PacketType (SKESK 'SKESKV4) = SKESKType + deriving (Eq, Show) + packetType _ = SKESKType + packetCode _ = 3 + toPkt (SKESK4Packet symalgo s2k esk) = + SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 symalgo s2k esk)) + fromPktEither (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 symalgo s2k esk))) = + Right (SKESK4Packet symalgo s2k esk) + fromPktEither (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ _ _ _ _))) = + Left "Cannot coerce SKESKv6 packet to SKESKv4" + fromPktEither pkt = coercionError "SKESK" pkt instance Pretty (SKESK 'SKESKV4) where - pretty = pretty . toPkt + pretty = pretty . toPkt instance Packet (SKESK 'SKESKV6) where - data PacketType (SKESK 'SKESKV6) = SKESK6Type - deriving (Show, Eq) - packetType _ = SKESK6Type - packetCode _ = 3 - toPkt (SKESK6Packet symalgo aead s2k iv esk tag) = - SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 symalgo aead s2k iv esk tag)) - fromPktEither (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 symalgo aead s2k iv esk tag))) = - Right (SKESK6Packet symalgo aead s2k iv esk tag) - fromPktEither (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ _ _))) = - Left "Cannot coerce SKESKv4 packet to SKESKv6" - fromPktEither pkt = coercionError "SKESKv6" pkt + data PacketType (SKESK 'SKESKV6) = SKESK6Type + deriving (Eq, Show) + packetType _ = SKESK6Type + packetCode _ = 3 + toPkt (SKESK6Packet symalgo aead s2k iv esk tag) = + SKESKPkt + (SKESKPayloadV6Packet (SKESKPayloadV6 symalgo aead s2k iv esk tag)) + fromPktEither + ( SKESKPkt + (SKESKPayloadV6Packet (SKESKPayloadV6 symalgo aead s2k iv esk tag)) + ) = + Right (SKESK6Packet symalgo aead s2k iv esk tag) + fromPktEither (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ _ _))) = + Left "Cannot coerce SKESKv4 packet to SKESKv6" + fromPktEither pkt = coercionError "SKESKv6" pkt instance Pretty (SKESK 'SKESKV6) where - pretty = pretty . toPkt + pretty = pretty . toPkt data OnePassSignature (v :: OnePassSignatureVersion) where - OnePassSignatureV3Packet :: - PacketVersion - -> SigType - -> HashAlgorithm - -> PubKeyAlgorithm - -> EightOctetKeyId - -> NestedFlag - -> OnePassSignature 'OPSV3 - OnePassSignatureV6Packet :: - SigType - -> HashAlgorithm - -> PubKeyAlgorithm - -> SignatureSalt - -> ByteString - -> NestedFlag - -> OnePassSignature 'OPSV6 + OnePassSignatureV3Packet + :: PacketVersion + -> SigType + -> HashAlgorithm + -> PubKeyAlgorithm + -> EightOctetKeyId + -> NestedFlag + -> OnePassSignature 'OPSV3 + OnePassSignatureV6Packet + :: SigType + -> HashAlgorithm + -> PubKeyAlgorithm + -> SignatureSalt + -> ByteString + -> NestedFlag + -> OnePassSignature 'OPSV6 deriving instance Eq (OnePassSignature v) deriving instance Show (OnePassSignature v) instance Packet (OnePassSignature 'OPSV3) where - data PacketType (OnePassSignature 'OPSV3) = OnePassSignatureType - deriving (Show, Eq) - packetType _ = OnePassSignatureType - packetCode _ = 4 - toPkt (OnePassSignatureV3Packet a b c d e f) = - OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 a b c d e f)) - fromPktEither (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 a b c d e f))) = - Right (OnePassSignatureV3Packet a b c d e f) - fromPktEither pkt = coercionError "OnePassSignature" pkt + data PacketType (OnePassSignature 'OPSV3) = OnePassSignatureType + deriving (Eq, Show) + packetType _ = OnePassSignatureType + packetCode _ = 4 + toPkt (OnePassSignatureV3Packet a b c d e f) = + OnePassSignaturePkt + (OPSPayloadV3Packet (OPSPayloadV3 a b c d e f)) + fromPktEither + ( OnePassSignaturePkt + (OPSPayloadV3Packet (OPSPayloadV3 a b c d e f)) + ) = + Right (OnePassSignatureV3Packet a b c d e f) + fromPktEither pkt = coercionError "OnePassSignature" pkt instance Pretty (OnePassSignature 'OPSV3) where - pretty = pretty . toPkt + pretty = pretty . toPkt instance Packet (OnePassSignature 'OPSV6) where - data PacketType (OnePassSignature 'OPSV6) = OnePassSignatureV6Type - deriving (Show, Eq) - packetType _ = OnePassSignatureV6Type - packetCode _ = 4 - toPkt (OnePassSignatureV6Packet a b c d e f) = - OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 a b c d e f)) - fromPktEither (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 a b c d e f))) = - Right (OnePassSignatureV6Packet a b c d e f) - fromPktEither pkt = coercionError "OnePassSignatureV6" pkt + data PacketType (OnePassSignature 'OPSV6) = OnePassSignatureV6Type + deriving (Eq, Show) + packetType _ = OnePassSignatureV6Type + packetCode _ = 4 + toPkt (OnePassSignatureV6Packet a b c d e f) = + OnePassSignaturePkt + (OPSPayloadV6Packet (OPSPayloadV6 a b c d e f)) + fromPktEither + ( OnePassSignaturePkt + (OPSPayloadV6Packet (OPSPayloadV6 a b c d e f)) + ) = + Right (OnePassSignatureV6Packet a b c d e f) + fromPktEither pkt = coercionError "OnePassSignatureV6" pkt instance Pretty (OnePassSignature 'OPSV6) where - pretty = pretty . toPkt + pretty = pretty . toPkt -data SecretKey = - SecretKey +data SecretKey + = SecretKey { _secretKeyPKPayload :: SomePKPayload , _secretKeySKAddendum :: SKAddendum } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet SecretKey where - data PacketType SecretKey = SecretKeyType - deriving (Show, Eq) - packetType _ = SecretKeyType - packetCode _ = 5 - toPkt (SecretKey a b) = SecretKeyPkt a b - fromPktEither (SecretKeyPkt a b) = Right (SecretKey a b) - fromPktEither pkt = coercionError "SecretKey" pkt + data PacketType SecretKey = SecretKeyType + deriving (Eq, Show) + packetType _ = SecretKeyType + packetCode _ = 5 + toPkt (SecretKey a b) = SecretKeyPkt a b + fromPktEither (SecretKeyPkt a b) = Right (SecretKey a b) + fromPktEither pkt = coercionError "SecretKey" pkt instance Pretty SecretKey where - pretty = pretty . toPkt + pretty = pretty . toPkt -newtype PublicKey = - PublicKey +newtype PublicKey + = PublicKey { _publicKeyPKPayload :: SomePKPayload } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet PublicKey where - data PacketType PublicKey = PublicKeyType - deriving (Show, Eq) - packetType _ = PublicKeyType - packetCode _ = 6 - toPkt (PublicKey a) = PublicKeyPkt a - fromPktEither (PublicKeyPkt a) = Right (PublicKey a) - fromPktEither pkt = coercionError "PublicKey" pkt + data PacketType PublicKey = PublicKeyType + deriving (Eq, Show) + packetType _ = PublicKeyType + packetCode _ = 6 + toPkt (PublicKey a) = PublicKeyPkt a + fromPktEither (PublicKeyPkt a) = Right (PublicKey a) + fromPktEither pkt = coercionError "PublicKey" pkt instance Pretty PublicKey where - pretty = pretty . toPkt + pretty = pretty . toPkt -data SecretSubkey = - SecretSubkey +data SecretSubkey + = SecretSubkey { _secretSubkeyPKPayload :: SomePKPayload , _secretSubkeySKAddendum :: SKAddendum } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet SecretSubkey where - data PacketType SecretSubkey = SecretSubkeyType - deriving (Show, Eq) - packetType _ = SecretSubkeyType - packetCode _ = 7 - toPkt (SecretSubkey a b) = SecretSubkeyPkt a b - fromPktEither (SecretSubkeyPkt a b) = Right (SecretSubkey a b) - fromPktEither pkt = coercionError "SecretSubkey" pkt + data PacketType SecretSubkey = SecretSubkeyType + deriving (Eq, Show) + packetType _ = SecretSubkeyType + packetCode _ = 7 + toPkt (SecretSubkey a b) = SecretSubkeyPkt a b + fromPktEither (SecretSubkeyPkt a b) = Right (SecretSubkey a b) + fromPktEither pkt = coercionError "SecretSubkey" pkt instance Pretty SecretSubkey where - pretty = pretty . toPkt + pretty = pretty . toPkt -data CompressedData = - CompressedData +data CompressedData + = CompressedData { _compressedDataCompressionAlgorithm :: CompressionAlgorithm , _compressedDataPayload :: CompressedDataPayload } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet CompressedData where - data PacketType CompressedData = CompressedDataType - deriving (Show, Eq) - packetType _ = CompressedDataType - packetCode _ = 8 - toPkt (CompressedData a b) = CompressedDataPkt a b - fromPktEither (CompressedDataPkt a b) = Right (CompressedData a b) - fromPktEither pkt = coercionError "CompressedData" pkt + data PacketType CompressedData = CompressedDataType + deriving (Eq, Show) + packetType _ = CompressedDataType + packetCode _ = 8 + toPkt (CompressedData a b) = CompressedDataPkt a b + fromPktEither (CompressedDataPkt a b) = Right (CompressedData a b) + fromPktEither pkt = coercionError "CompressedData" pkt instance Pretty CompressedData where - pretty = pretty . toPkt + pretty = pretty . toPkt -newtype SymEncData = - SymEncData +newtype SymEncData + = SymEncData { _symEncDataPayload :: ByteString } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet SymEncData where - data PacketType SymEncData = SymEncDataType - deriving (Show, Eq) - packetType _ = SymEncDataType - packetCode _ = 9 - toPkt (SymEncData a) = SymEncDataPkt a - fromPktEither (SymEncDataPkt a) = Right (SymEncData a) - fromPktEither pkt = coercionError "SymEncData" pkt + data PacketType SymEncData = SymEncDataType + deriving (Eq, Show) + packetType _ = SymEncDataType + packetCode _ = 9 + toPkt (SymEncData a) = SymEncDataPkt a + fromPktEither (SymEncDataPkt a) = Right (SymEncData a) + fromPktEither pkt = coercionError "SymEncData" pkt instance Pretty SymEncData where - pretty = pretty . toPkt + pretty = pretty . toPkt -newtype Marker = - Marker +newtype Marker + = Marker { _markerPayload :: ByteString } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet Marker where - data PacketType Marker = MarkerType - deriving (Show, Eq) - packetType _ = MarkerType - packetCode _ = 10 - toPkt (Marker a) = MarkerPkt a - fromPktEither (MarkerPkt a) = Right (Marker a) - fromPktEither pkt = coercionError "Marker" pkt + data PacketType Marker = MarkerType + deriving (Eq, Show) + packetType _ = MarkerType + packetCode _ = 10 + toPkt (Marker a) = MarkerPkt a + fromPktEither (MarkerPkt a) = Right (Marker a) + fromPktEither pkt = coercionError "Marker" pkt instance Pretty Marker where - pretty = pretty . toPkt + pretty = pretty . toPkt -data LiteralData = - LiteralData - { _literalDataDataType :: DataType +data LiteralData + = LiteralData + { _literalDataDataType :: LiteralDataType , _literalDataFileName :: FileName , _literalDataTimeStamp :: ThirtyTwoBitTimeStamp , _literalDataPayload :: ByteString } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet LiteralData where - data PacketType LiteralData = LiteralDataType - deriving (Show, Eq) - packetType _ = LiteralDataType - packetCode _ = 11 - toPkt (LiteralData a b c d) = LiteralDataPkt a b c d - fromPktEither (LiteralDataPkt a b c d) = Right (LiteralData a b c d) - fromPktEither pkt = coercionError "LiteralData" pkt + data PacketType LiteralData = LiteralDataType + deriving (Eq, Show) + packetType _ = LiteralDataType + packetCode _ = 11 + toPkt (LiteralData a b c d) = LiteralDataPkt a b c d + fromPktEither (LiteralDataPkt a b c d) = Right (LiteralData a b c d) + fromPktEither pkt = coercionError "LiteralData" pkt instance Pretty LiteralData where - pretty = pretty . toPkt + pretty = pretty . toPkt -newtype Trust = - Trust +newtype Trust + = Trust { _trustPayload :: ByteString } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet Trust where - data PacketType Trust = TrustType - deriving (Show, Eq) - packetType _ = TrustType - packetCode _ = 12 - toPkt (Trust a) = TrustPkt a - fromPktEither (TrustPkt a) = Right (Trust a) - fromPktEither pkt = coercionError "Trust" pkt + data PacketType Trust = TrustType + deriving (Eq, Show) + packetType _ = TrustType + packetCode _ = 12 + toPkt (Trust a) = TrustPkt a + fromPktEither (TrustPkt a) = Right (Trust a) + fromPktEither pkt = coercionError "Trust" pkt instance Pretty Trust where - pretty = pretty . toPkt + pretty = pretty . toPkt -newtype UserId = - UserId +newtype UserId + = UserId { _userIdPayload :: Text } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet UserId where - data PacketType UserId = UserIdType - deriving (Show, Eq) - packetType _ = UserIdType - packetCode _ = 13 - toPkt (UserId a) = UserIdPkt a - fromPktEither (UserIdPkt a) = Right (UserId a) - fromPktEither pkt = coercionError "UserId" pkt + data PacketType UserId = UserIdType + deriving (Eq, Show) + packetType _ = UserIdType + packetCode _ = 13 + toPkt (UserId a) = UserIdPkt a + fromPktEither (UserIdPkt a) = Right (UserId a) + fromPktEither pkt = coercionError "UserId" pkt instance Pretty UserId where - pretty = pretty . toPkt + pretty = pretty . toPkt -newtype PublicSubkey = - PublicSubkey +newtype PublicSubkey + = PublicSubkey { _publicSubkeyPKPayload :: SomePKPayload } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet PublicSubkey where - data PacketType PublicSubkey = PublicSubkeyType - deriving (Show, Eq) - packetType _ = PublicSubkeyType - packetCode _ = 14 - toPkt (PublicSubkey a) = PublicSubkeyPkt a - fromPktEither (PublicSubkeyPkt a) = Right (PublicSubkey a) - fromPktEither pkt = coercionError "PublicSubkey" pkt + data PacketType PublicSubkey = PublicSubkeyType + deriving (Eq, Show) + packetType _ = PublicSubkeyType + packetCode _ = 14 + toPkt (PublicSubkey a) = PublicSubkeyPkt a + fromPktEither (PublicSubkeyPkt a) = Right (PublicSubkey a) + fromPktEither pkt = coercionError "PublicSubkey" pkt instance Pretty PublicSubkey where - pretty = pretty . toPkt + pretty = pretty . toPkt -newtype UserAttribute = - UserAttribute +newtype UserAttribute + = UserAttribute { _userAttributeSubPackets :: [UserAttrSubPacket] } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet UserAttribute where - data PacketType UserAttribute = UserAttributeType - deriving (Show, Eq) - packetType _ = UserAttributeType - packetCode _ = 17 - toPkt (UserAttribute a) = UserAttributePkt a - fromPktEither (UserAttributePkt a) = Right (UserAttribute a) - fromPktEither pkt = coercionError "UserAttribute" pkt + data PacketType UserAttribute = UserAttributeType + deriving (Eq, Show) + packetType _ = UserAttributeType + packetCode _ = 17 + toPkt (UserAttribute a) = UserAttributePkt a + fromPktEither (UserAttributePkt a) = Right (UserAttribute a) + fromPktEither pkt = coercionError "UserAttribute" pkt instance Pretty UserAttribute where - pretty = pretty . toPkt + pretty = pretty . toPkt -data SymEncIntegrityProtectedData = - SymEncIntegrityProtectedData - { _symEncIntegrityProtectedDataPacketVersion :: PacketVersion - , _symEncIntegrityProtectedDataPayload :: ByteString - } - | SymEncIntegrityProtectedDataV2 - SymmetricAlgorithm - AEADAlgorithm - Word8 - Salt - ByteString - deriving (Data, Eq, Show, Typeable) +data SymEncIntegrityProtectedData + = SymEncIntegrityProtectedData + { _symEncIntegrityProtectedDataPacketVersion :: PacketVersion + , _symEncIntegrityProtectedDataPayload :: ByteString + } + | SymEncIntegrityProtectedDataV2 + SymmetricAlgorithm + AEADAlgorithm + Word8 + Salt + ByteString + deriving (Data, Eq, Show, Typeable) instance Packet SymEncIntegrityProtectedData where - data PacketType - SymEncIntegrityProtectedData = SymEncIntegrityProtectedDataType - deriving (Show, Eq) - packetType _ = SymEncIntegrityProtectedDataType - packetCode _ = 18 - toPkt (SymEncIntegrityProtectedData a b) = SymEncIntegrityProtectedDataPkt (SEIPD1 a b) - toPkt (SymEncIntegrityProtectedDataV2 a b c d e) = - SymEncIntegrityProtectedDataPkt (SEIPD2 a b c d e) - fromPktEither (SymEncIntegrityProtectedDataPkt (SEIPD1 a b)) = - Right (SymEncIntegrityProtectedData a b) - fromPktEither (SymEncIntegrityProtectedDataPkt (SEIPD2 a b c d e)) = - Right (SymEncIntegrityProtectedDataV2 a b c d e) - fromPktEither pkt = coercionError "SymEncIntegrityProtectedData" pkt + data + PacketType + SymEncIntegrityProtectedData + = SymEncIntegrityProtectedDataType + deriving (Eq, Show) + packetType _ = SymEncIntegrityProtectedDataType + packetCode _ = 18 + toPkt (SymEncIntegrityProtectedData a b) = SymEncIntegrityProtectedDataPkt (SEIPD1 a b) + toPkt (SymEncIntegrityProtectedDataV2 a b c d e) = + SymEncIntegrityProtectedDataPkt (SEIPD2 a b c d e) + fromPktEither (SymEncIntegrityProtectedDataPkt (SEIPD1 a b)) = + Right (SymEncIntegrityProtectedData a b) + fromPktEither (SymEncIntegrityProtectedDataPkt (SEIPD2 a b c d e)) = + Right (SymEncIntegrityProtectedDataV2 a b c d e) + fromPktEither pkt = coercionError "SymEncIntegrityProtectedData" pkt instance Pretty SymEncIntegrityProtectedData where - pretty = pretty . toPkt + pretty = pretty . toPkt -newtype ModificationDetectionCode = - ModificationDetectionCode +newtype ModificationDetectionCode + = ModificationDetectionCode { _modificationDetectionCodePayload :: ByteString } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet ModificationDetectionCode where - data PacketType - ModificationDetectionCode = ModificationDetectionCodeType - deriving (Show, Eq) - packetType _ = ModificationDetectionCodeType - packetCode _ = 19 - toPkt (ModificationDetectionCode a) = ModificationDetectionCodePkt a - fromPktEither (ModificationDetectionCodePkt a) = Right (ModificationDetectionCode a) - fromPktEither pkt = coercionError "ModificationDetectionCode" pkt + data + PacketType + ModificationDetectionCode + = ModificationDetectionCodeType + deriving (Eq, Show) + packetType _ = ModificationDetectionCodeType + packetCode _ = 19 + toPkt (ModificationDetectionCode a) = ModificationDetectionCodePkt a + fromPktEither (ModificationDetectionCodePkt a) = Right (ModificationDetectionCode a) + fromPktEither pkt = coercionError "ModificationDetectionCode" pkt instance Pretty ModificationDetectionCode where - pretty = pretty . toPkt + pretty = pretty . toPkt -data OtherPacket = - OtherPacket +newtype Padding + = Padding + { _padding :: ByteString + } + deriving (Data, Eq, Show, Typeable) + +instance Packet Padding where + data + PacketType + Padding + = PaddingType + deriving (Eq, Show) + packetType _ = PaddingType + packetCode _ = 21 + toPkt (Padding a) = PaddingPkt a + fromPktEither (PaddingPkt a) = Right (Padding a) + fromPktEither pkt = coercionError "Padding" pkt + +instance Pretty Padding where + pretty = pretty . toPkt + +data OtherPacket + = OtherPacket { _otherPacketType :: Word8 , _otherPacketPayload :: ByteString } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet OtherPacket where - data PacketType OtherPacket = OtherPacketType - deriving (Show, Eq) - packetType _ = OtherPacketType - packetCode _ = error "OtherPacket has no static packet type code" - dynamicPacketCode = _otherPacketType - toPkt (OtherPacket a b) = OtherPacketPkt a b - fromPktEither (OtherPacketPkt a b) = Right (OtherPacket a b) - fromPktEither pkt = coercionError "OtherPacket" pkt + data PacketType OtherPacket = OtherPacketType + deriving (Eq, Show) + packetType _ = OtherPacketType + packetCode _ = error "OtherPacket has no static packet type code" + dynamicPacketCode = _otherPacketType + toPkt (OtherPacket a b) = OtherPacketPkt a b + fromPktEither (OtherPacketPkt a b) = Right (OtherPacket a b) + fromPktEither pkt = coercionError "OtherPacket" pkt instance Pretty OtherPacket where - pretty = pretty . toPkt + pretty = pretty . toPkt -data BrokenPacket = - BrokenPacket +data BrokenPacket + = BrokenPacket { _brokenPacketParseError :: String , _brokenPacketType :: Word8 , _brokenPacketPayload :: ByteString } - deriving (Data, Eq, Show, Typeable) + deriving (Data, Eq, Show, Typeable) instance Packet BrokenPacket where - data PacketType BrokenPacket = BrokenPacketType - deriving (Show, Eq) - packetType _ = BrokenPacketType - packetCode _ = error "BrokenPacket has no static packet type code" - dynamicPacketCode = _brokenPacketType - toPkt (BrokenPacket a b c) = BrokenPacketPkt a b c - fromPktEither (BrokenPacketPkt a b c) = Right (BrokenPacket a b c) - fromPktEither pkt = coercionError "BrokenPacket" pkt + data PacketType BrokenPacket = BrokenPacketType + deriving (Eq, Show) + packetType _ = BrokenPacketType + packetCode _ = error "BrokenPacket has no static packet type code" + dynamicPacketCode = _brokenPacketType + toPkt (BrokenPacket a b c) = BrokenPacketPkt a b c + fromPktEither (BrokenPacketPkt a b c) = Right (BrokenPacket a b c) + fromPktEither pkt = coercionError "BrokenPacket" pkt instance Pretty BrokenPacket where - pretty = pretty . toPkt + pretty = pretty . toPkt $(makeLenses ''Signature) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs @@ -2,470 +2,571 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - {-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} module Codec.Encryption.OpenPGP.Types.Internal.Pkt where -import GHC.Generics (Generic) - -import Codec.Encryption.OpenPGP.Types.Internal.Base -import Codec.Encryption.OpenPGP.Types.Internal.PKITypes - -import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils (prettyLBS) import Control.Lens (makeLenses) -import Data.Aeson ((.=), object) +import Data.Aeson (object, (.=)) import qualified Data.Aeson as A +import qualified Data.Aeson.Key as AK import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL -import Data.Data (Data(..), Constr, mkDataType, mkConstr, Fixity(Prefix)) +import Data.Data + ( Constr + , Data (..) + , Fixity (Prefix) + , mkConstr + , mkDataType + ) import qualified Data.Data as DD -import Data.Hashable (Hashable(..)) +import Data.Hashable (Hashable (..)) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE import Data.Ord (comparing) import Data.Text (Text) -import qualified Data.Text as T import Data.Time.Clock (UTCTime) import Data.Typeable (Typeable) import Data.Word (Word8) -import Prettyprinter (Pretty(..), (<+>)) +import GHC.Generics (Generic) +import Prettyprinter (Pretty (..), (<+>)) +import Codec.Encryption.OpenPGP.Types.Internal.Base +import Codec.Encryption.OpenPGP.Types.Internal.PKITypes +import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils + ( prettyLBS + ) + data PKESKPayloadVersion = PKESKV3 | PKESKV6 - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) -data PKESKPayloadV3 = - PKESKPayloadV3 - PacketVersion - EightOctetKeyId - PubKeyAlgorithm - (NonEmpty MPI) - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) +data PKESKPayloadV3 + = PKESKPayloadV3 + PacketVersion + EightOctetKeyId + PubKeyAlgorithm + (NonEmpty MPI) + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) -data PKESKPayloadV6 = - PKESKPayloadV6 - BL.ByteString - PubKeyAlgorithm - BL.ByteString - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) +data PKESKPayloadV6 + = PKESKPayloadV6 + BL.ByteString + PubKeyAlgorithm + BL.ByteString + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data PKESKPayload - = PKESKPayloadV3Packet PKESKPayloadV3 - | PKESKPayloadV6Packet PKESKPayloadV6 - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + = PKESKPayloadV3Packet PKESKPayloadV3 + | PKESKPayloadV6Packet PKESKPayloadV6 + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data SKESKPayloadVersion = SKESKV4 | SKESKV6 - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) -data SKESKPayloadV4 = - SKESKPayloadV4 - SymmetricAlgorithm - S2K - (Maybe BL.ByteString) - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) +data SKESKPayloadV4 + = SKESKPayloadV4 + SymmetricAlgorithm + S2K + (Maybe BL.ByteString) + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) -data SKESKPayloadV6 = - SKESKPayloadV6 - SymmetricAlgorithm - AEADAlgorithm - S2K - BL.ByteString - BL.ByteString - BL.ByteString - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) +data SKESKPayloadV6 + = SKESKPayloadV6 + SymmetricAlgorithm + AEADAlgorithm + S2K + BL.ByteString + BL.ByteString + BL.ByteString + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data SKESKPayload - = SKESKPayloadV4Packet SKESKPayloadV4 - | SKESKPayloadV6Packet SKESKPayloadV6 - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + = SKESKPayloadV4Packet SKESKPayloadV4 + | SKESKPayloadV6Packet SKESKPayloadV6 + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data OnePassSignatureVersion = OPSV3 | OPSV6 - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) -data OPSPayloadV3 = - OPSPayloadV3 - PacketVersion - SigType - HashAlgorithm - PubKeyAlgorithm - EightOctetKeyId - NestedFlag - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) +data OPSPayloadV3 + = OPSPayloadV3 + PacketVersion + SigType + HashAlgorithm + PubKeyAlgorithm + EightOctetKeyId + NestedFlag + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) -data OPSPayloadV6 = - OPSPayloadV6 - SigType - HashAlgorithm - PubKeyAlgorithm - SignatureSalt - BL.ByteString - NestedFlag - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) +data OPSPayloadV6 + = OPSPayloadV6 + SigType + HashAlgorithm + PubKeyAlgorithm + SignatureSalt + BL.ByteString + NestedFlag + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data OnePassSignaturePayload - = OPSPayloadV3Packet OPSPayloadV3 - | OPSPayloadV6Packet OPSPayloadV6 - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + = OPSPayloadV3Packet OPSPayloadV3 + | OPSPayloadV6Packet OPSPayloadV6 + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data SEIPDPayload - = SEIPD1 PacketVersion BL.ByteString - | SEIPD2 SymmetricAlgorithm AEADAlgorithm Word8 Salt BL.ByteString - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + = SEIPD1 PacketVersion BL.ByteString + | SEIPD2 SymmetricAlgorithm AEADAlgorithm Word8 Salt BL.ByteString + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data KeyPktKind - = PublicPkt - | SecretPkt - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + = PublicPkt + | SecretPkt + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data KeyPktRole - = KeyPktPrimary - | KeyPktSubkey - deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) + = KeyPktPrimary + | KeyPktSubkey + deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data KeyPkt (k :: KeyPktKind) where - KeyPktPublicPrimary :: SomePKPayload -> KeyPkt 'PublicPkt - KeyPktPublicSubkey :: SomePKPayload -> KeyPkt 'PublicPkt - KeyPktSecretPrimary :: SomePKPayload -> SKAddendum -> KeyPkt 'SecretPkt - KeyPktSecretSubkey :: SomePKPayload -> SKAddendum -> KeyPkt 'SecretPkt + KeyPktPublicPrimary :: SomePKPayload -> KeyPkt 'PublicPkt + KeyPktPublicSubkey :: SomePKPayload -> KeyPkt 'PublicPkt + KeyPktSecretPrimary + :: SomePKPayload -> SKAddendum -> KeyPkt 'SecretPkt + KeyPktSecretSubkey + :: SomePKPayload -> SKAddendum -> KeyPkt 'SecretPkt deriving instance Eq (KeyPkt k) deriving instance Show (KeyPkt k) instance Ord (KeyPkt k) where - compare = comparing keyPktToPkt + compare = comparing keyPktToPkt instance Hashable (KeyPkt k) where - hashWithSalt s kp = hashWithSalt s (keyPktToPkt kp) + hashWithSalt s kp = hashWithSalt s (keyPktToPkt kp) instance Typeable k => Data (KeyPkt k) where - gfoldl f z (KeyPktPublicPrimary pkp) = z KeyPktPublicPrimary `f` pkp - gfoldl f z (KeyPktPublicSubkey pkp) = z KeyPktPublicSubkey `f` pkp - gfoldl f z (KeyPktSecretPrimary pkp ska) = z KeyPktSecretPrimary `f` pkp `f` ska - gfoldl f z (KeyPktSecretSubkey pkp ska) = z KeyPktSecretSubkey `f` pkp `f` ska + gfoldl f z (KeyPktPublicPrimary pkp) = z KeyPktPublicPrimary `f` pkp + gfoldl f z (KeyPktPublicSubkey pkp) = z KeyPktPublicSubkey `f` pkp + gfoldl f z (KeyPktSecretPrimary pkp ska) = z KeyPktSecretPrimary `f` pkp `f` ska + gfoldl f z (KeyPktSecretSubkey pkp ska) = z KeyPktSecretSubkey `f` pkp `f` ska - toConstr (KeyPktPublicPrimary _) = conKeyPktPublicPrimary - toConstr (KeyPktPublicSubkey _) = conKeyPktPublicSubkey - toConstr (KeyPktSecretPrimary _ _) = conKeyPktSecretPrimary - toConstr (KeyPktSecretSubkey _ _) = conKeyPktSecretSubkey + toConstr (KeyPktPublicPrimary _) = conKeyPktPublicPrimary + toConstr (KeyPktPublicSubkey _) = conKeyPktPublicSubkey + toConstr (KeyPktSecretPrimary _ _) = conKeyPktSecretPrimary + toConstr (KeyPktSecretSubkey _ _) = conKeyPktSecretSubkey - dataTypeOf _ = tyKeyPkt + dataTypeOf _ = tyKeyPkt - gunfold _ _ _ = error "KeyPkt: gunfold not supported for GADT" + gunfold _ _ _ = error "KeyPkt: gunfold not supported for GADT" tyKeyPkt :: DD.DataType -tyKeyPkt = mkDataType "Codec.Encryption.OpenPGP.Types.Internal.Pkt.KeyPkt" - [ conKeyPktPublicPrimary - , conKeyPktPublicSubkey - , conKeyPktSecretPrimary - , conKeyPktSecretSubkey - ] +tyKeyPkt = + mkDataType + "Codec.Encryption.OpenPGP.Types.Internal.Pkt.KeyPkt" + [ conKeyPktPublicPrimary + , conKeyPktPublicSubkey + , conKeyPktSecretPrimary + , conKeyPktSecretSubkey + ] -conKeyPktPublicPrimary, conKeyPktPublicSubkey, - conKeyPktSecretPrimary, conKeyPktSecretSubkey :: Constr +conKeyPktPublicPrimary + , conKeyPktPublicSubkey + , conKeyPktSecretPrimary + , conKeyPktSecretSubkey + :: Constr conKeyPktPublicPrimary = mkConstr tyKeyPkt "KeyPktPublicPrimary" [] Prefix -conKeyPktPublicSubkey = mkConstr tyKeyPkt "KeyPktPublicSubkey" [] Prefix +conKeyPktPublicSubkey = mkConstr tyKeyPkt "KeyPktPublicSubkey" [] Prefix conKeyPktSecretPrimary = mkConstr tyKeyPkt "KeyPktSecretPrimary" [] Prefix -conKeyPktSecretSubkey = mkConstr tyKeyPkt "KeyPktSecretSubkey" [] Prefix +conKeyPktSecretSubkey = mkConstr tyKeyPkt "KeyPktSecretSubkey" [] Prefix data SomeKeyPkt where - SomeKeyPkt :: KeyPkt k -> SomeKeyPkt + SomeKeyPkt :: KeyPkt k -> SomeKeyPkt deriving instance Show SomeKeyPkt instance Eq SomeKeyPkt where - SomeKeyPkt left == SomeKeyPkt right = someKeyPktToPkt (SomeKeyPkt left) == someKeyPktToPkt (SomeKeyPkt right) + SomeKeyPkt left == SomeKeyPkt right = + someKeyPktToPkt (SomeKeyPkt left) + == someKeyPktToPkt (SomeKeyPkt right) data KeyPktCoercionError - = NotAKeyPacket Pkt - | ExpectedPublicKeyPacket Pkt - | ExpectedSecretKeyPacket Pkt - deriving (Eq, Show) + = NotAKeyPacket Pkt + | ExpectedPublicKeyPacket Pkt + | ExpectedSecretKeyPacket Pkt + deriving (Eq, Show) -- data Pkt = forall a. (Packet a, Show a, Eq a) => Pkt a data Pkt - = PKESKPkt PKESKPayload - | SignaturePkt SignaturePayload - | SKESKPkt SKESKPayload - | OnePassSignaturePkt OnePassSignaturePayload - | SecretKeyPkt SomePKPayload SKAddendum - | PublicKeyPkt SomePKPayload - | SecretSubkeyPkt SomePKPayload SKAddendum - | CompressedDataPkt CompressionAlgorithm CompressedDataPayload - | SymEncDataPkt ByteString - | MarkerPkt ByteString - | LiteralDataPkt DataType FileName ThirtyTwoBitTimeStamp ByteString - | TrustPkt ByteString - | UserIdPkt Text - | PublicSubkeyPkt SomePKPayload - | UserAttributePkt [UserAttrSubPacket] - | SymEncIntegrityProtectedDataPkt SEIPDPayload - | ModificationDetectionCodePkt ByteString - | OtherPacketPkt Word8 ByteString - | BrokenPacketPkt String Word8 ByteString - deriving (Data, Eq, Generic, Show, Typeable) + = PKESKPkt PKESKPayload + | SignaturePkt SignaturePayload + | SKESKPkt SKESKPayload + | OnePassSignaturePkt OnePassSignaturePayload + | SecretKeyPkt SomePKPayload SKAddendum + | PublicKeyPkt SomePKPayload + | SecretSubkeyPkt SomePKPayload SKAddendum + | CompressedDataPkt CompressionAlgorithm CompressedDataPayload + | SymEncDataPkt ByteString + | MarkerPkt ByteString + | LiteralDataPkt + LiteralDataType + FileName + ThirtyTwoBitTimeStamp + ByteString + | TrustPkt ByteString + | UserIdPkt Text + | PublicSubkeyPkt SomePKPayload + | UserAttributePkt [UserAttrSubPacket] + | SymEncIntegrityProtectedDataPkt SEIPDPayload + | ModificationDetectionCodePkt ByteString + | PaddingPkt ByteString + | OtherPacketPkt Word8 ByteString + | BrokenPacketPkt String Word8 ByteString + deriving (Data, Eq, Generic, Show, Typeable) -data PktWithWireRep = - PktWithWireRep +data PktWithWireRep + = PktWithWireRep { _pktWireRepRef :: WireRepRef , _pktRange :: ByteRange , _pktRaw :: ByteString , _pktIndex :: Int , _pktValue :: Pkt } - deriving (Data, Eq, Generic, Show, Typeable) + deriving (Data, Eq, Generic, Show, Typeable) instance Hashable Pkt instance Ord Pkt where - compare p1 p2 = comparing pktTag p1 p2 <> compareFields p1 p2 - where - compareFields (PKESKPkt pkesk1) (PKESKPkt pkesk2) = compare pkesk1 pkesk2 - compareFields (SignaturePkt sp1) (SignaturePkt sp2) = compare sp1 sp2 - compareFields (SKESKPkt skesk1) (SKESKPkt skesk2) = compare skesk1 skesk2 - compareFields (OnePassSignaturePkt ops1) (OnePassSignaturePkt ops2) = compare ops1 ops2 - compareFields (SecretKeyPkt pkp1 ska1) (SecretKeyPkt pkp2 ska2) = - compare pkp1 pkp2 <> compare ska1 ska2 - compareFields (PublicKeyPkt pkp1) (PublicKeyPkt pkp2) = compare pkp1 pkp2 - compareFields (SecretSubkeyPkt pkp1 ska1) (SecretSubkeyPkt pkp2 ska2) = - compare pkp1 pkp2 <> compare ska1 ska2 - compareFields (CompressedDataPkt ca1 cdp1) (CompressedDataPkt ca2 cdp2) = - compare ca1 ca2 <> compare cdp1 cdp2 - compareFields (SymEncDataPkt bs1) (SymEncDataPkt bs2) = compare bs1 bs2 - compareFields (MarkerPkt bs1) (MarkerPkt bs2) = compare bs1 bs2 - compareFields (LiteralDataPkt dt1 fn1 ts1 bs1) (LiteralDataPkt dt2 fn2 ts2 bs2) = - compare dt1 dt2 <> compare fn1 fn2 <> compare ts1 ts2 <> compare bs1 bs2 - compareFields (TrustPkt bs1) (TrustPkt bs2) = compare bs1 bs2 - compareFields (UserIdPkt u1) (UserIdPkt u2) = compare u1 u2 - compareFields (PublicSubkeyPkt pkp1) (PublicSubkeyPkt pkp2) = compare pkp1 pkp2 - compareFields (UserAttributePkt us1) (UserAttributePkt us2) = compare us1 us2 - compareFields (SymEncIntegrityProtectedDataPkt seipd1) (SymEncIntegrityProtectedDataPkt seipd2) = compare seipd1 seipd2 - compareFields (ModificationDetectionCodePkt bs1) (ModificationDetectionCodePkt bs2) = compare bs1 bs2 - compareFields (OtherPacketPkt t1 bs1) (OtherPacketPkt t2 bs2) = compare t1 t2 <> compare bs1 bs2 - compareFields (BrokenPacketPkt s1 t1 bs1) (BrokenPacketPkt s2 t2 bs2) = - compare s1 s2 <> compare t1 t2 <> compare bs1 bs2 - compareFields _ _ = EQ + compare p1 p2 = comparing pktTag p1 p2 <> compareFields p1 p2 + where + compareFields (PKESKPkt pkesk1) (PKESKPkt pkesk2) = compare pkesk1 pkesk2 + compareFields (SignaturePkt sp1) (SignaturePkt sp2) = compare sp1 sp2 + compareFields (SKESKPkt skesk1) (SKESKPkt skesk2) = compare skesk1 skesk2 + compareFields (OnePassSignaturePkt ops1) (OnePassSignaturePkt ops2) = compare ops1 ops2 + compareFields (SecretKeyPkt pkp1 ska1) (SecretKeyPkt pkp2 ska2) = + compare pkp1 pkp2 <> compare ska1 ska2 + compareFields (PublicKeyPkt pkp1) (PublicKeyPkt pkp2) = compare pkp1 pkp2 + compareFields (SecretSubkeyPkt pkp1 ska1) (SecretSubkeyPkt pkp2 ska2) = + compare pkp1 pkp2 <> compare ska1 ska2 + compareFields (CompressedDataPkt ca1 cdp1) (CompressedDataPkt ca2 cdp2) = + compare ca1 ca2 <> compare cdp1 cdp2 + compareFields (SymEncDataPkt bs1) (SymEncDataPkt bs2) = compare bs1 bs2 + compareFields (MarkerPkt bs1) (MarkerPkt bs2) = compare bs1 bs2 + compareFields (LiteralDataPkt dt1 fn1 ts1 bs1) (LiteralDataPkt dt2 fn2 ts2 bs2) = + compare dt1 dt2 + <> compare fn1 fn2 + <> compare ts1 ts2 + <> compare bs1 bs2 + compareFields (TrustPkt bs1) (TrustPkt bs2) = compare bs1 bs2 + compareFields (UserIdPkt u1) (UserIdPkt u2) = compare u1 u2 + compareFields (PublicSubkeyPkt pkp1) (PublicSubkeyPkt pkp2) = compare pkp1 pkp2 + compareFields (UserAttributePkt us1) (UserAttributePkt us2) = compare us1 us2 + compareFields (SymEncIntegrityProtectedDataPkt seipd1) (SymEncIntegrityProtectedDataPkt seipd2) = compare seipd1 seipd2 + compareFields (ModificationDetectionCodePkt bs1) (ModificationDetectionCodePkt bs2) = compare bs1 bs2 + compareFields (OtherPacketPkt t1 bs1) (OtherPacketPkt t2 bs2) = compare t1 t2 <> compare bs1 bs2 + compareFields (BrokenPacketPkt s1 t1 bs1) (BrokenPacketPkt s2 t2 bs2) = + compare s1 s2 <> compare t1 t2 <> compare bs1 bs2 + compareFields _ _ = EQ instance Ord PktWithWireRep where - compare p1 p2 = - comparing _pktValue p1 p2 <> - comparing _pktRaw p1 p2 <> - comparing _pktWireRepRef p1 p2 <> - comparing _pktRange p1 p2 <> - comparing _pktIndex p1 p2 + compare p1 p2 = + comparing _pktValue p1 p2 + <> comparing _pktRaw p1 p2 + <> comparing _pktWireRepRef p1 p2 + <> comparing _pktRange p1 p2 + <> comparing _pktIndex p1 p2 wireRepOfPkt :: PktWithWireRep -> WireRepRef wireRepOfPkt = _pktWireRepRef -packetsFromWireRep :: WireRepRef -> [PktWithWireRep] -> [PktWithWireRep] +packetsFromWireRep + :: WireRepRef -> [PktWithWireRep] -> [PktWithWireRep] packetsFromWireRep src = filter ((== src) . wireRepOfPkt) instance Pretty Pkt where - pretty (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eoki pka mpis))) = - pretty "PKESK v" <> pretty pv <> pretty ':' <+> - pretty eoki <+> pretty pka <+> (pretty . NE.toList) mpis - pretty (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier pka esk))) = - pretty "PKESK v6:" <+> - pretty "recipient key identifier" <+> - pretty (bsToHexUpper recipientKeyIdentifier) <+> - pretty pka <+> pretty (bsToHexUpper esk) - pretty (SignaturePkt sp) = pretty sp - pretty (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k mbs))) = - pretty "SKESK v4:" <+> - pretty sa <+> pretty s2k <+> pretty (fmap bsToHexUpper mbs) - pretty (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag))) = - pretty "SKESK v6:" <+> - pretty sa <+> - pretty aa <+> - pretty s2k <+> - pretty (bsToHexUpper iv) <+> - pretty (bsToHexUpper esk) <+> - pretty (bsToHexUpper tag) - pretty (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 pv st ha pka eoki nestedflag))) = - pretty "one-pass signature v" <> pretty pv <> pretty ':' <+> - pretty st <+> pretty ha <+> pretty pka <+> pretty eoki <+> pretty nestedflag - pretty (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 st ha pka salt signerFingerprint nestedflag))) = - pretty "one-pass signature v6:" <+> - pretty st <+> - pretty ha <+> - pretty pka <+> pretty salt <+> pretty (bsToHexUpper signerFingerprint) <+> - pretty nestedflag - pretty (SecretKeyPkt pkp ska) = - pretty "secret key:" <+> pretty pkp <+> pretty ska - pretty (PublicKeyPkt pkp) = pretty "public key:" <+> pretty pkp - pretty (SecretSubkeyPkt pkp ska) = - pretty "secret subkey:" <+> pretty pkp <+> pretty ska - pretty (CompressedDataPkt ca cdp) = - pretty "compressed-data:" <+> pretty ca <+> prettyLBS cdp - pretty (SymEncDataPkt bs) = - pretty "symmetrically-encrypted-data:" <+> pretty (bsToHexUpper bs) - pretty (MarkerPkt bs) = pretty "marker:" <+> pretty (bsToHexUpper bs) - pretty (LiteralDataPkt dt fn ts bs) = - pretty "literal-data" <+> - pretty dt <+> prettyLBS fn <+> pretty ts <+> pretty (bsToHexUpper bs) - pretty (TrustPkt bs) = pretty "trust:" <+> pretty (BL.unpack bs) - pretty (UserIdPkt u) = pretty "user-ID:" <+> pretty u - pretty (PublicSubkeyPkt pkp) = pretty "public subkey:" <+> pretty pkp - pretty (UserAttributePkt us) = pretty "user-attribute:" <+> pretty us - pretty (SymEncIntegrityProtectedDataPkt (SEIPD1 pv bs)) = - pretty "symmetrically-encrypted-integrity-protected-data v" <> pretty pv <> - pretty ':' <+> - pretty (bsToHexUpper bs) - pretty (SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) = - pretty "symmetrically-encrypted-integrity-protected-data v2:" <+> - pretty sa <+> pretty aa <+> pretty chunkSize <+> pretty salt <+> - pretty (bsToHexUpper bs) - pretty (ModificationDetectionCodePkt bs) = - pretty "MDC:" <+> pretty (bsToHexUpper bs) - pretty (OtherPacketPkt t bs) = - pretty "unknown packet type" <+> - pretty t <> pretty ':' <+> pretty (bsToHexUpper bs) - pretty (BrokenPacketPkt s t bs) = - pretty "BROKEN packet (" <> pretty s <> pretty ')' <+> - pretty t <> pretty ':' <+> pretty (bsToHexUpper bs) + pretty (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eoki pka mpis))) = + pretty "PKESK v" + <> pretty pv + <> pretty ':' + <+> pretty eoki + <+> pretty pka + <+> (pretty . NE.toList) mpis + pretty + ( PKESKPkt + ( PKESKPayloadV6Packet + (PKESKPayloadV6 recipientKeyIdentifier pka esk) + ) + ) = + pretty "PKESK v6:" + <+> pretty "recipient key identifier" + <+> pretty (bsToHexUpper recipientKeyIdentifier) + <+> pretty pka + <+> pretty (bsToHexUpper esk) + pretty (SignaturePkt sp) = pretty sp + pretty (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k mbs))) = + pretty "SKESK v4:" + <+> pretty sa + <+> pretty s2k + <+> pretty (fmap bsToHexUpper mbs) + pretty + ( SKESKPkt + (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) + ) = + pretty "SKESK v6:" + <+> pretty sa + <+> pretty aa + <+> pretty s2k + <+> pretty (bsToHexUpper iv) + <+> pretty (bsToHexUpper esk) + <+> pretty (bsToHexUpper tag) + pretty + ( OnePassSignaturePkt + (OPSPayloadV3Packet (OPSPayloadV3 pv st ha pka eoki nestedflag)) + ) = + pretty "one-pass signature v" + <> pretty pv + <> pretty ':' + <+> pretty st + <+> pretty ha + <+> pretty pka + <+> pretty eoki + <+> pretty nestedflag + pretty + ( OnePassSignaturePkt + ( OPSPayloadV6Packet + (OPSPayloadV6 st ha pka salt signerFingerprint nestedflag) + ) + ) = + pretty "one-pass signature v6:" + <+> pretty st + <+> pretty ha + <+> pretty pka + <+> pretty salt + <+> pretty (bsToHexUpper signerFingerprint) + <+> pretty nestedflag + pretty (SecretKeyPkt pkp ska) = + pretty "secret key:" <+> pretty pkp <+> pretty ska + pretty (PublicKeyPkt pkp) = pretty "public key:" <+> pretty pkp + pretty (SecretSubkeyPkt pkp ska) = + pretty "secret subkey:" <+> pretty pkp <+> pretty ska + pretty (CompressedDataPkt ca cdp) = + pretty "compressed-data:" <+> pretty ca <+> prettyLBS cdp + pretty (SymEncDataPkt bs) = + pretty "symmetrically-encrypted-data:" + <+> pretty (bsToHexUpper bs) + pretty (MarkerPkt bs) = pretty "marker:" <+> pretty (bsToHexUpper bs) + pretty (LiteralDataPkt dt fn ts bs) = + pretty "literal-data" + <+> pretty dt + <+> prettyLBS fn + <+> pretty ts + <+> pretty (bsToHexUpper bs) + pretty (TrustPkt bs) = pretty "trust:" <+> pretty (BL.unpack bs) + pretty (UserIdPkt u) = pretty "user-ID:" <+> pretty u + pretty (PublicSubkeyPkt pkp) = pretty "public subkey:" <+> pretty pkp + pretty (UserAttributePkt us) = pretty "user-attribute:" <+> pretty us + pretty (SymEncIntegrityProtectedDataPkt (SEIPD1 pv bs)) = + pretty "symmetrically-encrypted-integrity-protected-data v" + <> pretty pv + <> pretty ':' + <+> pretty (bsToHexUpper bs) + pretty (SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) = + pretty "symmetrically-encrypted-integrity-protected-data v2:" + <+> pretty sa + <+> pretty aa + <+> pretty chunkSize + <+> pretty salt + <+> pretty (bsToHexUpper bs) + pretty (ModificationDetectionCodePkt bs) = + pretty "MDC:" <+> pretty (bsToHexUpper bs) + pretty (PaddingPkt bs) = + pretty "Padding:" <+> pretty (bsToHexUpper bs) + pretty (OtherPacketPkt t bs) = + pretty "unknown packet type" + <+> pretty t + <> pretty ':' + <+> pretty (bsToHexUpper bs) + pretty (BrokenPacketPkt s t bs) = + pretty "BROKEN packet (" + <> pretty s + <> pretty ')' + <+> pretty t + <> pretty ':' + <+> pretty (bsToHexUpper bs) instance A.ToJSON Pkt where - toJSON (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eoki pka mpis))) = - object - [ key "pkesk" .= + toJSON (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eoki pka mpis))) = object - [ key "version" .= pv - , key "keyid" .= eoki - , key "pkalgo" .= pka - , key "mpis" .= NE.toList mpis - ] - ] - toJSON (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier pka esk))) = - object - [ key "pkesk_v6" .= + [ AK.fromString "pkesk" + .= object + [ AK.fromString "version" .= pv + , AK.fromString "keyid" .= eoki + , AK.fromString "pkalgo" .= pka + , AK.fromString "mpis" .= NE.toList mpis + ] + ] + toJSON + ( PKESKPkt + ( PKESKPayloadV6Packet + (PKESKPayloadV6 recipientKeyIdentifier pka esk) + ) + ) = + object + [ AK.fromString "pkesk" + .= object + [ AK.fromString "version" .= (6 :: PacketVersion) + , AK.fromString "recipient_key_identifier" + .= BL.unpack recipientKeyIdentifier + , AK.fromString "pkalgo" .= pka + , AK.fromString "esk" .= BL.unpack esk + ] + ] + toJSON (SignaturePkt sp) = object [AK.fromString "signature" .= sp] + toJSON (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k mbs))) = object - [ key "recipient_key_identifier" .= BL.unpack recipientKeyIdentifier - , key "pkalgo" .= pka - , key "esk" .= BL.unpack esk - ] - ] - toJSON (SignaturePkt sp) = object [key "signature" .= sp] - toJSON (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k mbs))) = - object - [ key "skesk" .= + [ AK.fromString "skesk" + .= object + [ AK.fromString "version" .= (4 :: PacketVersion) + , AK.fromString "symalgo" .= sa + , AK.fromString "s2k" .= s2k + , AK.fromString "data" .= maybe mempty BL.unpack mbs + ] + ] + toJSON + ( SKESKPkt + (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) + ) = + object + [ AK.fromString "skesk" + .= object + [ AK.fromString "version" .= (6 :: PacketVersion) + , AK.fromString "symalgo" .= sa + , AK.fromString "aead" .= aa + , AK.fromString "s2k" .= s2k + , AK.fromString "iv" .= BL.unpack iv + , AK.fromString "esk" .= BL.unpack esk + , AK.fromString "tag" .= BL.unpack tag + ] + ] + toJSON + ( OnePassSignaturePkt + (OPSPayloadV3Packet (OPSPayloadV3 pv st ha pka eoki nestedflag)) + ) = + object + [ AK.fromString "onepasssignature" + .= object + [ AK.fromString "version" .= pv + , AK.fromString "sigtype" .= st + , AK.fromString "hashalgo" .= ha + , AK.fromString "pkalgo" .= pka + , AK.fromString "keyid" .= eoki + , AK.fromString "nested" .= nestedflag + ] + ] + toJSON + ( OnePassSignaturePkt + ( OPSPayloadV6Packet + (OPSPayloadV6 st ha pka salt signerFingerprint nestedflag) + ) + ) = + object + [ AK.fromString "onepasssignature" + .= object + [ AK.fromString "version" .= (6 :: Word8) + , AK.fromString "sigtype" .= st + , AK.fromString "hashalgo" .= ha + , AK.fromString "pkalgo" .= pka + , AK.fromString "salt" .= salt + , AK.fromString "fingerprint" .= BL.unpack signerFingerprint + , AK.fromString "nested" .= nestedflag + ] + ] + toJSON (SecretKeyPkt pkp ska) = object - [ key "version" .= (4 :: PacketVersion) - , key "symalgo" .= sa - , key "s2k" .= s2k - , key "data" .= maybe mempty BL.unpack mbs - ] - ] - toJSON (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag))) = - object - [ key "skesk-v6" .= + [ AK.fromString "secretkey" + .= object + [AK.fromString "public" .= pkp, AK.fromString "secret" .= ska] + ] + toJSON (PublicKeyPkt pkp) = object [AK.fromString "publickey" .= pkp] + toJSON (SecretSubkeyPkt pkp ska) = object - [ key "version" .= (6 :: PacketVersion) - , key "symalgo" .= sa - , key "aead" .= aa - , key "s2k" .= s2k - , key "iv" .= BL.unpack iv - , key "esk" .= BL.unpack esk - , key "tag" .= BL.unpack tag - ] - ] - toJSON (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 pv st ha pka eoki nestedflag))) = - object - [ key "onepasssignature" .= + [ AK.fromString "secretsubkey" + .= object + [AK.fromString "public" .= pkp, AK.fromString "secret" .= ska] + ] + toJSON (CompressedDataPkt ca cdp) = object - [ key "version" .= pv - , key "sigtype" .= st - , key "hashalgo" .= ha - , key "pkalgo" .= pka - , key "keyid" .= eoki - , key "nested" .= nestedflag - ] - ] - toJSON (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 st ha pka salt signerFingerprint nestedflag))) = - object - [ key "onepasssignature_v6" .= + [ AK.fromString "compresseddata" + .= object + [ AK.fromString "compressionalgo" .= ca + , AK.fromString "data" .= BL.unpack cdp + ] + ] + toJSON (SymEncDataPkt bs) = object [AK.fromString "symencdata" .= BL.unpack bs] + toJSON (MarkerPkt bs) = object [AK.fromString "marker" .= BL.unpack bs] + toJSON (LiteralDataPkt dt fn ts bs) = object - [ key "version" .= (6 :: Word8) - , key "sigtype" .= st - , key "hashalgo" .= ha - , key "pkalgo" .= pka - , key "salt" .= salt - , key "fingerprint" .= BL.unpack signerFingerprint - , key "nested" .= nestedflag - ] - ] - toJSON (SecretKeyPkt pkp ska) = - object - [ key "secretkey" .= - object [key "public" .= pkp, key "secret" .= ska] - ] - toJSON (PublicKeyPkt pkp) = object [key "publickey" .= pkp] - toJSON (SecretSubkeyPkt pkp ska) = - object - [ key "secretsubkey" .= - object [key "public" .= pkp, key "secret" .= ska] - ] - toJSON (CompressedDataPkt ca cdp) = - object - [ key "compresseddata" .= - object [key "compressionalgo" .= ca, key "data" .= BL.unpack cdp] - ] - toJSON (SymEncDataPkt bs) = object [key "symencdata" .= BL.unpack bs] - toJSON (MarkerPkt bs) = object [key "marker" .= BL.unpack bs] - toJSON (LiteralDataPkt dt fn ts bs) = - object - [ key "literaldata" .= + [ AK.fromString "literaldata" + .= object + [ AK.fromString "dt" .= dt + , AK.fromString "filename" .= BL.unpack fn + , AK.fromString "ts" .= ts + , AK.fromString "data" .= BL.unpack bs + ] + ] + toJSON (TrustPkt bs) = object [AK.fromString "trust" .= BL.unpack bs] + toJSON (UserIdPkt u) = object [AK.fromString "userid" .= u] + toJSON (PublicSubkeyPkt pkp) = object [AK.fromString "publicsubkkey" .= pkp] + toJSON (UserAttributePkt us) = object [AK.fromString "userattribute" .= us] + toJSON (SymEncIntegrityProtectedDataPkt (SEIPD1 pv bs)) = object - [ key "dt" .= dt - , key "filename" .= BL.unpack fn - , key "ts" .= ts - , key "data" .= BL.unpack bs - ] - ] - toJSON (TrustPkt bs) = object [key "trust" .= BL.unpack bs] - toJSON (UserIdPkt u) = object [key "userid" .= u] - toJSON (PublicSubkeyPkt pkp) = object [key "publicsubkkey" .= pkp] - toJSON (UserAttributePkt us) = object [key "userattribute" .= us] - toJSON (SymEncIntegrityProtectedDataPkt (SEIPD1 pv bs)) = - object - [ key "symencipd" .= - object [key "version" .= pv, key "data" .= BL.unpack bs] - ] - toJSON (SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) = - object - [ key "symencipd_v2" .= + [ AK.fromString "symencipd" + .= object + [ AK.fromString "version" .= pv + , AK.fromString "data" .= BL.unpack bs + ] + ] + toJSON (SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) = object - [ key "symalgo" .= sa - , key "aeadalgo" .= aa - , key "chunksize" .= chunkSize - , key "salt" .= salt - , key "data" .= BL.unpack bs - ] - ] - toJSON (ModificationDetectionCodePkt bs) = - object [key "mdc" .= BL.unpack bs] - toJSON (OtherPacketPkt t bs) = - object - [ key "otherpacket" .= - object [key "tag" .= t, key "data" .= BL.unpack bs] - ] - toJSON (BrokenPacketPkt s t bs) = - object - [ key "brokenpacket" .= + [ AK.fromString "symencipd" + .= object + [ AK.fromString "version" .= (2 :: PacketVersion) + , AK.fromString "symalgo" .= sa + , AK.fromString "aeadalgo" .= aa + , AK.fromString "chunksize" .= chunkSize + , AK.fromString "salt" .= salt + , AK.fromString "data" .= BL.unpack bs + ] + ] + toJSON (ModificationDetectionCodePkt bs) = + object [AK.fromString "mdc" .= BL.unpack bs] + toJSON (PaddingPkt bs) = + object [AK.fromString "padding" .= BL.unpack bs] + toJSON (OtherPacketPkt t bs) = object - [ key "error" .= s - , key "tag" .= t - , key "data" .= BL.unpack bs - ] - ] + [ AK.fromString "otherpacket" + .= object + [AK.fromString "tag" .= t, AK.fromString "data" .= BL.unpack bs] + ] + toJSON (BrokenPacketPkt s t bs) = + object + [ AK.fromString "brokenpacket" + .= object + [ AK.fromString "error" .= s + , AK.fromString "tag" .= t + , AK.fromString "data" .= BL.unpack bs + ] + ] pktTag :: Pkt -> Word8 pktTag PKESKPkt {} = 1 @@ -485,16 +586,17 @@ pktTag (UserAttributePkt _) = 17 pktTag SymEncIntegrityProtectedDataPkt {} = 18 pktTag (ModificationDetectionCodePkt _) = 19 +pktTag (PaddingPkt _) = 21 pktTag (OtherPacketPkt t _) = t pktTag (BrokenPacketPkt _ t _) = t -- is this the right thing to do? renderKeyPktCoercionError :: KeyPktCoercionError -> String renderKeyPktCoercionError (NotAKeyPacket pkt) = - "Expected a key packet, got tag " ++ show (pktTag pkt) + "Expected a key packet, got tag " ++ show (pktTag pkt) renderKeyPktCoercionError (ExpectedPublicKeyPacket pkt) = - "Expected a public key packet, got tag " ++ show (pktTag pkt) + "Expected a public key packet, got tag " ++ show (pktTag pkt) renderKeyPktCoercionError (ExpectedSecretKeyPacket pkt) = - "Expected a secret key packet, got tag " ++ show (pktTag pkt) + "Expected a secret key packet, got tag " ++ show (pktTag pkt) keyPktRole :: KeyPkt k -> KeyPktRole keyPktRole KeyPktPublicPrimary {} = KeyPktPrimary @@ -521,7 +623,8 @@ secretKeyPktSKAddendum (KeyPktSecretPrimary _ ska) = ska secretKeyPktSKAddendum (KeyPktSecretSubkey _ ska) = ska -mkPrimaryKeyPkt :: SomePKPayload -> Maybe SKAddendum -> SomeKeyPkt +mkPrimaryKeyPkt + :: SomePKPayload -> Maybe SKAddendum -> SomeKeyPkt mkPrimaryKeyPkt pkp Nothing = SomeKeyPkt (KeyPktPublicPrimary pkp) mkPrimaryKeyPkt pkp (Just ska) = SomeKeyPkt (KeyPktSecretPrimary pkp ska) @@ -542,7 +645,8 @@ someKeyPktToPkt :: SomeKeyPkt -> Pkt someKeyPktToPkt (SomeKeyPkt keyPkt) = keyPktToPkt keyPkt -pktToSomeKeyPktEither :: Pkt -> Either KeyPktCoercionError SomeKeyPkt +pktToSomeKeyPktEither + :: Pkt -> Either KeyPktCoercionError SomeKeyPkt pktToSomeKeyPktEither (PublicKeyPkt pkp) = Right (SomeKeyPkt (KeyPktPublicPrimary pkp)) pktToSomeKeyPktEither (PublicSubkeyPkt pkp) = Right (SomeKeyPkt (KeyPktPublicSubkey pkp)) pktToSomeKeyPktEither (SecretKeyPkt pkp ska) = Right (SomeKeyPkt (KeyPktSecretPrimary pkp ska)) @@ -552,7 +656,8 @@ pktToSomeKeyPkt :: Pkt -> Maybe SomeKeyPkt pktToSomeKeyPkt = either (const Nothing) Just . pktToSomeKeyPktEither -pktToPublicKeyPktEither :: Pkt -> Either KeyPktCoercionError (KeyPkt 'PublicPkt) +pktToPublicKeyPktEither + :: Pkt -> Either KeyPktCoercionError (KeyPkt 'PublicPkt) pktToPublicKeyPktEither (PublicKeyPkt pkp) = Right (KeyPktPublicPrimary pkp) pktToPublicKeyPktEither (PublicSubkeyPkt pkp) = Right (KeyPktPublicSubkey pkp) pktToPublicKeyPktEither pkt = Left (ExpectedPublicKeyPacket pkt) @@ -560,7 +665,8 @@ pktToPublicKeyPkt :: Pkt -> Maybe (KeyPkt 'PublicPkt) pktToPublicKeyPkt = either (const Nothing) Just . pktToPublicKeyPktEither -pktToSecretKeyPktEither :: Pkt -> Either KeyPktCoercionError (KeyPkt 'SecretPkt) +pktToSecretKeyPktEither + :: Pkt -> Either KeyPktCoercionError (KeyPkt 'SecretPkt) pktToSecretKeyPktEither (SecretKeyPkt pkp ska) = Right (KeyPktSecretPrimary pkp ska) pktToSecretKeyPktEither (SecretSubkeyPkt pkp ska) = Right (KeyPktSecretSubkey pkp ska) pktToSecretKeyPktEither pkt = Left (ExpectedSecretKeyPacket pkt) @@ -568,25 +674,36 @@ pktToSecretKeyPkt :: Pkt -> Maybe (KeyPkt 'SecretPkt) pktToSecretKeyPkt = either (const Nothing) Just . pktToSecretKeyPktEither --- | Convert secret key/subkey packets to their public-key packet forms. --- Non-secret packets are returned unchanged. +{- | Convert secret key/subkey packets to their public-key packet forms. +Non-secret packets are returned unchanged. +-} publicKeyPacketOf :: Pkt -> Pkt publicKeyPacketOf pkt = - maybe pkt (keyPktToPkt . keyPktToPublicView) (pktToSecretKeyPkt pkt) + maybe + pkt + (keyPktToPkt . keyPktToPublicView) + (pktToSecretKeyPkt pkt) -data Verification = - Verification +data Verification + = Verification { _verificationSigner :: SomePKPayload , _verificationSignature :: SignaturePayload , _verificationWarnings :: [VerificationWarning] } data VerificationWarning - = MissingSubkeyBackSignatureWarning - deriving (Eq, Show) + = MissingSubkeyBackSignatureWarning + | DeprecatedHashAlgorithmWarning HashAlgorithm + | UnsupportedHashAlgorithmWarning HashAlgorithm + | PkaMismatchWarning PubKeyAlgorithm PubKeyAlgorithm + | UnsupportedCriticalSubpacketWarning SigType + | LegacyIssuerKeyIdInV6Warning + | InvalidSignatureContextWarning SigType + | ExpiredSignatureWarning + deriving (Eq, Show) -data SOPVVerification = - SOPVVerification +data SOPVVerification + = SOPVVerification { _sopvvDateStamp :: UTCTime , _sopvvFingerprint :: Fingerprint , _sopvvPrimaryFingerprint :: Fingerprint diff --git a/Data/Conduit/OpenPGP/Decrypt.hs b/Data/Conduit/OpenPGP/Decrypt.hs --- a/Data/Conduit/OpenPGP/Decrypt.hs +++ b/Data/Conduit/OpenPGP/Decrypt.hs @@ -2,2483 +2,2929 @@ -- Copyright © 2013-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TypeApplications #-} - -module Data.Conduit.OpenPGP.Decrypt - ( conduitDecrypt - , conduitDecryptWithReport - , DecryptOptions(..) - , DecryptKeyResolution(..) - , PKESKRecipientKey(..) - , PKESKAttemptFailureKind(..) - , PKESKAttemptFailure(..) - , DecryptOutcome(..) - , DecryptReport(..) - , DecryptSessionKeyResolutionReport(..) - , DecryptSessionKeyResolutionPath(..) - , PKESKResolverAttempt(..) - , PKESKResolverAttemptAction(..) - , decryptSEIPDv2Payload - ) where - -import Codec.Encryption.OpenPGP.BlockCipher (renderCipherError, keySize) -import Control.Exception (SomeException, displayException, try) -import Control.Applicative ((<|>)) -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.IO.Unlift (MonadUnliftIO) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) -import Control.Monad.Trans.Resource (MonadResource, MonadThrow) -import qualified "crypton" Crypto.Cipher.Types as CCT -import qualified Crypto.Error as CE -import qualified Crypto.Hash as CH -import qualified Crypto.Hash.Algorithms as CHA -import Crypto.KDF.HKDF (expand, extract) -import Crypto.Number.Serialize (i2osp, os2ip) -import qualified Crypto.PubKey.Curve25519 as C25519 -import qualified Crypto.PubKey.Curve448 as C448 -import qualified Crypto.PubKey.ECC.DH as ECCDH -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.ECC.Types as ECCT -import qualified Crypto.PubKey.RSA.PKCS15 as P15 -import qualified Crypto.PubKey.RSA.Types as RSATypes -import Data.Binary (get) -import Data.Binary.Put (putWord64be, runPut) -import Data.Bits (countLeadingZeros, shiftL, shiftR, xor) -import Data.Bifunctor (first) -import qualified Data.ByteArray as BA -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Conduit -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL -import Data.Conduit.OpenPGP.Compression (conduitDecompress) -import Data.Conduit.Serialization.Binary (conduitGet) -import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) -import Data.List (intercalate, nub) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (catMaybes, isNothing, mapMaybe) -import Data.Word (Word16, Word8, Word64) - -import Codec.Encryption.OpenPGP.CFB (decryptOpenPGPCfb, decryptPreservingNonce, validateSEIPD1MDC, calculateMDC) -import Codec.Encryption.OpenPGP.Internal (leftPadTo) -import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher) -import Codec.Encryption.OpenPGP.Internal.CryptoECDH - ( normalizeMontgomeryPublic - , buildECDHKDFParam - , deriveECDHKek - ) -import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) -import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 - ( aeadModeAndNonceSizeForSEIPDv2 - , decryptSKESK6SessionKey - , deriveSKESK6KEK - , seipdv2SymmetricKeySize - ) -import Codec.Encryption.OpenPGP.Policy - ( DecryptPolicy(..) - , defaultDecryptPolicy - , validateTable30PolicyForRecipient - ) -import Codec.Encryption.OpenPGP.Internal.RFC7253OCB (decryptWithOCBRFC7253With) -import Codec.Encryption.OpenPGP.S2K - ( decodeOpenPGPEncodedSessionKey - , renderEncodedSessionKeyError - , renderS2KError - , S2KError(..) - , skesk2Key - , skesk2SessionKey - , string2Key - ) -import Codec.Encryption.OpenPGP.Types -import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey) -import Control.Lens ((.~), ix) -import Data.Conduit.OpenPGP.Keyring.Instances () -import qualified Data.IxSet.Typed as IxSet - -data RecursorState = - RecursorState - { _depth :: Int - , _pendingESKs :: [PendingESK] - , _lastNonce :: Maybe B.ByteString - , _lastClearText :: Maybe B.ByteString - , _decryptPolicy :: DecryptPolicy - } - deriving (Eq, Show) - -def :: RecursorState -def = RecursorState 0 [] Nothing Nothing defaultDecryptPolicy - -data DecryptStreamPhase - = ActiveDecryptPhase - | FinishedDecryptPhase - | MalformedDecryptPhase - -data DecryptStreamState (phase :: DecryptStreamPhase) where - ActiveDecryptState :: - RecursorState - -> DecryptStreamState 'ActiveDecryptPhase - FinishedDecryptState :: - RecursorState - -> Bool - -> DecryptStreamState 'FinishedDecryptPhase - MalformedDecryptState :: - RecursorState - -> String - -> DecryptStreamState 'MalformedDecryptPhase - -data SomeDecryptStreamState where - SomeDecryptStreamState :: - DecryptStreamState phase - -> SomeDecryptStreamState - -data PendingESK - = PendingPKESK PKESKPayload - | PendingSKESK SKESKPayload - deriving (Eq, Show) - -data EncryptedPayloadVersion - = LegacyEncryptedPayloadVersion - | SEIPDv2EncryptedPayloadVersion - -data EncryptedPayloadFlavor (v :: EncryptedPayloadVersion) where - LegacyEncryptedPayload :: EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion - SEIPDv2EncryptedPayload :: - SymmetricAlgorithm - -> AEADAlgorithm - -> EncryptedPayloadFlavor 'SEIPDv2EncryptedPayloadVersion - -type InputCallback m = String -> m BL.ByteString - -data PKESKRecipientKey = - PKESKRecipientKey - { pkeskRecipientPKPayload :: Maybe SomePKPayload - -- ^ Public key payload for the recipient. Required for X25519, X448, - -- and ECDH unwrap paths; may be 'Nothing' for RSA. - , pkeskRecipientSKey :: SKey - -- ^ Corresponding secret key. - } - -data PKESKAttemptFailure = - PKESKAttemptFailure - { pkeskAttemptFailureKeyContext :: Maybe (KeyVersion, PubKeyAlgorithm) - , pkeskAttemptFailureKind :: PKESKAttemptFailureKind - , pkeskAttemptFailureReason :: String - } - deriving (Eq, Show) - -data PKESKAttemptFailureKind - = PKESKAttemptUnwrapFailed - | PKESKAttemptSessionMaterialDecodeFailed - deriving (Eq, Show) - -data PKESKResolverError - = ResolverPolicyDenied String - | ResolverBackendUnavailable String - | ResolverInvalidResponse String - deriving (Eq, Show) - -data PKESKResolveRequest = - PKESKResolveRequest - { reqPKESK :: PKESKPayload - , reqProbePacket :: Pkt - , reqIsWildcardRecipient :: Bool - , reqAttemptIndex :: Int - , reqPreviousFailures :: [PKESKAttemptFailure] - } - deriving (Eq, Show) - -data PKESKResolveAction - = ResolveWith PKESKRecipientKey - | ResolveSkip - | ResolveExhausted - | ResolveFail PKESKResolverError - -type PKESKResolver m = PKESKResolveRequest -> m PKESKResolveAction - --- | Build a stateful 'PKESKResolver' that iterates over a pre-populated --- candidate list. The returned resolver yields candidates in order and --- returns 'ResolveExhausted' once the list is depleted. --- | How to resolve secret keys for PKESK-encrypted messages. -data DecryptKeyResolution - = DecryptWithoutPKESK - -- ^ Do not attempt PKESK decryption; fall through to manual session-key - -- input via the passphrase callback instead. - | DecryptWithKeyring SecretKeyring - -- ^ Resolve secret keys from a 'SecretKeyring'. Only unencrypted secret - -- keys (not passphrase-protected) are used. For passphrase-protected keys, - -- use 'DecryptWithKeyringAndPassphrase'. - | DecryptWithKeyringAndPassphrase SecretKeyring (SomePKPayload -> IO (Maybe BL.ByteString)) - -- ^ Resolve secret keys from a 'SecretKeyring', unlocking passphrase- - -- protected keys using the provided callback. The callback receives the - -- public key payload and returns the passphrase, or 'Nothing' to skip. - | DecryptWithUnwrapCandidatesCallback (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]) - -- ^ Preferred callback form for non-keyring key material. The callback - -- receives a typed key identifier (8-octet key ID, fingerprint, or - -- wildcard) plus the packet public-key algorithm, then returns all - -- matching candidates in priority order. hOpenPGP iterates candidates - -- deterministically without re-calling the callback for each retry. - --- | Canonical decrypt configuration. --- --- Most callers should prefer 'conduitDecrypt' and set: --- --- * 'decryptOptionsKeyResolution' to 'DecryptWithKeyring' or 'DecryptWithKeyringAndPassphrase' --- * 'decryptOptionsPolicy' to strict ('defaultDecryptPolicy') or lenient --- * 'decryptOptionsPassphraseCallback' for SKESK passphrase lookup -data DecryptOptions = - DecryptOptions - { decryptOptionsKeyResolution :: DecryptKeyResolution - , decryptOptionsPolicy :: DecryptPolicy - , decryptOptionsPassphraseCallback :: InputCallback IO - } - --- | Outcome of a checked decrypt conduit run. --- --- Use 'conduitDecrypt' to obtain this value. Because --- 'Data.Conduit..|' preserves the --- /rightmost/ conduit's return value, callers who also need the decrypted --- packet stream should use 'Data.Conduit.fuseBoth': --- --- @ --- (outcome, pkts) \<- runConduit $ source .| fuseBoth (conduitDecrypt opts) CL.consume --- @ -data DecryptOutcome - = DecryptClean - -- ^ The integrity-terminating marker (MDC or SEIPD v2 final AEAD tag) - -- was seen and no further packets arrived. The message was - -- well-formed end-to-end. - | DecryptTruncated - -- ^ The input stream ended before any integrity-terminating marker was - -- seen. The ciphertext was incomplete. - | DecryptTrailingData - -- ^ An integrity-terminating marker was seen, but additional packets - -- followed it. Only possible with 'lenientDecryptPolicy' (strict - -- policy reports 'DecryptMalformedStructure' instead). The trailing - -- packets were forwarded downstream unchanged. - | DecryptMalformedStructure String - -- ^ A structural packet-sequencing violation was detected. The - -- 'String' describes the specific violation: - -- - -- * PKESK version does not match the SEIPD version (e.g. a v6 PKESK - -- preceding a SEIPDv1 payload, or a v4 SKESK preceding a SEIPDv2 - -- payload). - -- - -- * ESK packets arrived in the wrong order relative to the encrypted - -- data packet (e.g. a literal-data packet appeared between a PKESK - -- and the SEIPD it was intended to protect). - -- - -- * A packet arrived after the message integrity boundary (trailing - -- data). Under 'defaultDecryptPolicy' this is reported here; under - -- 'lenientDecryptPolicy' it is reported as 'DecryptTrailingData' - -- instead. - deriving (Eq, Show) - -data DecryptSessionKeyResolutionPath - = DecryptResolvedViaSKESK - | DecryptResolvedViaPKESK - | DecryptResolvedViaManualPKESKInput - deriving (Eq, Show) - -data PKESKResolverAttemptAction - = ResolverAttemptResolveWith (Maybe (KeyVersion, PubKeyAlgorithm)) - | ResolverAttemptSkip - | ResolverAttemptExhausted - | ResolverAttemptFail PKESKResolverError - deriving (Eq, Show) - -data PKESKResolverAttempt = - PKESKResolverAttempt - { pkeskResolverAttemptPreviousFailures :: [PKESKAttemptFailure] - -- ^ Failures from earlier attempts on the same PKESK packet. - , pkeskResolverAttemptAction :: PKESKResolverAttemptAction - } - deriving (Eq, Show) - -data DecryptSessionKeyResolutionReport = - DecryptSessionKeyResolutionReport - { decryptSessionResolutionPath :: DecryptSessionKeyResolutionPath - , decryptSessionResolutionSKESKErrors :: [String] - , decryptSessionResolutionPKESKErrors :: [String] - , decryptSessionResolutionResolverAttempts :: [PKESKResolverAttempt] - } - deriving (Eq, Show) - -data DecryptReport = - DecryptReport - { decryptReportOutcome :: DecryptOutcome - , decryptReportSessionKeyResolutions :: [DecryptSessionKeyResolutionReport] - } - deriving (Eq, Show) - --- | AEAD decryption context (Reader monad eliminates parameter threading) -data AEADDecryptContext cipher = - AEADDecryptContext - { aeadMode :: CCT.AEADMode - , aeadInfo :: B.ByteString - , aeadChunkSize :: Word8 - , aeadNoncePrefix :: B.ByteString - , aeadCipher :: cipher - } - --- | ReaderT wrapper for AEAD decryption computations -type AEADDecrypt cipher = ReaderT (AEADDecryptContext cipher) (Either String) - -conduitDecrypt :: - (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) - => DecryptOptions - -> ConduitT Pkt Pkt m DecryptOutcome -conduitDecrypt opts = - decryptReportOutcome <$> conduitDecryptWithReport opts - -conduitDecryptWithReport :: - (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) - => DecryptOptions - -> ConduitT Pkt Pkt m DecryptReport -conduitDecryptWithReport opts = do - reportRef <- liftIO (newIORef []) - resolver <- liftIO (buildDecryptResolver (decryptOptionsKeyResolution opts)) - let allowManualPKESKPrompt = - case decryptOptionsKeyResolution opts of - DecryptWithoutPKESK -> True - _ -> False - outcome <- - conduitDecryptChecked' - (def {_decryptPolicy = decryptOptionsPolicy opts}) - allowManualPKESKPrompt - resolver - (decryptOptionsPassphraseCallback opts) - (Just reportRef) - resolutions <- reverse <$> liftIO (readIORef reportRef) - pure - DecryptReport - { decryptReportOutcome = outcome - , decryptReportSessionKeyResolutions = resolutions - } - --- | Build an internal 'PKESKResolver' from the public 'DecryptKeyResolution'. -buildDecryptResolver :: DecryptKeyResolution -> IO (PKESKResolver IO) -buildDecryptResolver DecryptWithoutPKESK = - pure (\_ -> pure ResolveExhausted) -buildDecryptResolver (DecryptWithKeyring kr) = - buildKeyringResolver kr Nothing -buildDecryptResolver (DecryptWithKeyringAndPassphrase kr cb) = - buildKeyringResolver kr (Just cb) -buildDecryptResolver (DecryptWithUnwrapCandidatesCallback cb) = - buildUnwrapCandidatesResolver cb - --- | Build a stateful resolver that looks up keys from a 'SecretKeyring'. -buildKeyringResolver :: - SecretKeyring - -> Maybe (SomePKPayload -> IO (Maybe BL.ByteString)) - -> IO (PKESKResolver IO) -buildKeyringResolver kr maybePassphraseCb = do - -- Tracks (last PKESK, remaining wildcard candidates once initialized). - stateRef <- newIORef (Nothing :: Maybe PKESKPayload, Nothing :: Maybe [PKESKRecipientKey]) - pure $ \req -> do - let pkesk = reqPKESK req - probe = reqProbePacket req - (lastPKESK, wildcardState) <- readIORef stateRef - let freshPKESK = Just pkesk /= lastPKESK - when freshPKESK $ writeIORef stateRef (Just pkesk, Nothing) - let wc = if freshPKESK then Nothing else wildcardState - case extractProbeKeyIdentifier probe of - KeyIdentifierWildcard -> do - -- Wildcard probe: iterate all keys - candidates <- case wc of - Nothing -> keyringCandidates (IxSet.toList kr) - Just cs -> pure cs - case candidates of - [] -> do - writeIORef stateRef (Just pkesk, Just []) - pure ResolveExhausted - (rk:rest) -> do - writeIORef stateRef (Just pkesk, Just rest) - pure (ResolveWith rk) - keyIdentifier -> do - -- Exact probe: direct lookup by key ID or fingerprint - let matchingTKs = matchingTKsForRecipient keyIdentifier - priorFailures = length (reqPreviousFailures req) - candidates <- keyringCandidates matchingTKs - case drop priorFailures candidates of - [] -> pure ResolveSkip - (rk:_) -> pure (ResolveWith rk) - where - matchingTKsForRecipient :: KeyIdentifier -> [TK 'SecretTK] - matchingTKsForRecipient keyIdentifier = - case keyIdentifier of - KeyIdentifierWildcard -> IxSet.toList kr - KeyIdentifierEightOctet rid -> IxSet.toList (kr IxSet.@= rid) - KeyIdentifierFingerprint rid -> - let indexedMatches = IxSet.toList (kr IxSet.@= rid) - in if null indexedMatches - then filter (tkMatchesRecipientFingerprint rid) (IxSet.toList kr) - else indexedMatches - - tkMatchesRecipientFingerprint :: Fingerprint -> TK 'SecretTK -> Bool - tkMatchesRecipientFingerprint rid tk = - any - (keyPktMatchesRecipientFingerprint rid) - (_tkPrimaryKey tk : map fst (_tkSubs tk)) - - keyPktMatchesRecipientFingerprint :: - Fingerprint -> KeyPkt 'SecretPkt -> Bool - keyPktMatchesRecipientFingerprint rid (KeyPktSecretPrimary pkp _) = - pkPayloadMatchesRecipientFingerprint rid pkp - keyPktMatchesRecipientFingerprint rid (KeyPktSecretSubkey pkp _) = - pkPayloadMatchesRecipientFingerprint rid pkp - - pkPayloadMatchesRecipientFingerprint :: Fingerprint -> SomePKPayload -> Bool - pkPayloadMatchesRecipientFingerprint rid pkp = - fingerprint pkp `elem` recipientFingerprintMatchVariants rid - - recipientFingerprintMatchVariants :: Fingerprint -> [Fingerprint] - recipientFingerprintMatchVariants (Fingerprint rid) - | BL.length rid == 20 = [Fingerprint rid, Fingerprint (BL.cons 0x04 rid)] - | BL.length rid == 21 && BL.head rid == 0x04 = [Fingerprint rid, Fingerprint (BL.tail rid)] - | BL.length rid == 32 = [Fingerprint rid, Fingerprint (BL.cons 0x06 rid)] - | BL.length rid == 33 && BL.head rid == 0x06 = [Fingerprint rid, Fingerprint (BL.tail rid)] - | otherwise = [Fingerprint rid] - - keyringCandidates :: [TK 'SecretTK] -> IO [PKESKRecipientKey] - keyringCandidates tks = concat <$> mapM tkCandidates tks - - tkCandidates :: TK 'SecretTK -> IO [PKESKRecipientKey] - tkCandidates tk = - fmap catMaybes . mapM resolveKeyPair $ - _tkPrimaryKey tk : map fst (_tkSubs tk) - - resolveKeyPair :: KeyPkt 'SecretPkt -> IO (Maybe PKESKRecipientKey) - resolveKeyPair (KeyPktSecretPrimary pkp (SUUnencrypted sk _)) = - pure $ Just PKESKRecipientKey {pkeskRecipientPKPayload = Just pkp, pkeskRecipientSKey = sk} - resolveKeyPair (KeyPktSecretSubkey pkp (SUUnencrypted sk _)) = - pure $ Just PKESKRecipientKey {pkeskRecipientPKPayload = Just pkp, pkeskRecipientSKey = sk} - resolveKeyPair (KeyPktSecretPrimary pkp ska) = unlockProtected pkp ska - resolveKeyPair (KeyPktSecretSubkey pkp ska) = unlockProtected pkp ska - - unlockProtected :: SomePKPayload -> SKAddendum -> IO (Maybe PKESKRecipientKey) - unlockProtected pkp ska = - case maybePassphraseCb of - Nothing -> pure Nothing - Just passphraseCb -> do - mPassphrase <- passphraseCb pkp - case mPassphrase of - Nothing -> pure Nothing - Just passphrase -> - case decryptPrivateKey (pkp, ska) passphrase of - Left _ -> pure Nothing - Right (SUUnencrypted sk _) -> - pure $ Just PKESKRecipientKey {pkeskRecipientPKPayload = Just pkp, pkeskRecipientSKey = sk} - Right _ -> pure Nothing - -buildUnwrapCandidatesResolver :: - (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]) - -> IO (PKESKResolver IO) -buildUnwrapCandidatesResolver cb = do - stateRef <- newIORef (Nothing :: Maybe PKESKPayload, [] :: [(Pkt, [PKESKRecipientKey])], [] :: [SKey]) - pure $ \req -> do - let pkesk = reqPKESK req - probePkt = reqProbePacket req - (lastPKESK, probeState, seenSKeys) <- readIORef stateRef - let freshPKESK = Just pkesk /= lastPKESK - when freshPKESK $ writeIORef stateRef (Just pkesk, [], []) - let state0 = if freshPKESK then [] else probeState - seen0 = if freshPKESK then [] else seenSKeys - case lookup probePkt state0 of - Just (next:rest) -> do - writeIORef - stateRef - ( Just pkesk - , updateProbeState probePkt rest state0 - , pkeskRecipientSKey next : seen0 - ) - pure (ResolveWith next) - Just [] -> - pure ResolveSkip - Nothing -> do - candidates <- filterFreshCandidates seen0 <$> callbackCandidates probePkt - case candidates of - [] -> do - writeIORef stateRef (Just pkesk, updateProbeState probePkt [] state0, seen0) - pure ResolveSkip - (next:rest) -> do - writeIORef - stateRef - ( Just pkesk - , updateProbeState probePkt rest state0 - , pkeskRecipientSKey next : seen0 - ) - pure (ResolveWith next) - where - callbackCandidates probePkt = - cb (extractProbeKeyIdentifier probePkt) (extractProbePKA probePkt) - - updateProbeState probePkt remaining state0 = - (probePkt, remaining) : filter ((/= probePkt) . fst) state0 - - filterFreshCandidates seenSKeys = - filter (\candidate -> pkeskRecipientSKey candidate `notElem` seenSKeys) - --- | Extract the recipient identifier from a PKESK probe packet. -extractProbeKeyIdentifier :: Pkt -> KeyIdentifier -extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid _ _))) - | isWildcardV3RecipientKeyId rid = KeyIdentifierWildcard - | otherwise = KeyIdentifierEightOctet rid -extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _))) - | BL.null rid = KeyIdentifierWildcard - | otherwise = KeyIdentifierFingerprint (Fingerprint rid) -extractProbeKeyIdentifier _ = KeyIdentifierWildcard - -isWildcardV3RecipientKeyId :: EightOctetKeyId -> Bool -isWildcardV3RecipientKeyId (EightOctetKeyId rid) = - BL.length rid == 8 && BL.all (== 0) rid - --- | Extract the public-key algorithm from a PKESK probe packet. -extractProbePKA :: Pkt -> PubKeyAlgorithm -extractProbePKA (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) = pka -extractProbePKA (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ pka _))) = pka -extractProbePKA _ = RSA -- fallback; should not be reached - --- | Core implementation: manual await loop so we can return a 'DecryptOutcome'. -conduitDecryptChecked' :: - (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) - => RecursorState - -> Bool - -> PKESKResolver IO - -> InputCallback IO - -> Maybe (IORef [DecryptSessionKeyResolutionReport]) - -> ConduitT Pkt Pkt m DecryptOutcome -conduitDecryptChecked' rs0 allowManualPKESKPrompt pkcb cb reportRef = - loop (SomeDecryptStreamState (ActiveDecryptState rs0)) - where - loop :: - (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) - => SomeDecryptStreamState -> ConduitT Pkt Pkt m DecryptOutcome - loop streamState = do - case streamState of - SomeDecryptStreamState (MalformedDecryptState _ reason) -> - return (DecryptMalformedStructure reason) - SomeDecryptStreamState state -> do - mpkt <- await - case mpkt of - Nothing -> return (finalOutcome state) - Just pkt -> do - (state', pkts) <- lift (push pkt state) - mapM_ yield pkts - loop state' - - push :: - (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m) - => Pkt - -> DecryptStreamState phase - -> m (SomeDecryptStreamState, [Pkt]) - push i (ActiveDecryptState s) - | _depth s > 42 = fail "I think we've been quine-attacked" - | hasPendingESKPrelude s && not (packetCanFollowESKPrelude i) = - return - ( SomeDecryptStreamState - (MalformedDecryptState - s - "Malformed encrypted packet sequence: ESK packets must immediately precede encrypted data") - , [] ) - | otherwise = - let dp = _decryptPolicy s - in case i of - SKESKPkt payload -> - do - when (decryptRejectDeprecatedSKESK dp) $ - case skeskPayloadS2K payload of - Simple _ -> - fail "SKESK uses Simple S2K specifier, which is deprecated by RFC9580 policy" - Salted _ _ -> - fail "SKESK uses Salted S2K specifier, which is deprecated by RFC9580 policy" - _ -> pure () - return - ( SomeDecryptStreamState - (ActiveDecryptState - (s {_pendingESKs = _pendingESKs s ++ [PendingSKESK payload]})) - , [] ) - PKESKPkt p -> - return - ( SomeDecryptStreamState - (ActiveDecryptState - (s {_pendingESKs = _pendingESKs s ++ [PendingPKESK p]})) - , [] ) - (SymEncDataPkt bs) -> - if hasESKPayloadVersionMismatch dp LegacyEncryptedPayload s - then - return - ( SomeDecryptStreamState - (MalformedDecryptState - s - ("ESK/payload version mismatch: ESK packets present but none are version-aligned with " ++ - "legacy SED payload")) - , [] ) - else do - when (not (decryptAllowSEDNoIntegrity dp)) $ - fail - "Received unauthenticated SED (Symmetrically Encrypted Data) packet; \ - \RFC9580 policy requires integrity-protected SEIPD. \ - \Use lenientDecryptPolicy to permit legacy messages." - (symalgo, sessionKey) <- - resolveSessionKey - s - allowManualPKESKPrompt - pkcb - cb - LegacyEncryptedPayload - reportRef - checkDecryptSymmetricAlgo dp symalgo - d <- - decryptSEDP - s {_pendingESKs = []} - allowManualPKESKPrompt - pkcb - cb - reportRef - symalgo - sessionKey - bs - -- SED is the terminal outer-stream packet. - return (finalizeOuterEncryptedPayload s d) - (SymEncIntegrityProtectedDataPkt (SEIPD1 _ bs)) -> - if hasESKPayloadVersionMismatch dp LegacyEncryptedPayload s - then - return - ( SomeDecryptStreamState - (MalformedDecryptState - s - ("ESK/payload version mismatch: ESK packets present but none are version-aligned with " ++ - "SEIPDv1 payload")) - , [] ) - else do - when (not (decryptAllowSEIPDv1 dp)) $ - fail - "Received SEIPDv1 packet; decrypt policy requires SEIPDv2 only." - (symalgo, sessionKey) <- - resolveSessionKey - s - allowManualPKESKPrompt - pkcb - cb - LegacyEncryptedPayload - reportRef - checkDecryptSymmetricAlgo dp symalgo - d <- - decryptSEIPDP - s {_pendingESKs = []} - allowManualPKESKPrompt - pkcb - cb - reportRef - symalgo - sessionKey - bs - -- The outer SEIPD1 packet is terminal; inner MDC is handled by - -- the recursive conduit's own _seenMessageEnd tracking. - return (finalizeOuterEncryptedPayload s d) - (SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) -> - if hasESKPayloadVersionMismatch dp (SEIPDv2EncryptedPayload sa aa) s - then - return - ( SomeDecryptStreamState - (MalformedDecryptState - s - ("ESK/payload version mismatch: ESK packets present but none are version-aligned with " ++ - "SEIPDv2 payload")) - , [] ) - else do - checkDecryptSymmetricAlgo dp sa - checkDecryptAEADAlgo dp aa - (_, sessionKey) <- - resolveSessionKey - s - allowManualPKESKPrompt - pkcb - cb - (SEIPDv2EncryptedPayload sa aa) - reportRef - d <- - decryptSEIPDv2P - s {_pendingESKs = []} - allowManualPKESKPrompt - pkcb - cb - reportRef - sa - aa - chunkSize - salt - sessionKey - bs - -- SEIPD2 final AEAD tag was verified inside decryptSEIPDv2P. - return (finalizeOuterEncryptedPayload s d) - m@(ModificationDetectionCodePkt mdc) -> do - when (isNothing (_lastClearText s)) $ fail "MDC with no referent" - let mcalculated = calculateMDC <$> _lastNonce s <*> _lastClearText s - expectedMdc <- - case mcalculated of - Nothing -> fail "MDC with no nonce or cleartext" - Just Nothing -> fail "MDC referent is too short" - Just (Just x) -> return x - when (expectedMdc /= mdc) $ - fail $ - "MDC indicates tampering: " ++ - show mdc ++ - " versus " ++ - maybe "" show mcalculated ++ - " ... " ++ - show (_lastNonce s) ++ " / " ++ show (_lastClearText s) - -- MDC is the integrity boundary inside a SEIPD1 inner stream. - return - ( SomeDecryptStreamState (FinishedDecryptState s False) - , [m] ) - -- RFC9580 Padding Packet (tag 21) can be ignored after decryption. - (OtherPacketPkt 21 _) -> - return (SomeDecryptStreamState (ActiveDecryptState s), []) - (OtherPacketPkt t _) | t < 40 -> - fail ("Unknown critical packet type in packet sequence: " ++ show t) - (OtherPacketPkt _ _) -> - return (SomeDecryptStreamState (ActiveDecryptState s), []) - p -> - return (SomeDecryptStreamState (ActiveDecryptState s), [p]) - push i (FinishedDecryptState s hadTrailing) = - if decryptRejectTrailingData (_decryptPolicy s) - then - return - ( SomeDecryptStreamState - (MalformedDecryptState - s - "packet received after message integrity boundary") - , [] ) - else - return - (SomeDecryptStreamState (FinishedDecryptState s True), [i]) - push _ malformedState@(MalformedDecryptState _ _) = - return (SomeDecryptStreamState malformedState, []) - - hasPendingESKPrelude s = not (null (_pendingESKs s)) - - hasESKPayloadVersionMismatch dp payloadFlavor state = - decryptRejectESKVersionMismatch dp - && hasPendingESKPrelude state - && null (alignedPrecedingESKs payloadFlavor (_pendingESKs state)) - - finalizeOuterEncryptedPayload state decryptedPkts = - ( SomeDecryptStreamState - (FinishedDecryptState (state { _pendingESKs = [] }) False) - , decryptedPkts ) - - finalOutcome :: DecryptStreamState phase -> DecryptOutcome - finalOutcome (ActiveDecryptState _) = DecryptTruncated - finalOutcome (FinishedDecryptState _ hadTrailing) = - if hadTrailing - then DecryptTrailingData - else DecryptClean - finalOutcome (MalformedDecryptState _ reason) = - DecryptMalformedStructure reason - - packetCanFollowESKPrelude pkt = - case pkt of - SKESKPkt _ -> True - PKESKPkt _ -> True - SymEncDataPkt _ -> True - SymEncIntegrityProtectedDataPkt _ -> True - MarkerPkt _ -> True - OtherPacketPkt 21 _ -> True - _ -> False - --- | Describes what integrity-terminating marker (if any) an inner packet --- stream is expected to contain. Passed to 'checkInnerOutcome' to --- distinguish a legitimate end-of-stream from a missing marker. -data InnerIntegrityExpectation - = NoIntegrityMarker - -- ^ The inner stream has no integrity-terminating packet. SED has none - -- by design; SEIPD2 authenticates via AEAD before the conduit runs. - -- 'DecryptTruncated' is the normal end-of-stream outcome. - --- | Propagate non-clean inner-stream outcomes as a 'fail'. Called after each --- recursive decrypt helper so that structural violations and (for SEIPD1) a --- missing MDC are not silently swallowed. -checkInnerOutcome :: MonadFail m => InnerIntegrityExpectation -> DecryptOutcome -> m () -checkInnerOutcome _ DecryptClean = pure () -checkInnerOutcome _ DecryptTrailingData = pure () -checkInnerOutcome NoIntegrityMarker DecryptTruncated = pure () -checkInnerOutcome _ (DecryptMalformedStructure reason) = - fail ("Inner encrypted payload had malformed structure: " ++ reason) - -decryptSEDP :: - (MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m) - => RecursorState - -> Bool - -> PKESKResolver IO - -> InputCallback IO - -> Maybe (IORef [DecryptSessionKeyResolutionReport]) - -> SymmetricAlgorithm - -> SessionKey - -> BL.ByteString - -> m [Pkt] -decryptSEDP rs allowManualPKESKPrompt pkcb cb reportRef symalgo (SessionKey sessionKey) bs = do - decrypted <- - case decryptOpenPGPCfb symalgo (BL.toStrict bs) sessionKey of - Left e -> fail (renderCipherError e) - Right x -> pure x - (innerOutcome, pkts) <- decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef decrypted - checkInnerOutcome NoIntegrityMarker innerOutcome - pure pkts - -decryptSEIPDP :: - (MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m) - => RecursorState - -> Bool - -> PKESKResolver IO - -> InputCallback IO - -> Maybe (IORef [DecryptSessionKeyResolutionReport]) - -> SymmetricAlgorithm - -> SessionKey - -> BL.ByteString - -> m [Pkt] -decryptSEIPDP rs allowManualPKESKPrompt pkcb cb reportRef symalgo (SessionKey sessionKey) bs = do - (nonce, decrypted) <- - case decryptPreservingNonce symalgo (BL.toStrict bs) sessionKey of - Left e -> fail (renderCipherError e) - Right x -> pure x - decryptedWithoutMDC <- - case validateSEIPD1MDC nonce decrypted of - Left err -> fail err - Right x -> pure x - (innerOutcome, pkts) <- decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef decryptedWithoutMDC - checkInnerOutcome NoIntegrityMarker innerOutcome - pure pkts - -decryptSEIPDv2P :: - (MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m) - => RecursorState - -> Bool - -> PKESKResolver IO - -> InputCallback IO - -> Maybe (IORef [DecryptSessionKeyResolutionReport]) - -> SymmetricAlgorithm - -> AEADAlgorithm - -> Word8 - -> Salt - -> SessionKey - -> BL.ByteString - -> m [Pkt] -decryptSEIPDv2P rs allowManualPKESKPrompt pkcb cb reportRef symalgo aeadalgo chunkSize salt sessionKey bs = do - let decrypted = - decryptSEIPDv2Payload - symalgo - aeadalgo - chunkSize - salt - (BL.toStrict bs) - sessionKey - case decrypted of - Left e -> fail e - Right cleartext -> do - (innerOutcome, pkts) <- - decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef cleartext - checkInnerOutcome NoIntegrityMarker innerOutcome - pure pkts - -decryptInnerPackets :: - (MonadFail m, MonadUnliftIO m, MonadThrow m) - => RecursorState - -> Bool - -> PKESKResolver IO - -> InputCallback IO - -> Maybe (IORef [DecryptSessionKeyResolutionReport]) - -> B.ByteString - -> m (DecryptOutcome, [Pkt]) -decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef cleartext = - runConduitRes $ - CB.sourceLbs (BL.fromStrict cleartext) .| conduitGet get .| conduitDecompress .| - fuseBoth - (conduitDecryptChecked' - rs {_depth = _depth rs + 1} - allowManualPKESKPrompt - pkcb - cb - reportRef) - CL.consume - -decryptSEIPDv2Payload :: - SymmetricAlgorithm - -> AEADAlgorithm - -> Word8 - -> Salt - -> B.ByteString - -> SessionKey - -> Either String B.ByteString -decryptSEIPDv2Payload symalgo aeadalgo chunkSize salt encrypted (SessionKey sessionKey) = do - when (chunkSize > 16) $ - Left "SEIPD v2 chunk size octet must be between 0 and 16" - (mode, nonceSize) <- aeadModeAndNonceSize aeadalgo - keyLen <- symKeySize symalgo - let outputLen = keyLen + nonceSize - 8 - when (B.length (unSalt salt) /= 32) $ - Left "SEIPD v2 salt must be exactly 32 octets" - when (B.length encrypted < 32) $ - Left "SEIPD v2 ciphertext must include at least one chunk tag and a final tag" - let info = - B.pack - [0xd2, 2, fromFVal symalgo, fromFVal aeadalgo, chunkSize] - prk = extract @CHA.SHA256 (unSalt salt) sessionKey - okm = expand @CHA.SHA256 prk info outputLen :: B.ByteString - messageKey = B.take keyLen okm - noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm) - decryptSEIPDv2WithKey - symalgo - mode - chunkSize - info - noncePrefix - messageKey - encrypted - -decryptSEIPDv2WithKey :: - SymmetricAlgorithm - -> CCT.AEADMode - -> Word8 - -> B.ByteString - -> B.ByteString - -> B.ByteString - -> B.ByteString - -> Either String B.ByteString -decryptSEIPDv2WithKey symalgo mode chunkSize info noncePrefix sessionKey encrypted = - withAESCipher - "SEIPD v2 decrypt currently supports AES-128/192/256 only" - symalgo - sessionKey - (decryptChunks mode info chunkSize noncePrefix encrypted) - -decryptChunks :: - CCT.BlockCipher cipher - => CCT.AEADMode - -> B.ByteString - -> Word8 - -> B.ByteString - -> B.ByteString - -> cipher - -> Either String B.ByteString -decryptChunks mode info chunkSize noncePrefix encrypted cipher = - let ctx = AEADDecryptContext mode info chunkSize noncePrefix cipher - in runReaderT decryptChunksWithReader ctx - where - decryptChunksWithReader :: CCT.BlockCipher cipher => AEADDecrypt cipher B.ByteString - decryptChunksWithReader = go 0 encrypted [] 0 - where - chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6) - tagLen = 16 - - go idx remaining acc totalPlain - | B.length remaining < 2 * tagLen = - lift $ Left "SEIPD v2 ciphertext is too short for chunk and final authentication tags" - | otherwise = do - let hasMoreChunks = B.length remaining > chunkLen + 2 * tagLen - currentChunkLen = - if hasMoreChunks - then chunkLen - else B.length remaining - 2 * tagLen - when (currentChunkLen < 0) $ - lift $ Left "SEIPD v2 malformed chunk lengths" - let (chunkCiphertext, r1) = B.splitAt currentChunkLen remaining - (chunkTag, r2) = B.splitAt tagLen r1 - plainChunk <- decryptChunkWithContext idx chunkCiphertext chunkTag - if hasMoreChunks - then go - (idx + 1) - r2 - (plainChunk : acc) - (totalPlain + B.length plainChunk) - else do - when (B.length r2 /= tagLen) $ - lift $ Left "SEIPD v2 missing final authentication tag" - verifyFinalTagWithContext - (idx + 1) - (totalPlain + B.length plainChunk) - r2 - return (B.concat (reverse (plainChunk : acc))) - - decryptChunkWithContext idx chunkCiphertext chunkTag = do - AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask - if mode' == CCT.AEAD_OCB - then - lift $ - decryptWithOCBRFC7253With - (\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed") - cipher' - (noncePrefix' <> encodeWord64be idx) - info - chunkCiphertext - (mkAuthTag chunkTag) - else do - aead <- initAEADWithContext idx - let mPlain = - CCT.aeadSimpleDecrypt - aead - info - chunkCiphertext - (mkAuthTag chunkTag) - case mPlain of - Nothing -> lift $ Left "SEIPD v2 chunk authentication failed" - Just p -> return p - - verifyFinalTagWithContext idx totalPlain finalTag = do - AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask - if mode' == CCT.AEAD_OCB - then do - plain <- - lift $ - decryptWithOCBRFC7253With - (\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed") - cipher' - (noncePrefix' <> encodeWord64be idx) - (info <> encodeWord64be (fromIntegral totalPlain)) - B.empty - (mkAuthTag finalTag) - if B.null plain - then return () - else lift $ Left "SEIPD v2 final authentication tag verification failed" - else do - aead <- initAEADWithContext idx - let mEmpty = - CCT.aeadSimpleDecrypt - aead - (info <> encodeWord64be (fromIntegral totalPlain)) - B.empty - (mkAuthTag finalTag) - case mEmpty of - Just p | B.null p -> return () - _ -> lift $ Left "SEIPD v2 final authentication tag verification failed" - - initAEADWithContext idx = do - AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask - lift $ first show . CE.eitherCryptoError $ - CCT.aeadInit mode' cipher' (noncePrefix' <> encodeWord64be idx) - -aeadModeAndNonceSize :: AEADAlgorithm -> Either String (CCT.AEADMode, Int) -aeadModeAndNonceSize = - aeadModeAndNonceSizeForSEIPDv2 - "Unknown AEAD algorithm for SEIPD v2 decrypt" - -symKeySize :: SymmetricAlgorithm -> Either String Int -symKeySize = - seipdv2SymmetricKeySize - "SEIPD v2 decrypt currently supports AES-128/192/256 only" - -encodeWord64be :: Word64 -> B.ByteString -encodeWord64be = BL.toStrict . runPut . putWord64be - -mkAuthTag :: B.ByteString -> CCT.AuthTag -mkAuthTag = CCT.AuthTag . BA.convert - -checkDecryptSymmetricAlgo :: MonadFail m => DecryptPolicy -> SymmetricAlgorithm -> m () -checkDecryptSymmetricAlgo dp sa = - case decryptAllowedSymmetricAlgos dp of - Nothing -> pure () - Just allowed - | sa `elem` allowed -> pure () - | otherwise -> - fail $ - "Decrypt policy rejects symmetric algorithm " ++ - show sa ++ - "; allowed: " ++ - show allowed - -checkDecryptAEADAlgo :: MonadFail m => DecryptPolicy -> AEADAlgorithm -> m () -checkDecryptAEADAlgo dp aa = - case decryptAllowedAEADAlgos dp of - Nothing -> pure () - Just allowed - | aa `elem` allowed -> pure () - | otherwise -> - fail $ - "Decrypt policy rejects AEAD algorithm " ++ - show aa ++ - "; allowed: " ++ - show allowed - -skeskPayloadSymmetricAlgorithm :: SKESKPayload -> SymmetricAlgorithm -skeskPayloadSymmetricAlgorithm payload = - case classifySKESKPayload payload of - ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa _ _) -> sa - ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa _ _ _ _ _) -> sa - -skeskPayloadS2K :: SKESKPayload -> S2K -skeskPayloadS2K payload = - case classifySKESKPayload payload of - ClassifiedSKESKPayloadV4 (SKESKPayloadV4 _ s2k _) -> s2k - ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ _ s2k _ _ _) -> s2k - -skeskPayloadAEADAlgorithm :: SKESKPayload -> Maybe AEADAlgorithm -skeskPayloadAEADAlgorithm payload = - case classifySKESKPayload payload of - ClassifiedSKESKPayloadV4 _ -> Nothing - ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ aa _ _ _ _) -> Just aa - -resolveSKESKSessionKey :: BL.ByteString -> SKESKPayload -> Either String B.ByteString -resolveSKESKSessionKey passphrase payload = - first renderSKESKSessionKeyResolutionError $ - resolveSKESKSessionKeyTyped passphrase (classifySKESKPayload payload) - -data SKESKSessionKeyResolutionError - = SKESKSessionKeyS2KError S2KError - | SKESKSessionKeyOtherError String - deriving (Eq, Show) - -renderSKESKSessionKeyResolutionError :: SKESKSessionKeyResolutionError -> String -renderSKESKSessionKeyResolutionError (SKESKSessionKeyS2KError err) = renderS2KError err -renderSKESKSessionKeyResolutionError (SKESKSessionKeyOtherError err) = err - -resolveSKESKSessionKeyTyped :: - BL.ByteString - -> ClassifiedSKESKPayload - -> Either SKESKSessionKeyResolutionError B.ByteString -resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k Nothing)) = - first - SKESKSessionKeyS2KError - (skesk2Key (SKESK4Packet sa s2k Nothing) passphrase) -resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k (Just esk))) = - first - SKESKSessionKeyS2KError - (snd <$> skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase) -resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aead s2k iv esk tag)) = do - keyLen <- first (SKESKSessionKeyS2KError . S2KUnsupportedAlgorithm) (keySize sa) - ikm <- first SKESKSessionKeyS2KError (string2Key s2k keyLen passphrase) - kek <- first SKESKSessionKeyOtherError (deriveSKESK6KEK sa aead ikm) - first - SKESKSessionKeyOtherError - (decryptSKESK6SessionKey sa aead kek (BL.toStrict iv) (BL.toStrict esk) (BL.toStrict tag)) - -data ClassifiedSKESKPayload where - ClassifiedSKESKPayloadV4 :: SKESKPayloadV4 -> ClassifiedSKESKPayload - ClassifiedSKESKPayloadV6 :: SKESKPayloadV6 -> ClassifiedSKESKPayload - -classifySKESKPayload :: SKESKPayload -> ClassifiedSKESKPayload -classifySKESKPayload (SKESKPayloadV4Packet payloadV4) = - ClassifiedSKESKPayloadV4 payloadV4 -classifySKESKPayload (SKESKPayloadV6Packet payloadV6) = - ClassifiedSKESKPayloadV6 payloadV6 - -resolveSessionKey :: - (MonadFail m, MonadIO m) - => RecursorState - -> Bool - -> PKESKResolver IO - -> InputCallback IO - -> EncryptedPayloadFlavor v - -> Maybe (IORef [DecryptSessionKeyResolutionReport]) - -> m (SymmetricAlgorithm, SessionKey) -resolveSessionKey rs allowManualPKESKPrompt pkcb cb payloadFlavor reportRef = - case precedingCandidates of - [] -> - if null (_pendingESKs rs) - then fail "Encrypted data packet has no preceding SKESK or PKESK packet" - else - fail - "Encrypted data packet has no preceding SKESK or PKESK packet aligned with payload version" - candidates -> - case skeskCandidates candidates of - [] -> resolvePKESKCandidates (pkeskCandidates candidates) [] [] [] - skesks -> do - passphrase <- liftIO $ cb "Input the passphrase I want" - resolveSKESKCandidates passphrase skesks (pkeskCandidates candidates) [] - where - precedingCandidates - | strictAlignment = alignedByVersion - | null alignedByVersion = _pendingESKs rs - | otherwise = alignedByVersion - - strictAlignment = decryptRejectESKVersionMismatch (_decryptPolicy rs) - alignedByVersion = pendingESKsFromAligned alignedStrict - alignedStrict = alignedPrecedingESKs payloadFlavor (_pendingESKs rs) - - skeskCandidates esks = reverse [skesk | PendingSKESK skesk <- esks] - - pkeskCandidates esks = reverse [pkesk | PendingPKESK pkesk <- esks] - - resolveSKESKCandidates :: - (MonadFail m, MonadIO m) - => BL.ByteString - -> [SKESKPayload] - -> [PKESKPayload] - -> [String] - -> m (SymmetricAlgorithm, SessionKey) - resolveSKESKCandidates _ [] pkesks skeskErrs = - resolvePKESKCandidates pkesks skeskErrs [] [] - resolveSKESKCandidates passphrase (skesk:rest) pkesks skeskErrs = - case resolveSKESKCandidate passphrase skesk of - Left err -> - resolveSKESKCandidates - passphrase - rest - pkesks - ((skeskErrPrefix skesk ++ err) : skeskErrs) - Right resolved -> do - emitResolutionReport - (mkResolutionReport DecryptResolvedViaSKESK skeskErrs [] []) - pure resolved - - resolveSKESKCandidate :: - BL.ByteString - -> SKESKPayload - -> Either String (SymmetricAlgorithm, SessionKey) - resolveSKESKCandidate passphrase skesk = do - let skeskSymAlgo = skeskPayloadSymmetricAlgorithm skesk - expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor - sessionKeyBytes <- resolveSKESKSessionKey passphrase skesk - case expectedSymAlgo of - Just expected | expected /= skeskSymAlgo -> - Left "SKESK/encrypted-payload symmetric algorithm mismatch" - _ -> - case (payloadExpectedAEADAlgorithm payloadFlavor, skeskPayloadAEADAlgorithm skesk) of - (Just expectedAEAD, Just skeskAEAD) - | expectedAEAD /= skeskAEAD -> - Left "SKESK/encrypted-payload AEAD algorithm mismatch" - _ -> Right (skeskSymAlgo, SessionKey sessionKeyBytes) - - skeskErrPrefix skesk = "[" ++ describeSKESK skesk ++ "] " - - resolvePKESKCandidates :: - (MonadFail m, MonadIO m) - => [PKESKPayload] - -> [String] - -> [String] - -> [PKESKResolverAttempt] - -> m (SymmetricAlgorithm, SessionKey) - resolvePKESKCandidates [] [] [] _ = - fail "Encrypted data packet has no usable preceding SKESK or PKESK packet" - resolvePKESKCandidates [] skeskErrs [] _ = - fail - ("Encrypted data packet has no usable preceding SKESK or PKESK packet; " ++ - "candidate errors: " ++ unwords (reverse skeskErrs)) - resolvePKESKCandidates [] skeskErrs pkeskErrs resolverAttempts = - if allowManualPKESKPrompt - then do - let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor - errs = skeskErrs ++ pkeskErrs - encodedSessionKey <- - BL.toStrict <$> - liftIO - (cb - "Input decrypted PKESK session key material (OpenPGP encoded or raw key bytes)") - case decodePKESKSessionKey expectedSymAlgo encodedSessionKey of - Left manualErr -> - fail - ("Encrypted data packet has no usable preceding SKESK or PKESK packet; " ++ - "candidate errors: " ++ - unwords (reverse errs) ++ - "; manual input failed: " ++ manualErr) - Right (sa, k) -> do - emitResolutionReport - (mkResolutionReport - DecryptResolvedViaManualPKESKInput - skeskErrs - pkeskErrs - resolverAttempts) - pure (sa, SessionKey k) - else - fail - ("Encrypted data packet has no usable preceding SKESK or PKESK packet; " ++ - "candidate errors: " ++ - unwords (reverse (skeskErrs ++ pkeskErrs))) - resolvePKESKCandidates (pkesk:rest) skeskErrs pkeskErrs resolverAttempts = do - let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor - errPrefix = "[" ++ describePKESK pkesk ++ "] " - attemptPKESKCandidate [] [] 0 expectedSymAlgo errPrefix resolverAttempts - where - attemptPKESKCandidate attemptedSKeys previousFailures attemptIndex expectedSymAlgo errPrefix resolverAttemptsAcc = do - let callbackProbeSummary = describeCallbackProbeSummary pkesk - resolverResult <- - liftIO (resolvePKESKRecipientKey pkesk previousFailures attemptIndex) - case resolverResult of - Left resolverErr -> - fail (errPrefix ++ resolverErr) - Right (Nothing, _, newAttempts) -> - let resolverAttempts' = resolverAttemptsAcc ++ newAttempts - terminalError = - case reverse previousFailures of - (latestFailure:_) -> errPrefix ++ pkeskAttemptFailureReason latestFailure - [] -> - errPrefix ++ - "no matching key context (callback probes: " ++ - callbackProbeSummary ++ - ")" - in - resolvePKESKCandidates - rest - skeskErrs - (terminalError : pkeskErrs) - resolverAttempts' - Right (Just keyInfo, nextAttemptIndex, newAttempts) - | pkeskRecipientSKey keyInfo `elem` attemptedSKeys -> - let resolverAttempts' = resolverAttemptsAcc ++ newAttempts - terminalError = - case reverse previousFailures of - (latestFailure:_) -> errPrefix ++ pkeskAttemptFailureReason latestFailure - [] -> - errPrefix ++ - "key context callback repeated without yielding a usable key" - in - resolvePKESKCandidates - rest - skeskErrs - (terminalError : pkeskErrs) - resolverAttempts' - | otherwise -> do - let resolverAttempts' = resolverAttemptsAcc ++ newAttempts - unwrapped <- liftIO (tryUnwrapPKESKSessionMaterial pkesk keyInfo) - case unwrapped of - Left err -> - attemptPKESKCandidate - (pkeskRecipientSKey keyInfo : attemptedSKeys) - (previousFailures ++ [mkAttemptFailure keyInfo PKESKAttemptUnwrapFailed err]) - nextAttemptIndex - expectedSymAlgo - errPrefix - resolverAttempts' - Right encodedSessionKey -> - case decodePKESKSessionKey expectedSymAlgo encodedSessionKey of - Left err -> - attemptPKESKCandidate - (pkeskRecipientSKey keyInfo : attemptedSKeys) - (previousFailures ++ - [ mkAttemptFailure - keyInfo - PKESKAttemptSessionMaterialDecodeFailed - err - ]) - nextAttemptIndex - expectedSymAlgo - errPrefix - resolverAttempts' - Right (sa, k) -> do - emitResolutionReport - (mkResolutionReport - DecryptResolvedViaPKESK - skeskErrs - pkeskErrs - resolverAttempts') - pure (sa, SessionKey k) - - emitResolutionReport :: MonadIO m => DecryptSessionKeyResolutionReport -> m () - emitResolutionReport report = - case reportRef of - Nothing -> pure () - Just ref -> liftIO (modifyIORef' ref (report :)) - - mkResolutionReport :: - DecryptSessionKeyResolutionPath - -> [String] - -> [String] - -> [PKESKResolverAttempt] - -> DecryptSessionKeyResolutionReport - mkResolutionReport path skeskErrs pkeskErrs resolverAttempts = - DecryptSessionKeyResolutionReport - { decryptSessionResolutionPath = path - , decryptSessionResolutionSKESKErrors = reverse skeskErrs - , decryptSessionResolutionPKESKErrors = reverse pkeskErrs - , decryptSessionResolutionResolverAttempts = resolverAttempts - } - - mkAttemptFailure keyInfo failureKind reason = - PKESKAttemptFailure - { pkeskAttemptFailureKeyContext = - recipientKeyContext keyInfo - , pkeskAttemptFailureKind = failureKind - , pkeskAttemptFailureReason = reason - } - - recipientKeyContext :: PKESKRecipientKey -> Maybe (KeyVersion, PubKeyAlgorithm) - recipientKeyContext keyInfo = - fmap (\pk -> (_keyVersion pk, _pkalgo pk)) (pkeskRecipientPKPayload keyInfo) - - renderPKESKResolverError (ResolverPolicyDenied reason) = - "resolver policy denied candidate selection: " ++ reason - renderPKESKResolverError (ResolverBackendUnavailable reason) = - "resolver backend unavailable: " ++ reason - renderPKESKResolverError (ResolverInvalidResponse reason) = - "resolver returned an invalid response: " ++ reason - - resolvePKESKRecipientKey payload previousFailures attemptIndex0 = - probePacketVariants attemptIndex0 [] (pkeskCallbackPackets payload) - where - probePacketVariants attemptIndex attemptsAcc [] = - pure (Right (Nothing, attemptIndex, reverse attemptsAcc)) - probePacketVariants attemptIndex attemptsAcc (probePkt:restProbePkts) = do - let request = - PKESKResolveRequest - { reqPKESK = payload - , reqProbePacket = probePkt - , reqIsWildcardRecipient = isWildcardPKESKPayload payload - , reqAttemptIndex = attemptIndex - , reqPreviousFailures = previousFailures - } - resolveAction <- - pkcb request - let attemptRecord = - PKESKResolverAttempt - { pkeskResolverAttemptPreviousFailures = previousFailures - , pkeskResolverAttemptAction = - case resolveAction of - ResolveWith keyInfo -> - ResolverAttemptResolveWith (recipientKeyContext keyInfo) - ResolveSkip -> ResolverAttemptSkip - ResolveExhausted -> ResolverAttemptExhausted - ResolveFail resolverErr -> ResolverAttemptFail resolverErr - } - case resolveAction of - ResolveWith keyInfo -> - pure - (Right (Just keyInfo, attemptIndex + 1, reverse (attemptRecord : attemptsAcc))) - ResolveSkip -> - probePacketVariants - (attemptIndex + 1) - (attemptRecord : attemptsAcc) - restProbePkts - ResolveExhausted -> - pure - (Right (Nothing, attemptIndex + 1, reverse (attemptRecord : attemptsAcc))) - ResolveFail resolverErr -> - pure (Left (renderPKESKResolverError resolverErr)) - - pkeskCallbackPackets payload = - nub $ - case payload of - PKESKPayloadV3Packet (PKESKPayloadV3 v rid pka mpis) -> - map - (\ridVariant -> - PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 v ridVariant pka mpis))) - (recipientIdCallbackVariantsV3 rid) - PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk) -> - map - (\ridVariant -> - PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 ridVariant pka esk))) - (recipientIdCallbackVariants rid) - - describeCallbackProbeSummary payload = - intercalate ", " (map describePKESKCallbackProbe (pkeskCallbackPackets payload)) - - describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) = - "PKESK3 " ++ - show pka ++ - " rid=" ++ - show rid ++ - if isWildcardV3RecipientKeyId rid - then " (wildcard)" - else "" - describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) = - "PKESK6 " ++ show pka ++ " rid=" ++ show rid - describePKESKCallbackProbe pkt = show pkt - - recipientIdCallbackVariantsV3 rid - | isWildcardV3RecipientKeyId rid = [rid] - | otherwise = [rid, EightOctetKeyId (BL.replicate 8 0)] - - isWildcardV3RecipientKeyId (EightOctetKeyId rid) = - BL.length rid == 8 && BL.all (== 0) rid - - recipientIdCallbackVariants rid - | BL.length rid == 20 = [rid, BL.cons 0x04 rid] - | BL.length rid == 21 && BL.head rid == 0x04 = [rid, BL.tail rid] - | BL.length rid == 32 = [rid, BL.cons 0x06 rid] - | BL.length rid == 33 && BL.head rid == 0x06 = [rid, BL.tail rid] - | otherwise = [rid] - - isWildcardPKESKPayload (PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _)) = - isWildcardV3RecipientKeyId (EightOctetKeyId rid) - isWildcardPKESKPayload _ = False - describePKESK payload = - case classifyPKESKPayload payload of - ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ rid pka _) -> - "PKESK3 " ++ show pka ++ " rid=" ++ show rid - ClassifiedPKESKPayloadV6 (PKESKPayloadV6 rid pka _) -> - "PKESK6 " ++ show pka ++ " rid=" ++ show rid - - describeSKESK payload = - case classifySKESKPayload payload of - ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k _) -> - "SKESK4 " ++ show sa ++ " s2k=" ++ show s2k - ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aa s2k _ _ _) -> - "SKESK6 " ++ show sa ++ "/" ++ show aa ++ " s2k=" ++ show s2k - -data AlignedPendingESK (v :: EncryptedPayloadVersion) where - LegacyAlignedSKESK :: SKESKPayloadV4 -> AlignedPendingESK 'LegacyEncryptedPayloadVersion - LegacyAlignedPKESK :: PKESKPayloadV3 -> AlignedPendingESK 'LegacyEncryptedPayloadVersion - SEIPDv2AlignedSKESK :: SKESKPayloadV6 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion - SEIPDv2AlignedPKESK :: PKESKPayloadV6 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion - -- | A version 3 PKESK that precedes a SEIPDv2 payload. - -- - -- RFC 9580 §5.13 explicitly permits version 3 PKESKs before a version 2 - -- SEIPD packet, as a backward-compatibility allowance for implementations - -- that cannot yet produce v6 key material. The v3 PKESK carries the - -- session key wrapped with legacy (v3) asymmetric key wrapping; the SEIPD - -- v2 payload itself is still authenticated with modern AEAD. This - -- constructor therefore counts as "aligned" for SEIPDv2 — it does not - -- indicate a mis-assembled message — even though the PKESK version does - -- not match the SEIPD version. - SEIPDv2AlignedLegacyPKESK :: PKESKPayloadV3 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion - -alignedPrecedingESKs :: - EncryptedPayloadFlavor v - -> [PendingESK] - -> [AlignedPendingESK v] -alignedPrecedingESKs LegacyEncryptedPayload = - mapMaybe - (\esk -> - case esk of - PendingSKESK (SKESKPayloadV4Packet skesk4) -> Just (LegacyAlignedSKESK skesk4) - PendingPKESK (PKESKPayloadV3Packet pkesk3) -> Just (LegacyAlignedPKESK pkesk3) - _ -> Nothing) -alignedPrecedingESKs (SEIPDv2EncryptedPayload _ _) = - mapMaybe - (\esk -> - case esk of - PendingSKESK (SKESKPayloadV6Packet skesk6) -> Just (SEIPDv2AlignedSKESK skesk6) - PendingPKESK (PKESKPayloadV6Packet pkesk6) -> Just (SEIPDv2AlignedPKESK pkesk6) - -- v3 PKESK before SEIPDv2 is explicitly allowed by RFC 9580 §5.13; - -- see 'SEIPDv2AlignedLegacyPKESK' for details. - PendingPKESK (PKESKPayloadV3Packet pkesk3) -> Just (SEIPDv2AlignedLegacyPKESK pkesk3) - _ -> Nothing) - -pendingESKsFromAligned :: [AlignedPendingESK v] -> [PendingESK] -pendingESKsFromAligned = - map - (\esk -> - case esk of - LegacyAlignedSKESK skesk4 -> PendingSKESK (SKESKPayloadV4Packet skesk4) - LegacyAlignedPKESK pkesk3 -> PendingPKESK (PKESKPayloadV3Packet pkesk3) - SEIPDv2AlignedSKESK skesk6 -> PendingSKESK (SKESKPayloadV6Packet skesk6) - SEIPDv2AlignedPKESK pkesk6 -> PendingPKESK (PKESKPayloadV6Packet pkesk6) - SEIPDv2AlignedLegacyPKESK pkesk3 -> PendingPKESK (PKESKPayloadV3Packet pkesk3)) - -payloadExpectedSymmetricAlgorithm :: EncryptedPayloadFlavor v -> Maybe SymmetricAlgorithm -payloadExpectedSymmetricAlgorithm LegacyEncryptedPayload = Nothing -payloadExpectedSymmetricAlgorithm (SEIPDv2EncryptedPayload sa _) = Just sa - -payloadExpectedAEADAlgorithm :: EncryptedPayloadFlavor v -> Maybe AEADAlgorithm -payloadExpectedAEADAlgorithm LegacyEncryptedPayload = Nothing -payloadExpectedAEADAlgorithm (SEIPDv2EncryptedPayload _ aa) = Just aa - -tryUnwrapPKESKSessionMaterial :: - PKESKPayload -> PKESKRecipientKey -> IO (Either String B.ByteString) -tryUnwrapPKESKSessionMaterial pkesk keyInfo = do - attempted <- try @SomeException (unwrapPKESKSessionMaterial pkesk keyInfo :: IO B.ByteString) - pure (first displayException attempted) - -data PKESKUnwrapCase where - PKESKUnwrapV3RSA :: RSATypes.PrivateKey -> MPI -> PKESKUnwrapCase - PKESKUnwrapV6RSA :: RSATypes.PrivateKey -> B.ByteString -> PKESKUnwrapCase - PKESKUnwrapV6ECDH :: - PKESKRecipientKey - -> PubKeyAlgorithm - -> B.ByteString - -> ECDSA.PrivateKey - -> PKESKUnwrapCase - PKESKUnwrapV6XDHRaw :: - PKESKRecipientKey - -> PubKeyAlgorithm - -> B.ByteString - -> B.ByteString - -> PKESKUnwrapCase - PKESKUnwrapV3X25519FromECDH :: - PKESKRecipientKey - -> NonEmpty MPI - -> ECDSA.PrivateKey - -> PKESKUnwrapCase - PKESKUnwrapV3X25519Raw :: - PKESKRecipientKey - -> NonEmpty MPI - -> B.ByteString - -> PKESKUnwrapCase - PKESKUnwrapV3ECDH :: - PKESKRecipientKey - -> PubKeyAlgorithm - -> NonEmpty MPI - -> ECDSA.PrivateKey - -> PKESKUnwrapCase - -data ClassifiedPKESKPayload where - ClassifiedPKESKPayloadV3 :: PKESKPayloadV3 -> ClassifiedPKESKPayload - ClassifiedPKESKPayloadV6 :: PKESKPayloadV6 -> ClassifiedPKESKPayload - -data ClassifiedPKESKRecipientKey where - ClassifiedPKESKRecipientRSA :: - PKESKRecipientKey -> RSATypes.PrivateKey -> ClassifiedPKESKRecipientKey - ClassifiedPKESKRecipientECDH :: - PKESKRecipientKey -> ECDSA.PrivateKey -> ClassifiedPKESKRecipientKey - ClassifiedPKESKRecipientX25519 :: - PKESKRecipientKey -> B.ByteString -> ClassifiedPKESKRecipientKey - ClassifiedPKESKRecipientX448 :: - PKESKRecipientKey -> B.ByteString -> ClassifiedPKESKRecipientKey - ClassifiedPKESKRecipientUnsupported :: - PKESKRecipientKey -> ClassifiedPKESKRecipientKey - -classifyPKESKPayload :: PKESKPayload -> ClassifiedPKESKPayload -classifyPKESKPayload (PKESKPayloadV3Packet payloadV3) = - ClassifiedPKESKPayloadV3 payloadV3 -classifyPKESKPayload (PKESKPayloadV6Packet payloadV6) = - ClassifiedPKESKPayloadV6 payloadV6 - -classifyPKESKRecipientKey :: PKESKRecipientKey -> ClassifiedPKESKRecipientKey -classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (RSAPrivateKey (RSA_PrivateKey privateKey))) = - ClassifiedPKESKRecipientRSA keyInfo privateKey -classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (ECDHPrivateKey (ECDSA_PrivateKey privateKey))) = - ClassifiedPKESKRecipientECDH keyInfo privateKey -classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (X25519PrivateKey privateKeyRaw)) = - ClassifiedPKESKRecipientX25519 keyInfo privateKeyRaw -classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (X448PrivateKey privateKeyRaw)) = - ClassifiedPKESKRecipientX448 keyInfo privateKeyRaw -classifyPKESKRecipientKey keyInfo = - ClassifiedPKESKRecipientUnsupported keyInfo - -pkeskPayloadAlgorithm :: PKESKPayload -> PubKeyAlgorithm -pkeskPayloadAlgorithm payload = - case classifyPKESKPayload payload of - ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka _) -> pka - ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka _) -> pka - -classifyPKESKUnwrapCase :: - PKESKPayload - -> PKESKRecipientKey - -> Either String PKESKUnwrapCase -classifyPKESKUnwrapCase payload keyInfo = - case (classifyPKESKPayload payload, classifyPKESKRecipientKey keyInfo) of - ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka (mpi :| [])) - , ClassifiedPKESKRecipientRSA _ privateKey) - | pka == RSA || pka == DeprecatedRSAEncryptOnly -> - Right (PKESKUnwrapV3RSA privateKey mpi) - ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) - , ClassifiedPKESKRecipientRSA _ privateKey) - | pka == RSA -> - Right (PKESKUnwrapV6RSA privateKey (BL.toStrict esk)) - ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) - , ClassifiedPKESKRecipientECDH recipientCtx privateKey) - | pka == ECDH || pka == X25519 -> - Right (PKESKUnwrapV6ECDH recipientCtx pka (BL.toStrict esk) privateKey) - ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) - , ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw) - | pka == X25519 -> - Right (PKESKUnwrapV6XDHRaw recipientCtx pka (BL.toStrict esk) privateKeyRaw) - ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) - , ClassifiedPKESKRecipientX448 recipientCtx privateKeyRaw) - | pka == X448 -> - Right (PKESKUnwrapV6XDHRaw recipientCtx pka (BL.toStrict esk) privateKeyRaw) - ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis) - , ClassifiedPKESKRecipientECDH recipientCtx privateKey) - | pka == X25519 -> - Right (PKESKUnwrapV3X25519FromECDH recipientCtx mpis privateKey) - ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis) - , ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw) - | pka == X25519 -> - Right (PKESKUnwrapV3X25519Raw recipientCtx mpis privateKeyRaw) - ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis) - , ClassifiedPKESKRecipientECDH recipientCtx privateKey) - | pka == ECDH || pka == X25519 -> - Right (PKESKUnwrapV3ECDH recipientCtx pka mpis privateKey) - (ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka _), _) -> - Left ("PKESK key unwrap unsupported for packet algorithm " ++ show pka) - (ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka _), _) -> - Left - ("PKESKv6 key unwrap unsupported for packet algorithm " ++ - show pka ++ " with secret key " ++ show (pkeskRecipientSKey keyInfo)) - -unwrapPKESKSessionMaterial :: - (MonadFail m, MonadIO m) => PKESKPayload -> PKESKRecipientKey -> m B.ByteString -unwrapPKESKSessionMaterial pkesk keyInfo = do - either fail pure (validateTable30Policy pkesk keyInfo) - unwrapCase <- either fail pure (classifyPKESKUnwrapCase pkesk keyInfo) - case unwrapCase of - PKESKUnwrapV3RSA privateKey mpi -> - rsaUnwrap - privateKey - (leftPadTo (rsaModulusBytes privateKey) (i2osp (unMPI mpi))) - PKESKUnwrapV6RSA privateKey esk -> do - normalized <- either fail pure (normalizePKESKv6RSAEsk privateKey esk) - rsaUnwrap privateKey normalized - PKESKUnwrapV6ECDH recipientCtx pka esk privateKey -> - ecdhUnwrapV6 recipientCtx pka esk privateKey - PKESKUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw -> - ecdhUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw - PKESKUnwrapV3X25519FromECDH recipientCtx mpis privateKey -> do - recipientPKP <- - maybe - (fail - "X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback") - pure - (pkeskRecipientPKPayload recipientCtx) - recipientSecretRaw <- - either fail pure (resolveX25519SecretRaw recipientPKP privateKey) - x25519UnwrapV3 recipientCtx mpis recipientSecretRaw - PKESKUnwrapV3X25519Raw recipientCtx mpis privateKeyRaw -> - x25519UnwrapV3 recipientCtx mpis privateKeyRaw - PKESKUnwrapV3ECDH recipientCtx pka mpis privateKey -> - ecdhUnwrap recipientCtx pka mpis privateKey - where - validateTable30Policy :: PKESKPayload -> PKESKRecipientKey -> Either String () - validateTable30Policy payload recipientCtx = - case pkeskRecipientPKPayload recipientCtx of - Nothing -> Right () - Just recipientPKP -> - case (pkeskPayloadAlgorithm payload, _pubkey recipientPKP) of - (ECDH, ECDHPubKey _ kdfHA kdfSA) -> - validateTable30PolicyForRecipient recipientPKP kdfHA kdfSA - _ -> Right () - - rsaUnwrap privateKey encryptedSessionMaterial = do - decrypted <- - liftIO - (P15.decryptSafer privateKey encryptedSessionMaterial :: - IO (Either RSATypes.Error B.ByteString)) - case decrypted of - Left err -> fail ("RSA PKESK decrypt failed: " ++ show err) - Right decoded -> pure decoded - - normalizePKESKv6RSAEsk :: - RSATypes.PrivateKey - -> B.ByteString - -> Either String B.ByteString - normalizePKESKv6RSAEsk privateKey esk = do - when (B.length esk < 2) $ - Left "PKESKv6 RSA ESK is too short to contain an MPI" - let mpiBits = - fromIntegral (B.index esk 0) `shiftL` 8 + - fromIntegral (B.index esk 1) - mpiLen = (mpiBits + 7) `div` 8 - when (B.length esk /= 2 + mpiLen) $ - Left - ("PKESKv6 RSA ESK MPI length mismatch: expected " ++ - show (2 + mpiLen) ++ " octets, got " ++ show (B.length esk)) - let mpiPayload = B.drop 2 esk - when (mpiBits > 0) $ do - when (B.null mpiPayload) $ - Left "PKESKv6 RSA ESK MPI has non-zero bit length but empty payload" - let firstOctet = B.head mpiPayload - actualBits = - (B.length mpiPayload - 1) * 8 + (8 - countLeadingZeros firstOctet) - when (actualBits /= mpiBits) $ - Left - ("PKESKv6 RSA ESK MPI bit-length mismatch: declared " ++ - show mpiBits ++ ", actual " ++ show actualBits) - let modulusLen = rsaModulusBytes privateKey - when (B.length mpiPayload > modulusLen) $ - Left - ("PKESKv6 RSA ESK MPI payload exceeds recipient modulus size: " ++ - show (B.length mpiPayload) ++ " > " ++ show modulusLen) - pure (leftPadTo modulusLen mpiPayload) - - ecdhUnwrap recipientCtx pka mpis privateKey = do - recipientPKP <- - maybe - (fail - "ECDH PKESK unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback") - pure - (pkeskRecipientPKPayload recipientCtx) - case _pubkey recipientPKP of - ECDHPubKey ecdhPub kdfHA kdfSA -> do - (ephemeralBytes, wrappedSessionKeyBytes) <- - either fail pure (parseECDHPKESKMPIs mpis) - sharedSecret <- - case ecdhPub of - ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> do - ephPoint <- parseUncompressedPointForCurve curve ephemeralBytes - pure - (BA.convert - (ECCDH.getShared curve (ECDSA.private_d privateKey) ephPoint) :: - B.ByteString) - EdDSAPubKey Ed25519 _ -> do - recipientSecretRaw <- - either fail pure (resolveX25519SecretRaw recipientPKP privateKey) - recipientSecret <- - either fail pure . - first show . CE.eitherCryptoError $ - C25519.secretKey recipientSecretRaw - ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) - ephPub <- - either fail pure . - first show . CE.eitherCryptoError $ - C25519.publicKey ephBytes - pure . BA.convert $ C25519.dh ephPub recipientSecret - EdDSAPubKey Ed448 _ -> - fail - "legacy ECDH PKESK unwrap does not support Curve448Legacy recipients" - _ -> - fail - "ECDH PKESK unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible" - param <- either fail pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) - kek <- either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param) - let wrappedCandidates = - candidateWrappedRFC3394CiphertextsForLegacyECDH - (LegacyECDHWrappedRFC3394Ciphertext wrappedSessionKeyBytes) - validUnwraps = - [ material - | wrappedCandidate <- wrappedCandidates - , Right decoded <- [aesKeyUnwrapRFC3394 kdfSA kek (unLegacyECDHWrappedRFC3394Ciphertext wrappedCandidate)] - , Right material <- [parseLegacyECDHDecodedSessionMaterial decoded] - ] - case validUnwraps of - (material:_) -> pure (encodeLegacyECDHSessionMaterial material) - [] -> - case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of - Left err -> fail err - Right _ -> - fail - "legacy ECDH wrapped session key decrypted but decoded session material is malformed" - _ -> - fail - "ECDH PKESK unwrap requires recipient PKPayload with ECDHPubKey parameters" - - ecdhUnwrapV6 recipientCtx pka esk privateKey = do - recipientPKP <- - maybe - (fail - "ECDH PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback") - pure - (pkeskRecipientPKPayload recipientCtx) - if pka == X25519 - then do - recipientSecretRaw <- - either fail pure (resolveX25519SecretRaw recipientPKP privateKey) - v6X25519Unwrap recipientPKP recipientSecretRaw esk - else - if pka == X448 - then - fail - "X448 PKESKv6 unwrap requires an X448PrivateKey recipient secret key and recipient PKPayload context" - else - case _pubkey recipientPKP of - ECDHPubKey ecdhPub kdfHA kdfSA -> do - (ephemeralBytes, wrappedSessionKeyBytes) <- - either fail pure (parsePKESKv6ECDHEsk pka esk) - case ecdhPub of - ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> do - ephPoint <- parseUncompressedPointForCurve curve ephemeralBytes - let sharedSecret = - BA.convert - (ECCDH.getShared curve (ECDSA.private_d privateKey) ephPoint) :: - B.ByteString - param <- either fail pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) - kek <- either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param) - case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of - Left err -> fail err - Right decoded -> pure decoded - EdDSAPubKey Ed25519 _ -> do - recipientSecretRaw <- - either fail pure (resolveX25519SecretRaw recipientPKP privateKey) - recipientSecret <- - either fail pure . - first show . CE.eitherCryptoError $ - C25519.secretKey recipientSecretRaw - ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) - ephPub <- - either fail pure . - first show . CE.eitherCryptoError $ - C25519.publicKey ephBytes - let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString - param <- either fail pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) - let rfc6637Result = - do kek <- deriveECDHKek kdfHA kdfSA sharedSecret param - aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes - case rfc6637Result of - Right decoded -> pure decoded - Left rfc6637Err -> do - recipientPublicRaw <- either fail pure (extractX25519RecipientPublic recipientPKP) - let kekX25519 = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret - case aesKeyUnwrapRFC3394 AES128 kekX25519 wrappedSessionKeyBytes of - Right decoded -> pure decoded - Left x25519Err -> - fail - ("ECDH PKESKv6 Curve25519 unwrap failed (RFC6637: " ++ - rfc6637Err ++ ", X25519: " ++ x25519Err ++ ")") - EdDSAPubKey Ed448 _ -> - fail - "ECDH PKESKv6 unwrap does not support Curve448Legacy recipients; use X448 PKESKv6 packets" - _ -> - fail - "ECDH PKESKv6 unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible" - _ -> - fail - "ECDH PKESKv6 unwrap requires recipient PKPayload with ECDHPubKey parameters" - - ecdhUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw = do - recipientPKP <- - maybe - (fail - "X25519/X448 PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback") - pure - (pkeskRecipientPKPayload recipientCtx) - case pka of - X25519 -> v6X25519Unwrap recipientPKP (leftPadTo 32 privateKeyRaw) esk - X448 -> v6X448Unwrap recipientPKP (leftPadTo 56 privateKeyRaw) esk - _ -> - fail - ("X25519/X448 PKESKv6 unwrap only supports X25519/X448 packets; got " ++ - show pka) - - v6X25519Unwrap recipientPKP recipientSecretRaw esk = do - recipientPublicRaw <- either fail pure (extractX25519RecipientPublic recipientPKP) - (ephemeralBytes, wrappedSessionKeyBytes) <- - either fail pure (parsePKESKv6ECDHEsk X25519 esk) - ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) - recipientSecret <- - either fail pure . - first show . CE.eitherCryptoError $ - C25519.secretKey (leftPadTo 32 recipientSecretRaw) - ephPub <- - either fail pure . - first show . CE.eitherCryptoError $ - C25519.publicKey ephBytes - let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString - kek = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret - case aesKeyUnwrapRFC3394 AES128 kek wrappedSessionKeyBytes of - Left err -> fail err - Right decoded -> pure decoded - - extractX25519RecipientPublic recipientPKP = - case _pubkey recipientPKP of - EdDSAPubKey Ed25519 point -> - normalizeX25519EphemeralPublic (edPointBytes point) - ECDHPubKey (EdDSAPubKey Ed25519 point) _ _ -> - normalizeX25519EphemeralPublic (edPointBytes point) - other -> - Left - ("X25519 PKESKv6 unwrap requires an X25519 recipient public key, got " ++ - show other) - - extractX448RecipientPublic recipientPKP = - case _pubkey recipientPKP of - EdDSAPubKey Ed448 point -> - normalizeX448EphemeralPublic (edPointBytes point) - ECDHPubKey (EdDSAPubKey Ed448 point) _ _ -> - normalizeX448EphemeralPublic (edPointBytes point) - other -> - Left - ("X448 PKESKv6 unwrap requires an X448 recipient public key, got " ++ - show other) - - resolveX25519SecretRaw recipientPKP privateKey = do - recipientPublicRaw <- extractX25519RecipientPublic recipientPKP - let secretBE = leftPadTo 32 (i2osp (ECDSA.private_d privateKey)) - candidates = [secretBE, B.reverse secretBE] - matchesCandidate candidate = - case CE.eitherCryptoError (C25519.secretKey candidate) of - Right sk -> - let derivedPub = BA.convert (C25519.toPublic sk) :: B.ByteString - in derivedPub == recipientPublicRaw - Left _ -> False - case filter matchesCandidate candidates of - (candidate:_) -> Right candidate - [] -> Right secretBE - - v6X448Unwrap recipientPKP recipientSecretRaw esk = do - recipientPublicRaw <- either fail pure (extractX448RecipientPublic recipientPKP) - (ephemeralBytes, wrappedSessionKeyBytes) <- - either fail pure (parsePKESKv6ECDHEsk X448 esk) - ephBytes <- either fail pure (normalizeX448EphemeralPublic ephemeralBytes) - recipientSecret <- - either fail pure . - first show . CE.eitherCryptoError $ - C448.secretKey (leftPadTo 56 recipientSecretRaw) - ephPub <- - either fail pure . - first show . CE.eitherCryptoError $ - C448.publicKey ephBytes - let sharedSecret = BA.convert (C448.dh ephPub recipientSecret) :: B.ByteString - kek = deriveX448Kek ephBytes recipientPublicRaw sharedSecret - case aesKeyUnwrapRFC3394 AES256 kek wrappedSessionKeyBytes of - Left err -> fail err - Right decoded -> pure decoded - - x25519UnwrapV3 recipientCtx mpis recipientSecretRaw = do - recipientPKP <- - maybe - (fail - "X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback") - pure - (pkeskRecipientPKPayload recipientCtx) - recipientPublicRaw <- either fail pure (extractX25519RecipientPublic recipientPKP) - (ephemeralBytes, eskBytes) <- - either fail pure (parseECDHPKESKMPIs mpis) - ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) - recipientSecret <- - either fail pure . - first show . CE.eitherCryptoError $ - C25519.secretKey (leftPadTo 32 recipientSecretRaw) - ephPub <- - either fail pure . - first show . CE.eitherCryptoError $ - C25519.publicKey ephBytes - let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString - kek9580 = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret - -- RFC9580 interpretation: eskBytes = algo_byte || AES-KW(raw_session_key) - rfc9580Result = do - (sessionAlgorithm, wrappedKey) <- parsePKESKv3X25519EskBytes eskBytes - rawKey <- aesKeyUnwrapRFC3394 AES128 kek9580 wrappedKey - expectedLen <- symmetricKeyLength sessionAlgorithm - when (B.length rawKey /= expectedLen) $ - Left - ("X25519 PKESKv3 unwrapped session key length mismatch for " ++ - show sessionAlgorithm ++ - ": expected " ++ show expectedLen ++ ", got " ++ show (B.length rawKey)) - Right - (B.singleton (fromIntegral (fromFVal sessionAlgorithm)) <> - rawKey <> - checksum16Bytes rawKey) - case rfc9580Result of - Right result -> pure result - Left rfc9580Err -> - -- Fallback: legacy ECDH interpretation where the full eskBytes is - -- AES-KW(algo || key || checksum || padding). Try with the RFC9580 - -- X25519 KEK and, when available, the RFC6637 ECDH KEK derived from - -- any ECDH parameters on the recipient public key. - let kekPairs = (kek9580, AES128) : x25519LegacyECDHKekCandidates recipientPKP sharedSecret - wrapped = LegacyECDHWrappedRFC3394Ciphertext eskBytes - candidates = candidateWrappedRFC3394CiphertextsForLegacyECDH wrapped - validResults = - [ encodeLegacyECDHSessionMaterial material - | (kek, kekSA) <- kekPairs - , candidate <- candidates - , Right decoded <- - [aesKeyUnwrapRFC3394 kekSA kek (unLegacyECDHWrappedRFC3394Ciphertext candidate)] - , Right material <- [parseLegacyECDHDecodedSessionMaterial decoded] - ] - in case validResults of - (result:_) -> pure result - [] -> - fail - ("X25519 PKESKv3 unwrap failed (RFC9580: " ++ - rfc9580Err ++ - "; legacy ECDH-style fallback also failed)") - - -- | Derive RFC6637 ECDH KEK candidates for legacy X25519 PKESKv3 fallback. - -- Returns @(kek, kekAlgorithm)@ pairs for each plausible ECDH KDF - -- parameterisation found on the recipient public key. - x25519LegacyECDHKekCandidates :: - SomePKPayload - -> B.ByteString - -> [(B.ByteString, SymmetricAlgorithm)] - x25519LegacyECDHKekCandidates pkPayload sharedSecret = - case _pubkey pkPayload of - ECDHPubKey ecdhPub kdfHA kdfSA -> - [ (kek, kdfSA) - | Right param <- [buildECDHKDFParam pkPayload X25519 ecdhPub kdfHA kdfSA] - , Right kek <- [deriveECDHKek kdfHA kdfSA sharedSecret param] - ] - _ -> [] - -rsaModulusBytes :: RSATypes.PrivateKey -> Int -rsaModulusBytes (RSATypes.PrivateKey (RSATypes.PublicKey sizeField _ _) _ _ _ _ _ _) = - if sizeField > 512 - then (sizeField + 7) `div` 8 - else sizeField - -edPointBytes :: EdPoint -> B.ByteString -edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x -edPointBytes (NativeEPoint (EPoint x)) = i2osp x - -parseECDHPKESKMPIs :: NonEmpty MPI -> Either String (B.ByteString, B.ByteString) -parseECDHPKESKMPIs (ephemeralMPI :| [wrappedMPI]) = - Right (i2osp (unMPI ephemeralMPI), i2osp (unMPI wrappedMPI)) -parseECDHPKESKMPIs _ = - Left "ECDH PKESK must contain exactly two MPIs (ephemeral key, wrapped session key)" - -newtype LegacyECDHWrappedRFC3394Ciphertext = - LegacyECDHWrappedRFC3394Ciphertext - { unLegacyECDHWrappedRFC3394Ciphertext :: B.ByteString - } - deriving (Eq) - -newtype LegacyECDHSessionKey = LegacyECDHSessionKey { unLegacyECDHSessionKey :: B.ByteString } - -newtype LegacyECDHSessionPadding = LegacyECDHSessionPadding { unLegacyECDHSessionPadding :: B.ByteString } - -data LegacyECDHDecodedSessionMaterial = - LegacyECDHDecodedSessionMaterial - { legacyECDHSessionAlgorithm :: SymmetricAlgorithm - , legacyECDHSessionKey :: LegacyECDHSessionKey - , legacyECDHSessionPadding :: LegacyECDHSessionPadding - } - -candidateWrappedRFC3394CiphertextsForLegacyECDH :: - LegacyECDHWrappedRFC3394Ciphertext -> [LegacyECDHWrappedRFC3394Ciphertext] -candidateWrappedRFC3394CiphertextsForLegacyECDH wrapped = - let observedLen = B.length (unLegacyECDHWrappedRFC3394Ciphertext wrapped) - plausibleWrappedLens = legacyECDHRFC3394WrappedLengths - reconstructed = - [ LegacyECDHWrappedRFC3394Ciphertext - (if observedLen == targetLen - then unLegacyECDHWrappedRFC3394Ciphertext wrapped - else leftPadTo targetLen (unLegacyECDHWrappedRFC3394Ciphertext wrapped)) - | targetLen <- plausibleWrappedLens - , targetLen >= observedLen - ] - in nub (wrapped : reconstructed) - -legacyECDHRFC3394WrappedLengths :: [Int] -legacyECDHRFC3394WrappedLengths = - map legacyRFC3394WrappedLenForKeyLen [16, 24, 32] - where - legacyRFC3394WrappedLenForKeyLen keyLen = - let encodedLen = 1 + keyLen + 2 - paddedLen = ((encodedLen + 7) `div` 8) * 8 - in paddedLen + 8 - -parseLegacyECDHDecodedSessionMaterial :: - B.ByteString -> Either String LegacyECDHDecodedSessionMaterial -parseLegacyECDHDecodedSessionMaterial decoded = do - when (B.length decoded < 3) $ - Left "legacy ECDH decoded session material is too short" - let sessionAlgorithm = toFVal (B.head decoded) - sessionKeyLen <- symmetricKeyLength sessionAlgorithm - let payload = B.tail decoded - when (B.length payload < sessionKeyLen + 2) $ - Left "legacy ECDH decoded session material does not contain full key and checksum" - let (sessionKey, checksumAndPad) = B.splitAt sessionKeyLen payload - (checksumBytes, padBytes) = B.splitAt 2 checksumAndPad - expectedChecksum = - fromIntegral (B.index checksumBytes 0) `shiftL` 8 + - fromIntegral (B.index checksumBytes 1) - actualChecksum = checksum16 sessionKey - when (actualChecksum /= expectedChecksum) $ - Left "legacy ECDH decoded session-key checksum mismatch" - if B.null padBytes || B.all (== 0) padBytes - then - Right - (LegacyECDHDecodedSessionMaterial - sessionAlgorithm - (LegacyECDHSessionKey sessionKey) - (LegacyECDHSessionPadding padBytes)) - else do - validatePKCS7Padding padBytes - Right - (LegacyECDHDecodedSessionMaterial - sessionAlgorithm - (LegacyECDHSessionKey sessionKey) - (LegacyECDHSessionPadding padBytes)) - -encodeLegacyECDHSessionMaterial :: LegacyECDHDecodedSessionMaterial -> B.ByteString -encodeLegacyECDHSessionMaterial - (LegacyECDHDecodedSessionMaterial sessionAlgorithm (LegacyECDHSessionKey sessionKey) _) = - B.singleton (fromIntegral (fromFVal sessionAlgorithm)) <> - sessionKey <> - checksum16Bytes sessionKey - -parsePKESKv6ECDHEsk :: PubKeyAlgorithm -> B.ByteString -> Either String (B.ByteString, B.ByteString) -parsePKESKv6ECDHEsk pka esk - | pka == X25519 = - case parseFixedEphemeralWithWrappedLen 32 esk of - Right parsed -> Right parsed - Left _ -> parseLenPrefixedEphemeral 32 esk - | pka == X448 = - case parseFixedEphemeralWithWrappedLen 56 esk of - Right parsed -> Right parsed - Left _ -> parseLenPrefixedEphemeral 56 esk - | B.length esk < 33 = - Left "PKESKv6 ECDH ESK is too short" - | otherwise = - let withLen = - let ephLen = fromIntegral (B.head esk) - rest = B.tail esk - in if ephLen > 0 && B.length rest > ephLen - then - let (eph, wrapped) = B.splitAt ephLen rest - in if validWrappedPayload wrapped - then Just (eph, wrapped) - else Nothing - else Nothing - fixed32WithWrappedLen = parseFixedEphemeralWithWrappedLenMaybe 32 esk - fixed32 = - let (eph, wrapped) = B.splitAt 32 esk - in if validWrappedPayload wrapped - then Just (eph, wrapped) - else Nothing - mpiWithWrappedLen = - if B.length esk >= 4 - then - let mpiBits = fromIntegral (B.index esk 0) `shiftL` 8 + fromIntegral (B.index esk 1) - mpiLen = (mpiBits + 7) `div` 8 - rest = B.drop (2 + mpiLen) esk - in if mpiLen > 0 && B.length esk > 2 + mpiLen && not (B.null rest) - then - let eph = B.take mpiLen (B.drop 2 esk) - wrappedLen = fromIntegral (B.head rest) - wrapped = B.tail rest - in if wrappedLen == B.length wrapped && validWrappedPayload wrapped - then Just (eph, wrapped) - else Nothing - else Nothing - else Nothing - in case fixed32WithWrappedLen <|> withLen <|> fixed32 <|> mpiWithWrappedLen of - Just x -> Right x - Nothing -> - Left - "PKESKv6 ECDH ESK could not be parsed as {ephemeral32||len||wrapped}, {len||ephemeral||wrapped}, {ephemeral32||wrapped}, or {mpi(ephemeral)||len||wrapped}" - where - validWrappedPayload wrapped = B.length wrapped >= 24 && B.length wrapped `mod` 8 == 0 - - parseFixedEphemeralWithWrappedLenMaybe ephLen payload = - let (eph, rest) = B.splitAt ephLen payload - in if B.length rest >= 2 - then - let wrappedLen = fromIntegral (B.head rest) - wrapped = B.tail rest - in if wrappedLen == B.length wrapped && validWrappedPayload wrapped - then Just (eph, wrapped) - else Nothing - else Nothing - - parseFixedEphemeralWithWrappedLen ephLen payload = - maybe - (Left - ("PKESKv6 XDH ESK expected {ephemeral" ++ - show ephLen ++ "||len||wrapped} framing")) - Right - (parseFixedEphemeralWithWrappedLenMaybe ephLen payload) - - parseLenPrefixedEphemeral expectedLen payload = - if B.null payload - then Left "PKESKv6 XDH ESK is empty" - else - let ephLen = fromIntegral (B.head payload) - rest = B.tail payload - in if ephLen == expectedLen && B.length rest > ephLen - then - let (eph, wrapped) = B.splitAt ephLen rest - in if validWrappedPayload wrapped - then Right (eph, wrapped) - else Left "PKESKv6 XDH ESK wrapped payload has invalid length" - else - Left - ("PKESKv6 XDH ESK expected " ++ - show expectedLen ++ "-octet ephemeral value") - -normalizeX25519EphemeralPublic :: B.ByteString -> Either String B.ByteString -normalizeX25519EphemeralPublic = - normalizeMontgomeryPublic - 32 - "invalid X25519 ephemeral public key length/prefix: " - -normalizeX448EphemeralPublic :: B.ByteString -> Either String B.ByteString -normalizeX448EphemeralPublic = - normalizeMontgomeryPublic - 56 - "invalid X448 ephemeral public key length/prefix: " - -parseUncompressedPointForCurve :: MonadFail m => ECCT.Curve -> B.ByteString -> m ECCT.Point -parseUncompressedPointForCurve curve bs - | B.length bs < 1 = fail "ECDH ephemeral point is empty" - | Just expectedLen <- expectedUncompressedPointLength curve - , B.length bs /= expectedLen = - fail - ("ECDH ephemeral point has invalid length for recipient curve: expected " ++ - show expectedLen ++ ", got " ++ show (B.length bs)) - | B.head bs /= 0x04 = fail "ECDH ephemeral point must be uncompressed (0x04)" - | otherwise = - let xy = B.tail bs - in if odd (B.length xy) - then fail "ECDH ephemeral point has malformed coordinate length" - else - let (xb, yb) = B.splitAt (B.length xy `div` 2) xy - in pure (ECCT.Point (os2ip xb) (os2ip yb)) - -expectedUncompressedPointLength :: ECCT.Curve -> Maybe Int -expectedUncompressedPointLength curve - | curve == ECCT.getCurveByName ECCT.SEC_p256r1 = Just 65 - | curve == ECCT.getCurveByName ECCT.SEC_p384r1 = Just 97 - | curve == ECCT.getCurveByName ECCT.SEC_p521r1 = Just 133 - | otherwise = Nothing - -deriveX25519Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -deriveX25519Kek ephemeralPublic recipientPublic sharedSecret = - let ikm = ephemeralPublic <> recipientPublic <> sharedSecret - prk = extract @CHA.SHA256 B.empty ikm - info :: B.ByteString - info = "OpenPGP X25519" - okm :: B.ByteString - okm = expand @CHA.SHA256 prk info 16 - in okm - -deriveX448Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -deriveX448Kek ephemeralPublic recipientPublic sharedSecret = - let ikm = ephemeralPublic <> recipientPublic <> sharedSecret - prk = extract @CHA.SHA512 B.empty ikm - info :: B.ByteString - info = "OpenPGP X448" - okm :: B.ByteString - okm = expand @CHA.SHA512 prk info 32 - in okm - -aesKeyUnwrapRFC3394 :: - SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString -aesKeyUnwrapRFC3394 sa kek wrapped = - withAESCipher "ECDH PKESK currently supports AES KEK algorithms only" sa kek unwrapWithCipher - where - unwrapWithCipher :: - CCT.BlockCipher cipher - => cipher - -> Either String B.ByteString - unwrapWithCipher cipher = do - when (B.length wrapped < 24 || B.length wrapped `mod` 8 /= 0) $ - Left "ECDH wrapped session key must be at least 24 octets and a multiple of 8" - let (a0, rBytes) = B.splitAt 8 wrapped - rs = chunksOf8 rBytes - when (length rs < 2) $ - Left "ECDH wrapped session key must contain at least two 64-bit blocks" - (aFinal, rFinal) <- unwrapRounds cipher a0 rs - when (aFinal /= B.replicate 8 0xA6) $ - Left "ECDH wrapped session key integrity check failed" - Right (B.concat rFinal) - - unwrapRounds :: - CCT.BlockCipher cipher - => cipher - -> B.ByteString - -> [B.ByteString] - -> Either String (B.ByteString, [B.ByteString]) - unwrapRounds cipher aInit rsInit = goJ 5 aInit rsInit - where - n = length rsInit - goJ j aState rsState - | j < 0 = Right (aState, rsState) - | otherwise = do - (a', rs') <- goI n aState rsState - goJ (j - 1) a' rs' - where - goI i aCurrent rsCurrent - | i <= 0 = Right (aCurrent, rsCurrent) - | otherwise = do - let t = fromIntegral (n * j + i) :: Word64 - aXorT = xorBS aCurrent (encodeWord64be t) - rI = rsCurrent !! (i - 1) - block = CCT.ecbDecrypt cipher (aXorT <> rI) - (aNext, rNext) = B.splitAt 8 block - rsNext = (ix (i - 1) .~ rNext) rsCurrent - goI (i - 1) aNext rsNext - -chunksOf8 :: B.ByteString -> [B.ByteString] -chunksOf8 bs - | B.null bs = [] - | otherwise = - let (h, t) = B.splitAt 8 bs - in h : chunksOf8 t - -xorBS :: B.ByteString -> B.ByteString -> B.ByteString -xorBS a b = B.pack (B.zipWith xor a b) - -decodePKESKSessionKey :: - Maybe SymmetricAlgorithm - -> B.ByteString - -> Either String (SymmetricAlgorithm, B.ByteString) -decodePKESKSessionKey expectedSymAlgo encodedSessionKey = - case decodeOpenPGPEncodedSessionKey encodedSessionKey of - Right (symalgo, sessionKey) -> - case expectedSymAlgo of - Just expected | expected /= symalgo -> - Left "Decrypted PKESK symmetric algorithm does not match payload" - _ -> Right (symalgo, sessionKey) - Left decodeErr -> - case expectedSymAlgo of - Nothing -> - Left - ("PKESK session key material must be OpenPGP encoded when payload algorithm is unknown: " ++ - renderEncodedSessionKeyError decodeErr) - Just expected -> do - expectedLen <- symmetricKeyLength expected - case decodeExpectedRawOrPaddedSessionKey expected expectedLen encodedSessionKey of - Left err -> Left err - Right sessionKey -> Right (expected, sessionKey) - -parsePKESKv3X25519EskBytes :: - B.ByteString -> Either String (SymmetricAlgorithm, B.ByteString) -parsePKESKv3X25519EskBytes eskBytes = do - when (B.length eskBytes < 2) $ - Left "PKESKv3 X25519 ESK field is too short" - let sessionAlgorithm = toFVal (B.head eskBytes) - wrappedSessionKeyBytes = B.tail eskBytes - when (sessionAlgorithm `notElem` [AES128, AES192, AES256]) $ - Left "PKESKv3 X25519 ESK field uses unsupported symmetric algorithm" - when (B.length wrappedSessionKeyBytes < 24 || B.length wrappedSessionKeyBytes `mod` 8 /= 0) $ - Left "PKESKv3 X25519 wrapped session key must be at least 24 octets and a multiple of 8" - pure (sessionAlgorithm, wrappedSessionKeyBytes) - -decodeExpectedRawOrPaddedSessionKey :: - SymmetricAlgorithm -> Int -> B.ByteString -> Either String B.ByteString -decodeExpectedRawOrPaddedSessionKey expected expectedLen encodedSessionKey - | B.length encodedSessionKey == expectedLen = Right encodedSessionKey - | otherwise = - case decodeV6PaddedSessionKeyWithoutAlgo expectedLen encodedSessionKey of - Right sessionKey -> Right sessionKey - Left _ -> - case decodeV6PaddedSessionKeyWithAlgo expected expectedLen encodedSessionKey of - Right sessionKey -> Right sessionKey - Left _ -> - Left "PKESK raw session key length does not match payload algorithm" - -decodeV6PaddedSessionKeyWithoutAlgo :: Int -> B.ByteString -> Either String B.ByteString -decodeV6PaddedSessionKeyWithoutAlgo expectedLen encodedSessionKey = do - when (B.length encodedSessionKey < expectedLen + 2) $ - Left "v6 ECDH decoded session material is too short" - let (sessionKey, rest) = B.splitAt expectedLen encodedSessionKey - (checksumBytes, padBytes) = B.splitAt 2 rest - expectedChecksum = - fromIntegral (B.index checksumBytes 0) `shiftL` 8 + - fromIntegral (B.index checksumBytes 1) - actualChecksum = checksum16 sessionKey - when (actualChecksum /= expectedChecksum) $ - Left "v6 ECDH decoded session-key checksum mismatch" - validatePKCS7Padding padBytes - Right sessionKey - -decodeV6PaddedSessionKeyWithAlgo :: - SymmetricAlgorithm -> Int -> B.ByteString -> Either String B.ByteString -decodeV6PaddedSessionKeyWithAlgo expected expectedLen encodedSessionKey = do - when (B.length encodedSessionKey < expectedLen + 3) $ - Left "v6 ECDH decoded session material with algorithm octet is too short" - let algOctet = B.head encodedSessionKey - when (toFVal algOctet /= expected) $ - Left "v6 ECDH decoded session material algorithm mismatch" - let rest = B.tail encodedSessionKey - (sessionKey, checksumAndPad) = B.splitAt expectedLen rest - (checksumBytes, padBytes) = B.splitAt 2 checksumAndPad - expectedChecksum = - fromIntegral (B.index checksumBytes 0) `shiftL` 8 + - fromIntegral (B.index checksumBytes 1) - actualChecksum = checksum16 sessionKey - when (actualChecksum /= expectedChecksum) $ - Left "v6 ECDH decoded session-key checksum mismatch" - validatePKCS7Padding padBytes - Right sessionKey - -validatePKCS7Padding :: B.ByteString -> Either String () -validatePKCS7Padding padBytes - | B.null padBytes = Right () - | otherwise = do - let padLen = fromIntegral (B.last padBytes) :: Int - when (padLen <= 0 || padLen > 8 || B.length padBytes /= padLen) $ - Left "v6 ECDH decoded session material has invalid PKCS#7-style padding length" - when (B.any (/= fromIntegral padLen) padBytes) $ - Left "v6 ECDH decoded session material has invalid PKCS#7-style padding bytes" - -symmetricKeyLength :: SymmetricAlgorithm -> Either String Int -symmetricKeyLength = first renderCipherError . keySize - -checksum16 :: B.ByteString -> Word16 -checksum16 = - fromIntegral . - B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0 - -checksum16Bytes :: B.ByteString -> B.ByteString -checksum16Bytes sessionKey = - B.pack [fromIntegral (chk `shiftR` 8), fromIntegral chk] +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Conduit.OpenPGP.Decrypt + ( conduitDecrypt + , conduitDecryptWithReport + , DecryptOptions (..) + , DecryptKeyResolution (..) + , PKESKRecipientKey (..) + , PKESKAttemptFailureKind (..) + , PKESKAttemptFailure (..) + , DecryptOutcome (..) + , DecryptReport (..) + , DecryptSessionKeyResolutionReport (..) + , DecryptSessionKeyResolutionPath (..) + , PKESKResolverAttempt (..) + , PKESKResolverAttemptAction (..) + , decryptSEIPDv2Payload + ) where + +import Control.Applicative ((<|>)) +import Control.Exception (SomeException, displayException, try) +import Control.Lens (ix, (.~)) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Trans.Resource (MonadResource, MonadThrow) +import qualified Crypto.Error as CE +import qualified Crypto.Hash as CH +import qualified Crypto.Hash.Algorithms as CHA +import Crypto.KDF.HKDF (expand, extract) +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Crypto.PubKey.Curve25519 as C25519 +import qualified Crypto.PubKey.Curve448 as C448 +import qualified Crypto.PubKey.ECC.DH as ECCDH +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Types as ECCT +import qualified Crypto.PubKey.RSA.PKCS15 as P15 +import qualified Crypto.PubKey.RSA.Types as RSATypes +import Data.Bifunctor (first) +import Data.Binary (get) +import Data.Binary.Put (putWord64be, runPut) +import Data.Bits (countLeadingZeros, shiftL, shiftR, xor) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.IORef + ( IORef + , modifyIORef' + , newIORef + , readIORef + , writeIORef + ) +import qualified Data.IxSet.Typed as IxSet +import Data.List (intercalate, nub) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes, isNothing, mapMaybe) +import Data.Word (Word16, Word64, Word8) +import qualified "crypton" Crypto.Cipher.Types as CCT + +import Codec.Encryption.OpenPGP.BlockCipher + ( keySize + , renderCipherError + ) +import Codec.Encryption.OpenPGP.CFB + ( calculateMDC + , decryptOpenPGPCfb + , decryptPreservingNonce + , validateSEIPD1MDC + ) +import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) +import Codec.Encryption.OpenPGP.Internal (leftPadTo) +import Codec.Encryption.OpenPGP.Internal.CryptoAES + ( withAESCipher + ) +import Codec.Encryption.OpenPGP.Internal.CryptoECDH + ( buildECDHKDFParam + , deriveECDHKek + , normalizeMontgomeryPublic + ) +import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 + ( aeadModeAndNonceSizeForSEIPDv2 + , decryptSKESK6SessionKey + , deriveSKESK6KEK + , seipdv2SymmetricKeySize + ) +import Codec.Encryption.OpenPGP.Internal.RFC7253OCB + ( decryptWithOCBRFC7253With + ) +import Codec.Encryption.OpenPGP.Policy + ( DecryptPolicy (..) + , defaultDecryptPolicy + , validateTable30PolicyForRecipient + ) +import Codec.Encryption.OpenPGP.S2K + ( S2KError (..) + , decodeOpenPGPEncodedSessionKey + , renderEncodedSessionKeyError + , renderS2KError + , skesk2Key + , skesk2SessionKey + , string2Key + ) +import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey) +import Codec.Encryption.OpenPGP.Types +import Data.Conduit.OpenPGP.Compression (conduitDecompress) +import Data.Conduit.OpenPGP.Keyring.Instances () + +data RecursorState + = RecursorState + { _depth :: Int + , _pendingESKs :: [PendingESK] + , _lastNonce :: Maybe B.ByteString + , _lastClearText :: Maybe B.ByteString + , _decryptPolicy :: DecryptPolicy + } + deriving (Eq, Show) + +def :: RecursorState +def = RecursorState 0 [] Nothing Nothing defaultDecryptPolicy + +data DecryptStreamPhase + = ActiveDecryptPhase + | FinishedDecryptPhase + | MalformedDecryptPhase + +data DecryptStreamState (phase :: DecryptStreamPhase) where + ActiveDecryptState + :: RecursorState + -> DecryptStreamState 'ActiveDecryptPhase + FinishedDecryptState + :: RecursorState + -> Bool + -> DecryptStreamState 'FinishedDecryptPhase + MalformedDecryptState + :: RecursorState + -> String + -> DecryptStreamState 'MalformedDecryptPhase + +data SomeDecryptStreamState where + SomeDecryptStreamState + :: DecryptStreamState phase + -> SomeDecryptStreamState + +data PendingESK + = PendingPKESK PKESKPayload + | PendingSKESK SKESKPayload + deriving (Eq, Show) + +data EncryptedPayloadVersion + = LegacyEncryptedPayloadVersion + | SEIPDv2EncryptedPayloadVersion + +data EncryptedPayloadFlavor (v :: EncryptedPayloadVersion) where + LegacyEncryptedPayload + :: EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion + SEIPDv2EncryptedPayload + :: SymmetricAlgorithm + -> AEADAlgorithm + -> EncryptedPayloadFlavor 'SEIPDv2EncryptedPayloadVersion + +type InputCallback m = String -> m BL.ByteString + +data PKESKRecipientKey + = PKESKRecipientKey + { pkeskRecipientPKPayload :: Maybe SomePKPayload + {- ^ Public key payload for the recipient. Required for X25519, X448, + and ECDH unwrap paths; may be 'Nothing' for RSA. + -} + , pkeskRecipientSKey :: SKey + -- ^ Corresponding secret key. + } + +data PKESKAttemptFailure + = PKESKAttemptFailure + { pkeskAttemptFailureKeyContext + :: Maybe (KeyVersion, PubKeyAlgorithm) + , pkeskAttemptFailureKind :: PKESKAttemptFailureKind + , pkeskAttemptFailureReason :: String + } + deriving (Eq, Show) + +data PKESKAttemptFailureKind + = PKESKAttemptUnwrapFailed + | PKESKAttemptSessionMaterialDecodeFailed + deriving (Eq, Show) + +data PKESKResolverError + = ResolverPolicyDenied String + | ResolverBackendUnavailable String + | ResolverInvalidResponse String + deriving (Eq, Show) + +data PKESKResolveRequest + = PKESKResolveRequest + { reqPKESK :: PKESKPayload + , reqProbePacket :: Pkt + , reqIsWildcardRecipient :: Bool + , reqAttemptIndex :: Int + , reqPreviousFailures :: [PKESKAttemptFailure] + } + deriving (Eq, Show) + +data PKESKResolveAction + = ResolveWith PKESKRecipientKey + | ResolveSkip + | ResolveExhausted + | ResolveFail PKESKResolverError + +type PKESKResolver m = + PKESKResolveRequest -> m PKESKResolveAction + +{- | Build a stateful 'PKESKResolver' that iterates over a pre-populated +candidate list. The returned resolver yields candidates in order and +returns 'ResolveExhausted' once the list is depleted. +| How to resolve secret keys for PKESK-encrypted messages. +-} +data DecryptKeyResolution + = {- | Do not attempt PKESK decryption; fall through to manual session-key + input via the passphrase callback instead. + -} + DecryptWithoutPKESK + | {- | Resolve secret keys from a 'SecretKeyring'. Only unencrypted secret + keys (not passphrase-protected) are used. For passphrase-protected keys, + use 'DecryptWithKeyringAndPassphrase'. + -} + DecryptWithKeyring SecretKeyring + | {- | Resolve secret keys from a 'SecretKeyring', unlocking passphrase- + protected keys using the provided callback. The callback receives the + public key payload and returns the passphrase, or 'Nothing' to skip. + -} + DecryptWithKeyringAndPassphrase + SecretKeyring + (SomePKPayload -> IO (Maybe BL.ByteString)) + | {- | Preferred callback form for non-keyring key material. The callback + receives a typed key identifier (8-octet key ID, fingerprint, or + wildcard) plus the packet public-key algorithm, then returns all + matching candidates in priority order. hOpenPGP iterates candidates + deterministically without re-calling the callback for each retry. + -} + DecryptWithUnwrapCandidatesCallback + (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]) + +{- | Canonical decrypt configuration. + +Most callers should prefer 'conduitDecrypt' and set: + +* 'decryptOptionsKeyResolution' to 'DecryptWithKeyring' or 'DecryptWithKeyringAndPassphrase' +* 'decryptOptionsPolicy' to strict ('defaultDecryptPolicy') or lenient +* 'decryptOptionsPassphraseCallback' for SKESK passphrase lookup +-} +data DecryptOptions + = DecryptOptions + { decryptOptionsKeyResolution :: DecryptKeyResolution + , decryptOptionsPolicy :: DecryptPolicy + , decryptOptionsPassphraseCallback :: InputCallback IO + } + +{- | Outcome of a checked decrypt conduit run. + +Use 'conduitDecrypt' to obtain this value. Because +'Data.Conduit..|' preserves the +/rightmost/ conduit's return value, callers who also need the decrypted +packet stream should use 'Data.Conduit.fuseBoth': + +@ +(outcome, pkts) \<- runConduit $ source .| fuseBoth (conduitDecrypt opts) CL.consume +@ +-} +data DecryptOutcome + = {- | The integrity-terminating marker (MDC or SEIPD v2 final AEAD tag) + was seen and no further packets arrived. The message was + well-formed end-to-end. + -} + DecryptClean + | {- | The input stream ended before any integrity-terminating marker was + seen. The ciphertext was incomplete. + -} + DecryptTruncated + | {- | An integrity-terminating marker was seen, but additional packets + followed it. Only possible with 'lenientDecryptPolicy' (strict + policy reports 'DecryptMalformedStructure' instead). The trailing + packets were forwarded downstream unchanged. + -} + DecryptTrailingData + | {- | A structural packet-sequencing violation was detected. The + 'String' describes the specific violation: + + * PKESK version does not match the SEIPD version (e.g. a v6 PKESK + preceding a SEIPDv1 payload, or a v4 SKESK preceding a SEIPDv2 + payload). + + * ESK packets arrived in the wrong order relative to the encrypted + data packet (e.g. a literal-data packet appeared between a PKESK + and the SEIPD it was intended to protect). + + * A packet arrived after the message integrity boundary (trailing + data). Under 'defaultDecryptPolicy' this is reported here; under + 'lenientDecryptPolicy' it is reported as 'DecryptTrailingData' + instead. + -} + DecryptMalformedStructure String + deriving (Eq, Show) + +data DecryptSessionKeyResolutionPath + = DecryptResolvedViaSKESK + | DecryptResolvedViaPKESK + | DecryptResolvedViaManualPKESKInput + deriving (Eq, Show) + +data PKESKResolverAttemptAction + = ResolverAttemptResolveWith (Maybe (KeyVersion, PubKeyAlgorithm)) + | ResolverAttemptSkip + | ResolverAttemptExhausted + | ResolverAttemptFail PKESKResolverError + deriving (Eq, Show) + +data PKESKResolverAttempt + = PKESKResolverAttempt + { pkeskResolverAttemptPreviousFailures :: [PKESKAttemptFailure] + -- ^ Failures from earlier attempts on the same PKESK packet. + , pkeskResolverAttemptAction :: PKESKResolverAttemptAction + } + deriving (Eq, Show) + +data DecryptSessionKeyResolutionReport + = DecryptSessionKeyResolutionReport + { decryptSessionResolutionPath :: DecryptSessionKeyResolutionPath + , decryptSessionResolutionSKESKErrors :: [String] + , decryptSessionResolutionPKESKErrors :: [String] + , decryptSessionResolutionResolverAttempts + :: [PKESKResolverAttempt] + } + deriving (Eq, Show) + +data DecryptReport + = DecryptReport + { decryptReportOutcome :: DecryptOutcome + , decryptReportSessionKeyResolutions + :: [DecryptSessionKeyResolutionReport] + } + deriving (Eq, Show) + +-- | AEAD decryption context (Reader monad eliminates parameter threading) +data AEADDecryptContext cipher + = AEADDecryptContext + { aeadMode :: CCT.AEADMode + , aeadInfo :: B.ByteString + , aeadChunkSize :: Word8 + , aeadNoncePrefix :: B.ByteString + , aeadCipher :: cipher + } + +-- | ReaderT wrapper for AEAD decryption computations +type AEADDecrypt cipher = + ReaderT (AEADDecryptContext cipher) (Either String) + +conduitDecrypt + :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m) + => DecryptOptions + -> ConduitT Pkt Pkt m DecryptOutcome +conduitDecrypt opts = + decryptReportOutcome <$> conduitDecryptWithReport opts + +conduitDecryptWithReport + :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m) + => DecryptOptions + -> ConduitT Pkt Pkt m DecryptReport +conduitDecryptWithReport opts = do + reportRef <- liftIO (newIORef []) + resolver <- + liftIO (buildDecryptResolver (decryptOptionsKeyResolution opts)) + let allowManualPKESKPrompt = + case decryptOptionsKeyResolution opts of + DecryptWithoutPKESK -> True + _ -> False + outcome <- + conduitDecryptChecked' + (def {_decryptPolicy = decryptOptionsPolicy opts}) + allowManualPKESKPrompt + resolver + (decryptOptionsPassphraseCallback opts) + (Just reportRef) + resolutions <- reverse <$> liftIO (readIORef reportRef) + pure + DecryptReport + { decryptReportOutcome = outcome + , decryptReportSessionKeyResolutions = resolutions + } + +-- | Build an internal 'PKESKResolver' from the public 'DecryptKeyResolution'. +buildDecryptResolver + :: DecryptKeyResolution -> IO (PKESKResolver IO) +buildDecryptResolver DecryptWithoutPKESK = + pure (\_ -> pure ResolveExhausted) +buildDecryptResolver (DecryptWithKeyring kr) = + buildKeyringResolver kr Nothing +buildDecryptResolver (DecryptWithKeyringAndPassphrase kr cb) = + buildKeyringResolver kr (Just cb) +buildDecryptResolver (DecryptWithUnwrapCandidatesCallback cb) = + buildUnwrapCandidatesResolver cb + +-- | Build a stateful resolver that looks up keys from a 'SecretKeyring'. +buildKeyringResolver + :: SecretKeyring + -> Maybe (SomePKPayload -> IO (Maybe BL.ByteString)) + -> IO (PKESKResolver IO) +buildKeyringResolver kr maybePassphraseCb = do + -- Tracks (last PKESK, remaining wildcard candidates once initialized). + stateRef <- + newIORef + ( Nothing :: Maybe PKESKPayload + , Nothing :: Maybe [PKESKRecipientKey] + , [] :: [(Pkt, [PKESKRecipientKey])] + ) + pure $ \req -> do + let pkesk = reqPKESK req + probe = reqProbePacket req + (lastPKESK, wildcardState, exactCache) <- readIORef stateRef + let freshPKESK = Just pkesk /= lastPKESK + when freshPKESK $ writeIORef stateRef (Just pkesk, Nothing, []) + let wc = if freshPKESK then Nothing else wildcardState + ec = if freshPKESK then [] else exactCache + case extractProbeKeyIdentifier probe of + KeyIdentifierWildcard -> do + -- Wildcard probe: iterate all keys + candidates <- case wc of + Nothing -> keyringCandidates (IxSet.toList kr) + Just cs -> pure cs + case candidates of + [] -> do + writeIORef stateRef (Just pkesk, Just [], ec) + pure ResolveExhausted + (rk : rest) -> do + writeIORef stateRef (Just pkesk, Just rest, ec) + pure (ResolveWith rk) + keyIdentifier -> do + -- Exact probe: direct lookup by key ID or fingerprint. + candidates <- case lookup probe ec of + Just cs -> pure cs + Nothing -> do + let matchingTKs = matchingTKsForRecipient keyIdentifier + cs <- keyringCandidates matchingTKs + writeIORef + stateRef + ( Just pkesk + , wc + , (probe, cs) : filter ((/= probe) . fst) ec + ) + pure cs + let priorFailures = length (reqPreviousFailures req) + case drop priorFailures candidates of + [] -> pure ResolveSkip + (rk : _) -> pure (ResolveWith rk) + where + matchingTKsForRecipient :: KeyIdentifier -> [TK 'SecretTK] + matchingTKsForRecipient keyIdentifier = + case keyIdentifier of + KeyIdentifierWildcard -> IxSet.toList kr + KeyIdentifierEightOctet rid -> IxSet.toList (kr IxSet.@= rid) + KeyIdentifierFingerprint rid -> + let indexedMatches = IxSet.toList (kr IxSet.@= rid) + in if null indexedMatches + then filter (tkMatchesRecipientFingerprint rid) (IxSet.toList kr) + else indexedMatches + + tkMatchesRecipientFingerprint + :: Fingerprint -> TK 'SecretTK -> Bool + tkMatchesRecipientFingerprint rid tk = + any + (keyPktMatchesRecipientFingerprint rid) + (_tkPrimaryKey tk : map fst (_tkSubs tk)) + + keyPktMatchesRecipientFingerprint + :: Fingerprint -> KeyPkt 'SecretPkt -> Bool + keyPktMatchesRecipientFingerprint rid (KeyPktSecretPrimary pkp _) = + pkPayloadMatchesRecipientFingerprint rid pkp + keyPktMatchesRecipientFingerprint rid (KeyPktSecretSubkey pkp _) = + pkPayloadMatchesRecipientFingerprint rid pkp + + pkPayloadMatchesRecipientFingerprint + :: Fingerprint -> SomePKPayload -> Bool + pkPayloadMatchesRecipientFingerprint rid pkp = + fingerprint pkp `elem` recipientFingerprintMatchVariants rid + + recipientFingerprintMatchVariants :: Fingerprint -> [Fingerprint] + recipientFingerprintMatchVariants (Fingerprint rid) + | BL.length rid == 20 = + [Fingerprint rid, Fingerprint (BL.cons 0x04 rid)] + | BL.length rid == 21 && BL.head rid == 0x04 = + [Fingerprint rid, Fingerprint (BL.tail rid)] + | BL.length rid == 32 = + [Fingerprint rid, Fingerprint (BL.cons 0x06 rid)] + | BL.length rid == 33 && BL.head rid == 0x06 = + [Fingerprint rid, Fingerprint (BL.tail rid)] + | otherwise = [Fingerprint rid] + + keyringCandidates :: [TK 'SecretTK] -> IO [PKESKRecipientKey] + keyringCandidates tks = concat <$> mapM tkCandidates tks + + tkCandidates :: TK 'SecretTK -> IO [PKESKRecipientKey] + tkCandidates tk = + fmap catMaybes . mapM resolveKeyPair $ + _tkPrimaryKey tk : map fst (_tkSubs tk) + + resolveKeyPair + :: KeyPkt 'SecretPkt -> IO (Maybe PKESKRecipientKey) + resolveKeyPair (KeyPktSecretPrimary pkp (SUUnencrypted sk _)) = + pure $ + Just + PKESKRecipientKey + { pkeskRecipientPKPayload = Just pkp + , pkeskRecipientSKey = sk + } + resolveKeyPair (KeyPktSecretSubkey pkp (SUUnencrypted sk _)) = + pure $ + Just + PKESKRecipientKey + { pkeskRecipientPKPayload = Just pkp + , pkeskRecipientSKey = sk + } + resolveKeyPair (KeyPktSecretPrimary pkp ska) = unlockProtected pkp ska + resolveKeyPair (KeyPktSecretSubkey pkp ska) = unlockProtected pkp ska + + unlockProtected + :: SomePKPayload -> SKAddendum -> IO (Maybe PKESKRecipientKey) + unlockProtected pkp ska = + case maybePassphraseCb of + Nothing -> pure Nothing + Just passphraseCb -> do + mPassphrase <- passphraseCb pkp + case mPassphrase of + Nothing -> pure Nothing + Just passphrase -> + case decryptPrivateKey (pkp, ska) passphrase of + Left _ -> pure Nothing + Right (SUUnencrypted sk _) -> + pure $ + Just + PKESKRecipientKey + { pkeskRecipientPKPayload = Just pkp + , pkeskRecipientSKey = sk + } + Right _ -> pure Nothing + +buildUnwrapCandidatesResolver + :: (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]) + -> IO (PKESKResolver IO) +buildUnwrapCandidatesResolver cb = do + stateRef <- + newIORef + ( Nothing :: Maybe PKESKPayload + , [] :: [(Pkt, [PKESKRecipientKey])] + , [] :: [SKey] + ) + pure $ \req -> do + let pkesk = reqPKESK req + probePkt = reqProbePacket req + (lastPKESK, probeState, seenSKeys) <- readIORef stateRef + let freshPKESK = Just pkesk /= lastPKESK + when freshPKESK $ writeIORef stateRef (Just pkesk, [], []) + let state0 = if freshPKESK then [] else probeState + seen0 = if freshPKESK then [] else seenSKeys + case lookup probePkt state0 of + Just (next : rest) -> do + writeIORef + stateRef + ( Just pkesk + , updateProbeState probePkt rest state0 + , pkeskRecipientSKey next : seen0 + ) + pure (ResolveWith next) + Just [] -> + pure ResolveSkip + Nothing -> do + candidates <- + filterFreshCandidates seen0 <$> callbackCandidates probePkt + case candidates of + [] -> do + writeIORef + stateRef + (Just pkesk, updateProbeState probePkt [] state0, seen0) + pure ResolveSkip + (next : rest) -> do + writeIORef + stateRef + ( Just pkesk + , updateProbeState probePkt rest state0 + , pkeskRecipientSKey next : seen0 + ) + pure (ResolveWith next) + where + callbackCandidates probePkt = + cb + (extractProbeKeyIdentifier probePkt) + (extractProbePKA probePkt) + + updateProbeState probePkt remaining state0 = + (probePkt, remaining) : filter ((/= probePkt) . fst) state0 + + filterFreshCandidates seenSKeys = + filter + (\candidate -> pkeskRecipientSKey candidate `notElem` seenSKeys) + +-- | Extract the recipient identifier from a PKESK probe packet. +extractProbeKeyIdentifier :: Pkt -> KeyIdentifier +extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid _ _))) + | isWildcardV3RecipientKeyId rid = KeyIdentifierWildcard + | otherwise = KeyIdentifierEightOctet rid +extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _))) + | BL.null rid = KeyIdentifierWildcard + | otherwise = KeyIdentifierFingerprint (Fingerprint rid) +extractProbeKeyIdentifier _ = KeyIdentifierWildcard + +isWildcardV3RecipientKeyId :: EightOctetKeyId -> Bool +isWildcardV3RecipientKeyId (EightOctetKeyId rid) = + BL.length rid == 8 && BL.all (== 0) rid + +-- | Extract the public-key algorithm from a PKESK probe packet. +extractProbePKA :: Pkt -> PubKeyAlgorithm +extractProbePKA (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) = pka +extractProbePKA (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ pka _))) = pka +extractProbePKA _ = RSA -- fallback; should not be reached + +-- | Core implementation: manual await loop so we can return a 'DecryptOutcome'. +conduitDecryptChecked' + :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> ConduitT Pkt Pkt m DecryptOutcome +conduitDecryptChecked' rs0 allowManualPKESKPrompt pkcb cb reportRef = + loop (SomeDecryptStreamState (ActiveDecryptState rs0)) + where + loop + :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m) + => SomeDecryptStreamState -> ConduitT Pkt Pkt m DecryptOutcome + loop streamState = do + case streamState of + SomeDecryptStreamState (MalformedDecryptState _ reason) -> + return (DecryptMalformedStructure reason) + SomeDecryptStreamState state -> do + mpkt <- await + case mpkt of + Nothing -> return (finalOutcome state) + Just pkt -> do + (state', pkts) <- lift (push pkt state) + mapM_ yield pkts + loop state' + + push + :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m) + => Pkt + -> DecryptStreamState phase + -> m (SomeDecryptStreamState, [Pkt]) + push i (ActiveDecryptState s) + | _depth s > 42 = fail "I think we've been quine-attacked" + | hasPendingESKPrelude s && not (packetCanFollowESKPrelude i) = + return + ( SomeDecryptStreamState + ( MalformedDecryptState + s + "Malformed encrypted packet sequence: ESK packets must immediately precede encrypted data" + ) + , [] + ) + | otherwise = + let dp = _decryptPolicy s + in case i of + SKESKPkt payload -> + do + when (decryptRejectDeprecatedSKESK dp) $ + case skeskPayloadS2K payload of + Simple _ -> + fail + "SKESK uses Simple S2K specifier, which is deprecated by RFC9580 policy" + Salted _ _ -> + fail + "SKESK uses Salted S2K specifier, which is deprecated by RFC9580 policy" + _ -> pure () + return + ( SomeDecryptStreamState + ( ActiveDecryptState + (s {_pendingESKs = PendingSKESK payload : _pendingESKs s}) + ) + , [] + ) + PKESKPkt p -> + return + ( SomeDecryptStreamState + ( ActiveDecryptState + (s {_pendingESKs = PendingPKESK p : _pendingESKs s}) + ) + , [] + ) + (SymEncDataPkt bs) -> + if hasESKPayloadVersionMismatch dp LegacyEncryptedPayload s + then + return + ( SomeDecryptStreamState + ( MalformedDecryptState + s + ( "ESK/payload version mismatch: ESK packets present but none are version-aligned with " + ++ "legacy SED payload" + ) + ) + , [] + ) + else do + when (not (decryptAllowSEDNoIntegrity dp)) $ + fail + "Received unauthenticated SED (Symmetrically Encrypted Data) packet; \ + \RFC9580 policy requires integrity-protected SEIPD. \ + \Use lenientDecryptPolicy to permit legacy messages." + (symalgo, sessionKey) <- + resolveSessionKey + s + allowManualPKESKPrompt + pkcb + cb + LegacyEncryptedPayload + reportRef + checkDecryptSymmetricAlgo dp symalgo + d <- + decryptSEDP + s {_pendingESKs = []} + allowManualPKESKPrompt + pkcb + cb + reportRef + symalgo + sessionKey + bs + -- SED is the terminal outer-stream packet. + return (finalizeOuterEncryptedPayload s d) + (SymEncIntegrityProtectedDataPkt (SEIPD1 _ bs)) -> + if hasESKPayloadVersionMismatch dp LegacyEncryptedPayload s + then + return + ( SomeDecryptStreamState + ( MalformedDecryptState + s + ( "ESK/payload version mismatch: ESK packets present but none are version-aligned with " + ++ "SEIPDv1 payload" + ) + ) + , [] + ) + else do + when (not (decryptAllowSEIPDv1 dp)) $ + fail + "Received SEIPDv1 packet; decrypt policy requires SEIPDv2 only." + (symalgo, sessionKey) <- + resolveSessionKey + s + allowManualPKESKPrompt + pkcb + cb + LegacyEncryptedPayload + reportRef + checkDecryptSymmetricAlgo dp symalgo + d <- + decryptSEIPDP + s {_pendingESKs = []} + allowManualPKESKPrompt + pkcb + cb + reportRef + symalgo + sessionKey + bs + -- The outer SEIPD1 packet is terminal; inner MDC is handled by + -- the recursive conduit's own _seenMessageEnd tracking. + return (finalizeOuterEncryptedPayload s d) + (SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) -> + if hasESKPayloadVersionMismatch dp (SEIPDv2EncryptedPayload sa aa) s + then + return + ( SomeDecryptStreamState + ( MalformedDecryptState + s + ( "ESK/payload version mismatch: ESK packets present but none are version-aligned with " + ++ "SEIPDv2 payload" + ) + ) + , [] + ) + else do + checkDecryptSymmetricAlgo dp sa + checkDecryptAEADAlgo dp aa + (_, sessionKey) <- + resolveSessionKey + s + allowManualPKESKPrompt + pkcb + cb + (SEIPDv2EncryptedPayload sa aa) + reportRef + d <- + decryptSEIPDv2P + s {_pendingESKs = []} + allowManualPKESKPrompt + pkcb + cb + reportRef + sa + aa + chunkSize + salt + sessionKey + bs + -- SEIPD2 final AEAD tag was verified inside decryptSEIPDv2P. + return (finalizeOuterEncryptedPayload s d) + m@(ModificationDetectionCodePkt mdc) -> do + when (isNothing (_lastClearText s)) $ fail "MDC with no referent" + let mcalculated = calculateMDC <$> _lastNonce s <*> _lastClearText s + expectedMdc <- + case mcalculated of + Nothing -> fail "MDC with no nonce or cleartext" + Just Nothing -> fail "MDC referent is too short" + Just (Just x) -> return x + when (expectedMdc /= mdc) $ + fail $ + "MDC indicates tampering: " + ++ show mdc + ++ " versus " + ++ maybe "" show mcalculated + ++ " ... " + ++ show (_lastNonce s) + ++ " / " + ++ show (_lastClearText s) + -- MDC is the integrity boundary inside a SEIPD1 inner stream. + return + ( SomeDecryptStreamState (FinishedDecryptState s False) + , [m] + ) + -- RFC9580 Padding Packet (tag 21) can be ignored after decryption. + (PaddingPkt _) -> + return (SomeDecryptStreamState (ActiveDecryptState s), []) + (OtherPacketPkt t _) + | t < 40 -> + fail + ("Unknown critical packet type in packet sequence: " ++ show t) + (OtherPacketPkt _ _) -> + return (SomeDecryptStreamState (ActiveDecryptState s), []) + p -> + return (SomeDecryptStreamState (ActiveDecryptState s), [p]) + push i (FinishedDecryptState s hadTrailing) = + if decryptRejectTrailingData (_decryptPolicy s) + then + return + ( SomeDecryptStreamState + ( MalformedDecryptState + s + "packet received after message integrity boundary" + ) + , [] + ) + else + return + (SomeDecryptStreamState (FinishedDecryptState s True), [i]) + push _ malformedState@(MalformedDecryptState _ _) = + return (SomeDecryptStreamState malformedState, []) + + hasPendingESKPrelude s = not (null (_pendingESKs s)) + + hasESKPayloadVersionMismatch dp payloadFlavor state = + decryptRejectESKVersionMismatch dp + && hasPendingESKPrelude state + && null (alignedPrecedingESKs payloadFlavor (_pendingESKs state)) + + finalizeOuterEncryptedPayload state decryptedPkts = + ( SomeDecryptStreamState + (FinishedDecryptState (state {_pendingESKs = []}) False) + , decryptedPkts + ) + + finalOutcome :: DecryptStreamState phase -> DecryptOutcome + finalOutcome (ActiveDecryptState _) = DecryptTruncated + finalOutcome (FinishedDecryptState _ hadTrailing) = + if hadTrailing + then DecryptTrailingData + else DecryptClean + finalOutcome (MalformedDecryptState _ reason) = + DecryptMalformedStructure reason + + packetCanFollowESKPrelude pkt = + case pkt of + SKESKPkt _ -> True + PKESKPkt _ -> True + SymEncDataPkt _ -> True + SymEncIntegrityProtectedDataPkt _ -> True + MarkerPkt _ -> True + OtherPacketPkt 21 _ -> True + _ -> False + +{- | Describes what integrity-terminating marker (if any) an inner packet +stream is expected to contain. Passed to 'checkInnerOutcome' to +distinguish a legitimate end-of-stream from a missing marker. +-} +data InnerIntegrityExpectation + = {- | The inner stream has no integrity-terminating packet. SED has none + by design; SEIPD2 authenticates via AEAD before the conduit runs. + 'DecryptTruncated' is the normal end-of-stream outcome. + -} + NoIntegrityMarker + +{- | Propagate non-clean inner-stream outcomes as a 'fail'. Called after each +recursive decrypt helper so that structural violations and (for SEIPD1) a +missing MDC are not silently swallowed. +-} +checkInnerOutcome + :: MonadFail m + => InnerIntegrityExpectation -> DecryptOutcome -> m () +checkInnerOutcome _ DecryptClean = pure () +checkInnerOutcome _ DecryptTrailingData = pure () +checkInnerOutcome NoIntegrityMarker DecryptTruncated = pure () +checkInnerOutcome _ (DecryptMalformedStructure reason) = + fail + ("Inner encrypted payload had malformed structure: " ++ reason) + +decryptSEDP + :: (MonadFail m, MonadIO m, MonadThrow m, MonadUnliftIO m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> SymmetricAlgorithm + -> SessionKey + -> BL.ByteString + -> m [Pkt] +decryptSEDP rs allowManualPKESKPrompt pkcb cb reportRef symalgo (SessionKey sessionKey) bs = do + decrypted <- + case decryptOpenPGPCfb symalgo (BL.toStrict bs) sessionKey of + Left e -> fail (renderCipherError e) + Right x -> pure x + (innerOutcome, pkts) <- + decryptInnerPackets + rs + allowManualPKESKPrompt + pkcb + cb + reportRef + decrypted + checkInnerOutcome NoIntegrityMarker innerOutcome + pure pkts + +decryptSEIPDP + :: (MonadFail m, MonadIO m, MonadThrow m, MonadUnliftIO m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> SymmetricAlgorithm + -> SessionKey + -> BL.ByteString + -> m [Pkt] +decryptSEIPDP rs allowManualPKESKPrompt pkcb cb reportRef symalgo (SessionKey sessionKey) bs = do + (nonce, decrypted) <- + case decryptPreservingNonce symalgo (BL.toStrict bs) sessionKey of + Left e -> fail (renderCipherError e) + Right x -> pure x + decryptedWithoutMDC <- + case validateSEIPD1MDC nonce decrypted of + Left err -> fail err + Right x -> pure x + (innerOutcome, pkts) <- + decryptInnerPackets + rs + allowManualPKESKPrompt + pkcb + cb + reportRef + decryptedWithoutMDC + checkInnerOutcome NoIntegrityMarker innerOutcome + pure pkts + +decryptSEIPDv2P + :: (MonadFail m, MonadIO m, MonadThrow m, MonadUnliftIO m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> SessionKey + -> BL.ByteString + -> m [Pkt] +decryptSEIPDv2P rs allowManualPKESKPrompt pkcb cb reportRef symalgo aeadalgo chunkSize salt sessionKey bs = do + let decrypted = + decryptSEIPDv2Payload + symalgo + aeadalgo + chunkSize + salt + (BL.toStrict bs) + sessionKey + case decrypted of + Left e -> fail e + Right cleartext -> do + (innerOutcome, pkts) <- + decryptInnerPackets + rs + allowManualPKESKPrompt + pkcb + cb + reportRef + cleartext + checkInnerOutcome NoIntegrityMarker innerOutcome + pure pkts + +decryptInnerPackets + :: (MonadFail m, MonadThrow m, MonadUnliftIO m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> B.ByteString + -> m (DecryptOutcome, [Pkt]) +decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef cleartext = + runConduitRes $ + CB.sourceLbs (BL.fromStrict cleartext) + .| conduitGet get + .| conduitDecompress + .| fuseBoth + ( conduitDecryptChecked' + rs {_depth = _depth rs + 1} + allowManualPKESKPrompt + pkcb + cb + reportRef + ) + CL.consume + +decryptSEIPDv2Payload + :: SymmetricAlgorithm + -> AEADAlgorithm + -> Word8 + -> Salt + -> B.ByteString + -> SessionKey + -> Either String B.ByteString +decryptSEIPDv2Payload symalgo aeadalgo chunkSize salt encrypted (SessionKey sessionKey) = do + when (chunkSize > 16) $ + Left "SEIPD v2 chunk size octet must be between 0 and 16" + (mode, nonceSize) <- aeadModeAndNonceSize aeadalgo + keyLen <- symKeySize symalgo + let outputLen = keyLen + nonceSize - 8 + when (B.length (unSalt salt) /= 32) $ + Left "SEIPD v2 salt must be exactly 32 octets" + when (B.length encrypted < 32) $ + Left + "SEIPD v2 ciphertext must include at least one chunk tag and a final tag" + let info = + B.pack + [0xd2, 2, fromFVal symalgo, fromFVal aeadalgo, chunkSize] + prk = extract @CHA.SHA256 (unSalt salt) sessionKey + okm = expand @CHA.SHA256 prk info outputLen :: B.ByteString + messageKey = B.take keyLen okm + noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm) + decryptSEIPDv2WithKey + symalgo + mode + chunkSize + info + noncePrefix + messageKey + encrypted + +decryptSEIPDv2WithKey + :: SymmetricAlgorithm + -> CCT.AEADMode + -> Word8 + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString + -> Either String B.ByteString +decryptSEIPDv2WithKey symalgo mode chunkSize info noncePrefix sessionKey encrypted = + withAESCipher + "SEIPD v2 decrypt currently supports AES-128/192/256 only" + symalgo + sessionKey + (decryptChunks mode info chunkSize noncePrefix encrypted) + +decryptChunks + :: CCT.BlockCipher cipher + => CCT.AEADMode + -> B.ByteString + -> Word8 + -> B.ByteString + -> B.ByteString + -> cipher + -> Either String B.ByteString +decryptChunks mode info chunkSize noncePrefix encrypted cipher = + let ctx = AEADDecryptContext mode info chunkSize noncePrefix cipher + in runReaderT decryptChunksWithReader ctx + where + decryptChunksWithReader + :: CCT.BlockCipher cipher => AEADDecrypt cipher B.ByteString + decryptChunksWithReader = go 0 encrypted [] 0 + where + chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6) + tagLen = 16 + + go idx remaining acc totalPlain + | B.length remaining < 2 * tagLen = + lift $ + Left + "SEIPD v2 ciphertext is too short for chunk and final authentication tags" + | otherwise = do + let hasMoreChunks = B.length remaining > chunkLen + 2 * tagLen + currentChunkLen = + if hasMoreChunks + then chunkLen + else B.length remaining - 2 * tagLen + when (currentChunkLen < 0) $ + lift $ + Left "SEIPD v2 malformed chunk lengths" + let (chunkCiphertext, r1) = B.splitAt currentChunkLen remaining + (chunkTag, r2) = B.splitAt tagLen r1 + plainChunk <- + decryptChunkWithContext idx chunkCiphertext chunkTag + if hasMoreChunks + then + go + (idx + 1) + r2 + (plainChunk : acc) + (totalPlain + B.length plainChunk) + else do + when (B.length r2 /= tagLen) $ + lift $ + Left "SEIPD v2 missing final authentication tag" + verifyFinalTagWithContext + (idx + 1) + (totalPlain + B.length plainChunk) + r2 + return (B.concat (reverse (plainChunk : acc))) + + decryptChunkWithContext idx chunkCiphertext chunkTag = do + AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask + if mode' == CCT.AEAD_OCB + then + lift $ + decryptWithOCBRFC7253With + (\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed") + cipher' + (noncePrefix' <> encodeWord64be idx) + info + chunkCiphertext + (mkAuthTag chunkTag) + else do + aead <- initAEADWithContext idx + let mPlain = + CCT.aeadSimpleDecrypt + aead + info + chunkCiphertext + (mkAuthTag chunkTag) + case mPlain of + Nothing -> lift $ Left "SEIPD v2 chunk authentication failed" + Just p -> return p + + verifyFinalTagWithContext idx totalPlain finalTag = do + AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask + if mode' == CCT.AEAD_OCB + then do + plain <- + lift $ + decryptWithOCBRFC7253With + (\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed") + cipher' + (noncePrefix' <> encodeWord64be idx) + (info <> encodeWord64be (fromIntegral totalPlain)) + B.empty + (mkAuthTag finalTag) + if B.null plain + then return () + else + lift $ + Left "SEIPD v2 final authentication tag verification failed" + else do + aead <- initAEADWithContext idx + let mEmpty = + CCT.aeadSimpleDecrypt + aead + (info <> encodeWord64be (fromIntegral totalPlain)) + B.empty + (mkAuthTag finalTag) + case mEmpty of + Just p | B.null p -> return () + _ -> + lift $ + Left "SEIPD v2 final authentication tag verification failed" + + initAEADWithContext idx = do + AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask + lift $ + first show . CE.eitherCryptoError $ + CCT.aeadInit mode' cipher' (noncePrefix' <> encodeWord64be idx) + +aeadModeAndNonceSize + :: AEADAlgorithm -> Either String (CCT.AEADMode, Int) +aeadModeAndNonceSize = + aeadModeAndNonceSizeForSEIPDv2 + "Unknown AEAD algorithm for SEIPD v2 decrypt" + +symKeySize :: SymmetricAlgorithm -> Either String Int +symKeySize = + seipdv2SymmetricKeySize + "SEIPD v2 decrypt currently supports AES-128/192/256 only" + +encodeWord64be :: Word64 -> B.ByteString +encodeWord64be = BL.toStrict . runPut . putWord64be + +mkAuthTag :: B.ByteString -> CCT.AuthTag +mkAuthTag = CCT.AuthTag . BA.convert + +checkDecryptSymmetricAlgo + :: MonadFail m => DecryptPolicy -> SymmetricAlgorithm -> m () +checkDecryptSymmetricAlgo dp sa = + case decryptAllowedSymmetricAlgos dp of + Nothing -> pure () + Just allowed + | sa `elem` allowed -> pure () + | otherwise -> + fail $ + "Decrypt policy rejects symmetric algorithm " + ++ show sa + ++ "; allowed: " + ++ show allowed + +checkDecryptAEADAlgo + :: MonadFail m => DecryptPolicy -> AEADAlgorithm -> m () +checkDecryptAEADAlgo dp aa = + case decryptAllowedAEADAlgos dp of + Nothing -> pure () + Just allowed + | aa `elem` allowed -> pure () + | otherwise -> + fail $ + "Decrypt policy rejects AEAD algorithm " + ++ show aa + ++ "; allowed: " + ++ show allowed + +skeskPayloadSymmetricAlgorithm + :: SKESKPayload -> SymmetricAlgorithm +skeskPayloadSymmetricAlgorithm payload = + case classifySKESKPayload payload of + ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa _ _) -> sa + ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa _ _ _ _ _) -> sa + +skeskPayloadS2K :: SKESKPayload -> S2K +skeskPayloadS2K payload = + case classifySKESKPayload payload of + ClassifiedSKESKPayloadV4 (SKESKPayloadV4 _ s2k _) -> s2k + ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ _ s2k _ _ _) -> s2k + +skeskPayloadAEADAlgorithm :: SKESKPayload -> Maybe AEADAlgorithm +skeskPayloadAEADAlgorithm payload = + case classifySKESKPayload payload of + ClassifiedSKESKPayloadV4 _ -> Nothing + ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ aa _ _ _ _) -> Just aa + +resolveSKESKSessionKey + :: BL.ByteString -> SKESKPayload -> Either String B.ByteString +resolveSKESKSessionKey passphrase payload = + first renderSKESKSessionKeyResolutionError $ + resolveSKESKSessionKeyTyped + passphrase + (classifySKESKPayload payload) + +data SKESKSessionKeyResolutionError + = SKESKSessionKeyS2KError S2KError + | SKESKSessionKeyOtherError String + deriving (Eq, Show) + +renderSKESKSessionKeyResolutionError + :: SKESKSessionKeyResolutionError -> String +renderSKESKSessionKeyResolutionError (SKESKSessionKeyS2KError err) = renderS2KError err +renderSKESKSessionKeyResolutionError (SKESKSessionKeyOtherError err) = err + +resolveSKESKSessionKeyTyped + :: BL.ByteString + -> ClassifiedSKESKPayload + -> Either SKESKSessionKeyResolutionError B.ByteString +resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k Nothing)) = + first + SKESKSessionKeyS2KError + (skesk2Key (SKESK4Packet sa s2k Nothing) passphrase) +resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k (Just esk))) = + first + SKESKSessionKeyS2KError + ( snd + <$> skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase + ) +resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aead s2k iv esk tag)) = do + keyLen <- + first + (SKESKSessionKeyS2KError . S2KUnsupportedAlgorithm) + (keySize sa) + ikm <- + first SKESKSessionKeyS2KError (string2Key s2k keyLen passphrase) + kek <- + first SKESKSessionKeyOtherError (deriveSKESK6KEK sa aead ikm) + first + SKESKSessionKeyOtherError + ( decryptSKESK6SessionKey + sa + aead + kek + (BL.toStrict iv) + (BL.toStrict esk) + (BL.toStrict tag) + ) + +data ClassifiedSKESKPayload where + ClassifiedSKESKPayloadV4 + :: SKESKPayloadV4 -> ClassifiedSKESKPayload + ClassifiedSKESKPayloadV6 + :: SKESKPayloadV6 -> ClassifiedSKESKPayload + +classifySKESKPayload :: SKESKPayload -> ClassifiedSKESKPayload +classifySKESKPayload (SKESKPayloadV4Packet payloadV4) = + ClassifiedSKESKPayloadV4 payloadV4 +classifySKESKPayload (SKESKPayloadV6Packet payloadV6) = + ClassifiedSKESKPayloadV6 payloadV6 + +resolveSessionKey + :: (MonadFail m, MonadIO m) + => RecursorState + -> Bool + -> PKESKResolver IO + -> InputCallback IO + -> EncryptedPayloadFlavor v + -> Maybe (IORef [DecryptSessionKeyResolutionReport]) + -> m (SymmetricAlgorithm, SessionKey) +resolveSessionKey rs allowManualPKESKPrompt pkcb cb payloadFlavor reportRef = + case precedingCandidates of + [] -> + if null (_pendingESKs rs) + then + fail + "Encrypted data packet has no preceding SKESK or PKESK packet" + else + fail + "Encrypted data packet has no preceding SKESK or PKESK packet aligned with payload version" + candidates -> + case skeskCandidates candidates of + [] -> resolvePKESKCandidates (pkeskCandidates candidates) [] [] [] + skesks -> do + passphrase <- liftIO $ cb "Input the passphrase I want" + resolveSKESKCandidates + passphrase + skesks + (pkeskCandidates candidates) + [] + where + precedingCandidates + | strictAlignment = alignedByVersion + | null alignedByVersion = _pendingESKs rs + | otherwise = alignedByVersion + + strictAlignment = decryptRejectESKVersionMismatch (_decryptPolicy rs) + alignedByVersion = pendingESKsFromAligned alignedStrict + alignedStrict = alignedPrecedingESKs payloadFlavor (_pendingESKs rs) + + skeskCandidates esks = [skesk | PendingSKESK skesk <- esks] + + pkeskCandidates esks = [pkesk | PendingPKESK pkesk <- esks] + + resolveSKESKCandidates + :: (MonadFail m, MonadIO m) + => BL.ByteString + -> [SKESKPayload] + -> [PKESKPayload] + -> [String] + -> m (SymmetricAlgorithm, SessionKey) + resolveSKESKCandidates _ [] pkesks skeskErrs = + resolvePKESKCandidates pkesks skeskErrs [] [] + resolveSKESKCandidates passphrase (skesk : rest) pkesks skeskErrs = + case resolveSKESKCandidate passphrase skesk of + Left err -> + resolveSKESKCandidates + passphrase + rest + pkesks + ((skeskErrPrefix skesk ++ err) : skeskErrs) + Right resolved -> do + emitResolutionReport + (mkResolutionReport DecryptResolvedViaSKESK skeskErrs [] []) + pure resolved + + resolveSKESKCandidate + :: BL.ByteString + -> SKESKPayload + -> Either String (SymmetricAlgorithm, SessionKey) + resolveSKESKCandidate passphrase skesk = do + let skeskSymAlgo = skeskPayloadSymmetricAlgorithm skesk + expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor + sessionKeyBytes <- resolveSKESKSessionKey passphrase skesk + case expectedSymAlgo of + Just expected + | expected /= skeskSymAlgo -> + Left "SKESK/encrypted-payload symmetric algorithm mismatch" + _ -> + case ( payloadExpectedAEADAlgorithm payloadFlavor + , skeskPayloadAEADAlgorithm skesk + ) of + (Just expectedAEAD, Just skeskAEAD) + | expectedAEAD /= skeskAEAD -> + Left "SKESK/encrypted-payload AEAD algorithm mismatch" + _ -> Right (skeskSymAlgo, SessionKey sessionKeyBytes) + + skeskErrPrefix skesk = "[" ++ describeSKESK skesk ++ "] " + + resolvePKESKCandidates + :: (MonadFail m, MonadIO m) + => [PKESKPayload] + -> [String] + -> [String] + -> [PKESKResolverAttempt] + -> m (SymmetricAlgorithm, SessionKey) + resolvePKESKCandidates [] [] [] _ = + fail + "Encrypted data packet has no usable preceding SKESK or PKESK packet" + resolvePKESKCandidates [] skeskErrs [] _ = + fail + ( "Encrypted data packet has no usable preceding SKESK or PKESK packet; " + ++ "candidate errors: " + ++ unwords (reverse skeskErrs) + ) + resolvePKESKCandidates [] skeskErrs pkeskErrs resolverAttempts = + if allowManualPKESKPrompt + then do + let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor + errs = skeskErrs ++ pkeskErrs + encodedSessionKey <- + BL.toStrict + <$> liftIO + ( cb + "Input decrypted PKESK session key material (OpenPGP encoded or raw key bytes)" + ) + case decodePKESKSessionKey expectedSymAlgo encodedSessionKey of + Left manualErr -> + fail + ( "Encrypted data packet has no usable preceding SKESK or PKESK packet; " + ++ "candidate errors: " + ++ unwords (reverse errs) + ++ "; manual input failed: " + ++ manualErr + ) + Right (sa, k) -> do + emitResolutionReport + ( mkResolutionReport + DecryptResolvedViaManualPKESKInput + skeskErrs + pkeskErrs + resolverAttempts + ) + pure (sa, SessionKey k) + else + fail + ( "Encrypted data packet has no usable preceding SKESK or PKESK packet; " + ++ "candidate errors: " + ++ unwords (reverse (skeskErrs ++ pkeskErrs)) + ) + resolvePKESKCandidates (pkesk : rest) skeskErrs pkeskErrs resolverAttempts = do + let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor + errPrefix = "[" ++ describePKESK pkesk ++ "] " + attemptPKESKCandidate + [] + [] + 0 + expectedSymAlgo + errPrefix + resolverAttempts + where + attemptPKESKCandidate attemptedSKeys previousFailures attemptIndex expectedSymAlgo errPrefix resolverAttemptsAcc = do + let callbackProbeSummary = describeCallbackProbeSummary pkesk + resolverResult <- + liftIO + (resolvePKESKRecipientKey pkesk previousFailures attemptIndex) + case resolverResult of + Left resolverErr -> + fail (errPrefix ++ resolverErr) + Right (Nothing, _, newAttempts) -> + let resolverAttempts' = resolverAttemptsAcc ++ newAttempts + terminalError = + case reverse previousFailures of + (latestFailure : _) -> errPrefix ++ pkeskAttemptFailureReason latestFailure + [] -> + errPrefix + ++ "no matching key context (callback probes: " + ++ callbackProbeSummary + ++ ")" + in resolvePKESKCandidates + rest + skeskErrs + (terminalError : pkeskErrs) + resolverAttempts' + Right (Just keyInfo, nextAttemptIndex, newAttempts) + | pkeskRecipientSKey keyInfo `elem` attemptedSKeys -> + let resolverAttempts' = resolverAttemptsAcc ++ newAttempts + terminalError = + case reverse previousFailures of + (latestFailure : _) -> errPrefix ++ pkeskAttemptFailureReason latestFailure + [] -> + errPrefix + ++ "key context callback repeated without yielding a usable key" + in resolvePKESKCandidates + rest + skeskErrs + (terminalError : pkeskErrs) + resolverAttempts' + | otherwise -> do + let resolverAttempts' = resolverAttemptsAcc ++ newAttempts + unwrapped <- liftIO (tryUnwrapPKESKSessionMaterial pkesk keyInfo) + case unwrapped of + Left err -> + attemptPKESKCandidate + (pkeskRecipientSKey keyInfo : attemptedSKeys) + ( previousFailures + ++ [mkAttemptFailure keyInfo PKESKAttemptUnwrapFailed err] + ) + nextAttemptIndex + expectedSymAlgo + errPrefix + resolverAttempts' + Right encodedSessionKey -> + case decodePKESKSessionKey expectedSymAlgo encodedSessionKey of + Left err -> + attemptPKESKCandidate + (pkeskRecipientSKey keyInfo : attemptedSKeys) + ( previousFailures + ++ [ mkAttemptFailure + keyInfo + PKESKAttemptSessionMaterialDecodeFailed + err + ] + ) + nextAttemptIndex + expectedSymAlgo + errPrefix + resolverAttempts' + Right (sa, k) -> do + emitResolutionReport + ( mkResolutionReport + DecryptResolvedViaPKESK + skeskErrs + pkeskErrs + resolverAttempts' + ) + pure (sa, SessionKey k) + + emitResolutionReport + :: MonadIO m => DecryptSessionKeyResolutionReport -> m () + emitResolutionReport report = + case reportRef of + Nothing -> pure () + Just ref -> liftIO (modifyIORef' ref (report :)) + + mkResolutionReport + :: DecryptSessionKeyResolutionPath + -> [String] + -> [String] + -> [PKESKResolverAttempt] + -> DecryptSessionKeyResolutionReport + mkResolutionReport path skeskErrs pkeskErrs resolverAttempts = + DecryptSessionKeyResolutionReport + { decryptSessionResolutionPath = path + , decryptSessionResolutionSKESKErrors = reverse skeskErrs + , decryptSessionResolutionPKESKErrors = reverse pkeskErrs + , decryptSessionResolutionResolverAttempts = resolverAttempts + } + + mkAttemptFailure keyInfo failureKind reason = + PKESKAttemptFailure + { pkeskAttemptFailureKeyContext = + recipientKeyContext keyInfo + , pkeskAttemptFailureKind = failureKind + , pkeskAttemptFailureReason = reason + } + + recipientKeyContext + :: PKESKRecipientKey -> Maybe (KeyVersion, PubKeyAlgorithm) + recipientKeyContext keyInfo = + fmap + (\pk -> (_keyVersion pk, _pkalgo pk)) + (pkeskRecipientPKPayload keyInfo) + + renderPKESKResolverError (ResolverPolicyDenied reason) = + "resolver policy denied candidate selection: " ++ reason + renderPKESKResolverError (ResolverBackendUnavailable reason) = + "resolver backend unavailable: " ++ reason + renderPKESKResolverError (ResolverInvalidResponse reason) = + "resolver returned an invalid response: " ++ reason + + resolvePKESKRecipientKey payload previousFailures attemptIndex0 = + probePacketVariants + attemptIndex0 + [] + (pkeskCallbackPackets payload) + where + probePacketVariants attemptIndex attemptsAcc [] = + pure (Right (Nothing, attemptIndex, reverse attemptsAcc)) + probePacketVariants attemptIndex attemptsAcc (probePkt : restProbePkts) = do + let request = + PKESKResolveRequest + { reqPKESK = payload + , reqProbePacket = probePkt + , reqIsWildcardRecipient = isWildcardPKESKPayload payload + , reqAttemptIndex = attemptIndex + , reqPreviousFailures = previousFailures + } + resolveAction <- + pkcb request + let attemptRecord = + PKESKResolverAttempt + { pkeskResolverAttemptPreviousFailures = previousFailures + , pkeskResolverAttemptAction = + case resolveAction of + ResolveWith keyInfo -> + ResolverAttemptResolveWith (recipientKeyContext keyInfo) + ResolveSkip -> ResolverAttemptSkip + ResolveExhausted -> ResolverAttemptExhausted + ResolveFail resolverErr -> ResolverAttemptFail resolverErr + } + case resolveAction of + ResolveWith keyInfo -> + pure + ( Right + ( Just keyInfo + , attemptIndex + 1 + , reverse (attemptRecord : attemptsAcc) + ) + ) + ResolveSkip -> + probePacketVariants + (attemptIndex + 1) + (attemptRecord : attemptsAcc) + restProbePkts + ResolveExhausted -> + pure + ( Right + ( Nothing + , attemptIndex + 1 + , reverse (attemptRecord : attemptsAcc) + ) + ) + ResolveFail resolverErr -> + pure (Left (renderPKESKResolverError resolverErr)) + + pkeskCallbackPackets payload = + nub $ + case payload of + PKESKPayloadV3Packet (PKESKPayloadV3 v rid pka mpis) -> + map + ( \ridVariant -> + PKESKPkt + (PKESKPayloadV3Packet (PKESKPayloadV3 v ridVariant pka mpis)) + ) + (recipientIdCallbackVariantsV3 rid) + PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk) -> + map + ( \ridVariant -> + PKESKPkt + (PKESKPayloadV6Packet (PKESKPayloadV6 ridVariant pka esk)) + ) + (recipientIdCallbackVariants rid) + + describeCallbackProbeSummary payload = + intercalate + ", " + (map describePKESKCallbackProbe (pkeskCallbackPackets payload)) + + describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) = + "PKESK3 " + ++ show pka + ++ " rid=" + ++ show rid + ++ if isWildcardV3RecipientKeyId rid + then " (wildcard)" + else "" + describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) = + "PKESK6 " ++ show pka ++ " rid=" ++ show rid + describePKESKCallbackProbe pkt = show pkt + + recipientIdCallbackVariantsV3 rid + | isWildcardV3RecipientKeyId rid = [rid] + | otherwise = [rid, EightOctetKeyId (BL.replicate 8 0)] + + recipientIdCallbackVariants rid + | BL.length rid == 20 = [rid, BL.cons 0x04 rid] + | BL.length rid == 21 && BL.head rid == 0x04 = [rid, BL.tail rid] + | BL.length rid == 32 = [rid, BL.cons 0x06 rid] + | BL.length rid == 33 && BL.head rid == 0x06 = [rid, BL.tail rid] + | otherwise = [rid] + + isWildcardPKESKPayload (PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _)) = + isWildcardV3RecipientKeyId (EightOctetKeyId rid) + isWildcardPKESKPayload _ = False + describePKESK payload = + case classifyPKESKPayload payload of + ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ rid pka _) -> + "PKESK3 " ++ show pka ++ " rid=" ++ show rid + ClassifiedPKESKPayloadV6 (PKESKPayloadV6 rid pka _) -> + "PKESK6 " ++ show pka ++ " rid=" ++ show rid + + describeSKESK payload = + case classifySKESKPayload payload of + ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k _) -> + "SKESK4 " ++ show sa ++ " s2k=" ++ show s2k + ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aa s2k _ _ _) -> + "SKESK6 " ++ show sa ++ "/" ++ show aa ++ " s2k=" ++ show s2k + +data AlignedPendingESK (v :: EncryptedPayloadVersion) where + LegacyAlignedSKESK + :: SKESKPayloadV4 + -> AlignedPendingESK 'LegacyEncryptedPayloadVersion + LegacyAlignedPKESK + :: PKESKPayloadV3 + -> AlignedPendingESK 'LegacyEncryptedPayloadVersion + SEIPDv2AlignedSKESK + :: SKESKPayloadV6 + -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion + SEIPDv2AlignedPKESK + :: PKESKPayloadV6 + -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion + {- | A version 3 PKESK that precedes a SEIPDv2 payload. + + RFC 9580 §5.13 explicitly permits version 3 PKESKs before a version 2 + SEIPD packet, as a backward-compatibility allowance for implementations + that cannot yet produce v6 key material. The v3 PKESK carries the + session key wrapped with legacy (v3) asymmetric key wrapping; the SEIPD + v2 payload itself is still authenticated with modern AEAD. This + constructor therefore counts as "aligned" for SEIPDv2 — it does not + indicate a mis-assembled message — even though the PKESK version does + not match the SEIPD version. + -} + SEIPDv2AlignedLegacyPKESK + :: PKESKPayloadV3 + -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion + +alignedPrecedingESKs + :: EncryptedPayloadFlavor v + -> [PendingESK] + -> [AlignedPendingESK v] +alignedPrecedingESKs LegacyEncryptedPayload = + mapMaybe + ( \esk -> + case esk of + PendingSKESK (SKESKPayloadV4Packet skesk4) -> Just (LegacyAlignedSKESK skesk4) + PendingPKESK (PKESKPayloadV3Packet pkesk3) -> Just (LegacyAlignedPKESK pkesk3) + _ -> Nothing + ) +alignedPrecedingESKs (SEIPDv2EncryptedPayload _ _) = + mapMaybe + ( \esk -> + case esk of + PendingSKESK (SKESKPayloadV6Packet skesk6) -> Just (SEIPDv2AlignedSKESK skesk6) + PendingPKESK (PKESKPayloadV6Packet pkesk6) -> Just (SEIPDv2AlignedPKESK pkesk6) + -- v3 PKESK before SEIPDv2 is explicitly allowed by RFC 9580 §5.13; + -- see 'SEIPDv2AlignedLegacyPKESK' for details. + PendingPKESK (PKESKPayloadV3Packet pkesk3) -> Just (SEIPDv2AlignedLegacyPKESK pkesk3) + _ -> Nothing + ) + +pendingESKsFromAligned :: [AlignedPendingESK v] -> [PendingESK] +pendingESKsFromAligned = + map + ( \esk -> + case esk of + LegacyAlignedSKESK skesk4 -> PendingSKESK (SKESKPayloadV4Packet skesk4) + LegacyAlignedPKESK pkesk3 -> PendingPKESK (PKESKPayloadV3Packet pkesk3) + SEIPDv2AlignedSKESK skesk6 -> PendingSKESK (SKESKPayloadV6Packet skesk6) + SEIPDv2AlignedPKESK pkesk6 -> PendingPKESK (PKESKPayloadV6Packet pkesk6) + SEIPDv2AlignedLegacyPKESK pkesk3 -> PendingPKESK (PKESKPayloadV3Packet pkesk3) + ) + +payloadExpectedSymmetricAlgorithm + :: EncryptedPayloadFlavor v -> Maybe SymmetricAlgorithm +payloadExpectedSymmetricAlgorithm LegacyEncryptedPayload = Nothing +payloadExpectedSymmetricAlgorithm (SEIPDv2EncryptedPayload sa _) = Just sa + +payloadExpectedAEADAlgorithm + :: EncryptedPayloadFlavor v -> Maybe AEADAlgorithm +payloadExpectedAEADAlgorithm LegacyEncryptedPayload = Nothing +payloadExpectedAEADAlgorithm (SEIPDv2EncryptedPayload _ aa) = Just aa + +tryUnwrapPKESKSessionMaterial + :: PKESKPayload + -> PKESKRecipientKey + -> IO (Either String B.ByteString) +tryUnwrapPKESKSessionMaterial pkesk keyInfo = do + attempted <- + try @SomeException + (unwrapPKESKSessionMaterial pkesk keyInfo :: IO B.ByteString) + pure (first displayException attempted) + +data PKESKUnwrapCase where + PKESKUnwrapV3RSA :: RSATypes.PrivateKey -> MPI -> PKESKUnwrapCase + PKESKUnwrapV6RSA + :: RSATypes.PrivateKey -> B.ByteString -> PKESKUnwrapCase + PKESKUnwrapV6ECDH + :: PKESKRecipientKey + -> PubKeyAlgorithm + -> B.ByteString + -> ECDSA.PrivateKey + -> PKESKUnwrapCase + PKESKUnwrapV6XDHRaw + :: PKESKRecipientKey + -> PubKeyAlgorithm + -> B.ByteString + -> B.ByteString + -> PKESKUnwrapCase + PKESKUnwrapV3X25519FromECDH + :: PKESKRecipientKey + -> NonEmpty MPI + -> ECDSA.PrivateKey + -> PKESKUnwrapCase + PKESKUnwrapV3X25519Raw + :: PKESKRecipientKey + -> NonEmpty MPI + -> B.ByteString + -> PKESKUnwrapCase + PKESKUnwrapV3ECDH + :: PKESKRecipientKey + -> PubKeyAlgorithm + -> NonEmpty MPI + -> ECDSA.PrivateKey + -> PKESKUnwrapCase + +data ClassifiedPKESKPayload where + ClassifiedPKESKPayloadV3 + :: PKESKPayloadV3 -> ClassifiedPKESKPayload + ClassifiedPKESKPayloadV6 + :: PKESKPayloadV6 -> ClassifiedPKESKPayload + +data ClassifiedPKESKRecipientKey where + ClassifiedPKESKRecipientRSA + :: PKESKRecipientKey + -> RSATypes.PrivateKey + -> ClassifiedPKESKRecipientKey + ClassifiedPKESKRecipientECDH + :: PKESKRecipientKey + -> ECDSA.PrivateKey + -> ClassifiedPKESKRecipientKey + ClassifiedPKESKRecipientX25519 + :: PKESKRecipientKey -> B.ByteString -> ClassifiedPKESKRecipientKey + ClassifiedPKESKRecipientX448 + :: PKESKRecipientKey -> B.ByteString -> ClassifiedPKESKRecipientKey + ClassifiedPKESKRecipientUnsupported + :: PKESKRecipientKey -> ClassifiedPKESKRecipientKey + +classifyPKESKPayload :: PKESKPayload -> ClassifiedPKESKPayload +classifyPKESKPayload (PKESKPayloadV3Packet payloadV3) = + ClassifiedPKESKPayloadV3 payloadV3 +classifyPKESKPayload (PKESKPayloadV6Packet payloadV6) = + ClassifiedPKESKPayloadV6 payloadV6 + +classifyPKESKRecipientKey + :: PKESKRecipientKey -> ClassifiedPKESKRecipientKey +classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (RSAPrivateKey (RSA_PrivateKey privateKey))) = + ClassifiedPKESKRecipientRSA keyInfo privateKey +classifyPKESKRecipientKey + keyInfo@( PKESKRecipientKey + _ + (ECDHPrivateKey (ECDSA_PrivateKey privateKey)) + ) = + ClassifiedPKESKRecipientECDH keyInfo privateKey +classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (X25519PrivateKey privateKeyRaw)) = + ClassifiedPKESKRecipientX25519 keyInfo privateKeyRaw +classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (X448PrivateKey privateKeyRaw)) = + ClassifiedPKESKRecipientX448 keyInfo privateKeyRaw +classifyPKESKRecipientKey keyInfo = + ClassifiedPKESKRecipientUnsupported keyInfo + +pkeskPayloadAlgorithm :: PKESKPayload -> PubKeyAlgorithm +pkeskPayloadAlgorithm payload = + case classifyPKESKPayload payload of + ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka _) -> pka + ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka _) -> pka + +classifyPKESKUnwrapCase + :: PKESKPayload + -> PKESKRecipientKey + -> Either String PKESKUnwrapCase +classifyPKESKUnwrapCase payload keyInfo = + case (classifyPKESKPayload payload, classifyPKESKRecipientKey keyInfo) of + ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka (mpi :| [])) + , ClassifiedPKESKRecipientRSA _ privateKey + ) + | pka == RSA || pka == DeprecatedRSAEncryptOnly -> + Right (PKESKUnwrapV3RSA privateKey mpi) + ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) + , ClassifiedPKESKRecipientRSA _ privateKey + ) + | pka == RSA -> + Right (PKESKUnwrapV6RSA privateKey (BL.toStrict esk)) + ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) + , ClassifiedPKESKRecipientECDH recipientCtx privateKey + ) + | pka == ECDH || pka == X25519 -> + Right + (PKESKUnwrapV6ECDH recipientCtx pka (BL.toStrict esk) privateKey) + ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) + , ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw + ) + | pka == X25519 -> + Right + ( PKESKUnwrapV6XDHRaw + recipientCtx + pka + (BL.toStrict esk) + privateKeyRaw + ) + ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) + , ClassifiedPKESKRecipientX448 recipientCtx privateKeyRaw + ) + | pka == X448 -> + Right + ( PKESKUnwrapV6XDHRaw + recipientCtx + pka + (BL.toStrict esk) + privateKeyRaw + ) + ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis) + , ClassifiedPKESKRecipientECDH recipientCtx privateKey + ) + | pka == X25519 -> + Right (PKESKUnwrapV3X25519FromECDH recipientCtx mpis privateKey) + ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis) + , ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw + ) + | pka == X25519 -> + Right (PKESKUnwrapV3X25519Raw recipientCtx mpis privateKeyRaw) + ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis) + , ClassifiedPKESKRecipientECDH recipientCtx privateKey + ) + | pka == ECDH || pka == X25519 -> + Right (PKESKUnwrapV3ECDH recipientCtx pka mpis privateKey) + (ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka _), _) -> + Left + ("PKESK key unwrap unsupported for packet algorithm " ++ show pka) + (ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka _), _) -> + Left + ( "PKESKv6 key unwrap unsupported for packet algorithm " + ++ show pka + ++ " with secret key " + ++ show (pkeskRecipientSKey keyInfo) + ) + +unwrapPKESKSessionMaterial + :: (MonadFail m, MonadIO m) + => PKESKPayload -> PKESKRecipientKey -> m B.ByteString +unwrapPKESKSessionMaterial pkesk keyInfo = do + either fail pure (validateTable30Policy pkesk keyInfo) + unwrapCase <- + either fail pure (classifyPKESKUnwrapCase pkesk keyInfo) + case unwrapCase of + PKESKUnwrapV3RSA privateKey mpi -> + rsaUnwrap + privateKey + (leftPadTo (rsaModulusBytes privateKey) (i2osp (unMPI mpi))) + PKESKUnwrapV6RSA privateKey esk -> do + normalized <- + either fail pure (normalizePKESKv6RSAEsk privateKey esk) + rsaUnwrap privateKey normalized + PKESKUnwrapV6ECDH recipientCtx pka esk privateKey -> + ecdhUnwrapV6 recipientCtx pka esk privateKey + PKESKUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw -> + ecdhUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw + PKESKUnwrapV3X25519FromECDH recipientCtx mpis privateKey -> do + recipientPKP <- + maybe + ( fail + "X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback" + ) + pure + (pkeskRecipientPKPayload recipientCtx) + recipientSecretRaw <- + either fail pure (resolveX25519SecretRaw recipientPKP privateKey) + x25519UnwrapV3 recipientCtx mpis recipientSecretRaw + PKESKUnwrapV3X25519Raw recipientCtx mpis privateKeyRaw -> + x25519UnwrapV3 recipientCtx mpis privateKeyRaw + PKESKUnwrapV3ECDH recipientCtx pka mpis privateKey -> + ecdhUnwrap recipientCtx pka mpis privateKey + where + validateTable30Policy + :: PKESKPayload -> PKESKRecipientKey -> Either String () + validateTable30Policy payload recipientCtx = + case pkeskRecipientPKPayload recipientCtx of + Nothing -> Right () + Just recipientPKP -> + case (pkeskPayloadAlgorithm payload, _pubkey recipientPKP) of + (ECDH, ECDHPubKey _ kdfHA kdfSA) -> + validateTable30PolicyForRecipient recipientPKP kdfHA kdfSA + _ -> Right () + + rsaUnwrap privateKey encryptedSessionMaterial = do + decrypted <- + liftIO + ( P15.decryptSafer privateKey encryptedSessionMaterial + :: IO (Either RSATypes.Error B.ByteString) + ) + case decrypted of + Left err -> fail ("RSA PKESK decrypt failed: " ++ show err) + Right decoded -> pure decoded + + normalizePKESKv6RSAEsk + :: RSATypes.PrivateKey + -> B.ByteString + -> Either String B.ByteString + normalizePKESKv6RSAEsk privateKey esk = do + when (B.length esk < 2) $ + Left "PKESKv6 RSA ESK is too short to contain an MPI" + let mpiBits = + fromIntegral (B.index esk 0) `shiftL` 8 + + fromIntegral (B.index esk 1) + mpiLen = (mpiBits + 7) `div` 8 + when (B.length esk /= 2 + mpiLen) $ + Left + ( "PKESKv6 RSA ESK MPI length mismatch: expected " + ++ show (2 + mpiLen) + ++ " octets, got " + ++ show (B.length esk) + ) + let mpiPayload = B.drop 2 esk + when (mpiBits > 0) $ do + when (B.null mpiPayload) $ + Left + "PKESKv6 RSA ESK MPI has non-zero bit length but empty payload" + let firstOctet = B.head mpiPayload + actualBits = + (B.length mpiPayload - 1) * 8 + + (8 - countLeadingZeros firstOctet) + when (actualBits /= mpiBits) $ + Left + ( "PKESKv6 RSA ESK MPI bit-length mismatch: declared " + ++ show mpiBits + ++ ", actual " + ++ show actualBits + ) + let modulusLen = rsaModulusBytes privateKey + when (B.length mpiPayload > modulusLen) $ + Left + ( "PKESKv6 RSA ESK MPI payload exceeds recipient modulus size: " + ++ show (B.length mpiPayload) + ++ " > " + ++ show modulusLen + ) + pure (leftPadTo modulusLen mpiPayload) + + ecdhUnwrap recipientCtx pka mpis privateKey = do + recipientPKP <- + maybe + ( fail + "ECDH PKESK unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback" + ) + pure + (pkeskRecipientPKPayload recipientCtx) + case _pubkey recipientPKP of + ECDHPubKey ecdhPub kdfHA kdfSA -> do + (ephemeralBytes, wrappedSessionKeyBytes) <- + either fail pure (parseECDHPKESKMPIs mpis) + sharedSecret <- + case ecdhPub of + ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> do + ephPoint <- parseUncompressedPointForCurve curve ephemeralBytes + pure + ( BA.convert + (ECCDH.getShared curve (ECDSA.private_d privateKey) ephPoint) + :: B.ByteString + ) + EdDSAPubKey EdSigningCurve25519 _ -> do + recipientSecretRaw <- + either fail pure (resolveX25519SecretRaw recipientPKP privateKey) + recipientSecret <- + either fail pure + . first show + . CE.eitherCryptoError + $ C25519.secretKey recipientSecretRaw + ephBytes <- + either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + ephPub <- + either fail pure + . first show + . CE.eitherCryptoError + $ C25519.publicKey ephBytes + pure . BA.convert $ C25519.dh ephPub recipientSecret + EdDSAPubKey EdSigningCurve448 _ -> + fail + "legacy ECDH PKESK unwrap does not support Curve448Legacy recipients" + _ -> + fail + "ECDH PKESK unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible" + param <- + either + fail + pure + (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) + kek <- + either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param) + let wrappedCandidates = + candidateWrappedRFC3394CiphertextsForLegacyECDH + (LegacyECDHWrappedRFC3394Ciphertext wrappedSessionKeyBytes) + validUnwraps = + [ material + | wrappedCandidate <- wrappedCandidates + , Right decoded <- + [ aesKeyUnwrapRFC3394 + kdfSA + kek + (unLegacyECDHWrappedRFC3394Ciphertext wrappedCandidate) + ] + , Right material <- [parseLegacyECDHDecodedSessionMaterial decoded] + ] + case validUnwraps of + (material : _) -> pure (encodeLegacyECDHSessionMaterial material) + [] -> + case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of + Left err -> fail err + Right _ -> + fail + "legacy ECDH wrapped session key decrypted but decoded session material is malformed" + _ -> + fail + "ECDH PKESK unwrap requires recipient PKPayload with ECDHPubKey parameters" + + ecdhUnwrapV6 recipientCtx pka esk privateKey = do + recipientPKP <- + maybe + ( fail + "ECDH PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback" + ) + pure + (pkeskRecipientPKPayload recipientCtx) + if pka == X25519 + then do + recipientSecretRaw <- + either fail pure (resolveX25519SecretRaw recipientPKP privateKey) + v6X25519Unwrap recipientPKP recipientSecretRaw esk + else + if pka == X448 + then + fail + "X448 PKESKv6 unwrap requires an X448PrivateKey recipient secret key and recipient PKPayload context" + else case _pubkey recipientPKP of + ECDHPubKey ecdhPub kdfHA kdfSA -> do + (ephemeralBytes, wrappedSessionKeyBytes) <- + either fail pure (parsePKESKv6ECDHEsk pka esk) + case ecdhPub of + ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> do + ephPoint <- parseUncompressedPointForCurve curve ephemeralBytes + let sharedSecret = + BA.convert + (ECCDH.getShared curve (ECDSA.private_d privateKey) ephPoint) + :: B.ByteString + param <- + either + fail + pure + (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) + kek <- + either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param) + case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of + Left err -> fail err + Right decoded -> pure decoded + EdDSAPubKey EdSigningCurve25519 _ -> do + recipientSecretRaw <- + either fail pure (resolveX25519SecretRaw recipientPKP privateKey) + recipientSecret <- + either fail pure + . first show + . CE.eitherCryptoError + $ C25519.secretKey recipientSecretRaw + ephBytes <- + either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + ephPub <- + either fail pure + . first show + . CE.eitherCryptoError + $ C25519.publicKey ephBytes + let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString + param <- + either + fail + pure + (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA) + let rfc6637Result = + do + kek <- deriveECDHKek kdfHA kdfSA sharedSecret param + aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes + case rfc6637Result of + Right decoded -> pure decoded + Left rfc6637Err -> do + recipientPublicRaw <- + either fail pure (extractX25519RecipientPublic recipientPKP) + let kekX25519 = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret + case aesKeyUnwrapRFC3394 AES128 kekX25519 wrappedSessionKeyBytes of + Right decoded -> pure decoded + Left x25519Err -> + fail + ( "ECDH PKESKv6 Curve25519 unwrap failed (RFC6637: " + ++ rfc6637Err + ++ ", X25519: " + ++ x25519Err + ++ ")" + ) + EdDSAPubKey EdSigningCurve448 _ -> + fail + "ECDH PKESKv6 unwrap does not support Curve448Legacy recipients; use X448 PKESKv6 packets" + _ -> + fail + "ECDH PKESKv6 unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible" + _ -> + fail + "ECDH PKESKv6 unwrap requires recipient PKPayload with ECDHPubKey parameters" + + ecdhUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw = do + recipientPKP <- + maybe + ( fail + "X25519/X448 PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback" + ) + pure + (pkeskRecipientPKPayload recipientCtx) + case pka of + X25519 -> v6X25519Unwrap recipientPKP (leftPadTo 32 privateKeyRaw) esk + X448 -> v6X448Unwrap recipientPKP (leftPadTo 56 privateKeyRaw) esk + _ -> + fail + ( "X25519/X448 PKESKv6 unwrap only supports X25519/X448 packets; got " + ++ show pka + ) + + v6X25519Unwrap recipientPKP recipientSecretRaw esk = do + recipientPublicRaw <- + either fail pure (extractX25519RecipientPublic recipientPKP) + (ephemeralBytes, wrappedSessionKeyBytes) <- + either fail pure (parsePKESKv6ECDHEsk X25519 esk) + ephBytes <- + either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + recipientSecret <- + either fail pure + . first show + . CE.eitherCryptoError + $ C25519.secretKey (leftPadTo 32 recipientSecretRaw) + ephPub <- + either fail pure + . first show + . CE.eitherCryptoError + $ C25519.publicKey ephBytes + let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString + kek = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret + case aesKeyUnwrapRFC3394 AES128 kek wrappedSessionKeyBytes of + Left err -> fail err + Right decoded -> pure decoded + + extractX25519RecipientPublic recipientPKP = + case _pubkey recipientPKP of + EdDSAPubKey EdSigningCurve25519 point -> + normalizeX25519EphemeralPublic (edPointBytes point) + ECDHPubKey (EdDSAPubKey EdSigningCurve25519 point) _ _ -> + normalizeX25519EphemeralPublic (edPointBytes point) + other -> + Left + ( "X25519 PKESKv6 unwrap requires an X25519 recipient public key, got " + ++ show other + ) + + extractX448RecipientPublic recipientPKP = + case _pubkey recipientPKP of + EdDSAPubKey EdSigningCurve448 point -> + normalizeX448EphemeralPublic (edPointBytes point) + ECDHPubKey (EdDSAPubKey EdSigningCurve448 point) _ _ -> + normalizeX448EphemeralPublic (edPointBytes point) + other -> + Left + ( "X448 PKESKv6 unwrap requires an X448 recipient public key, got " + ++ show other + ) + + resolveX25519SecretRaw recipientPKP privateKey = do + recipientPublicRaw <- extractX25519RecipientPublic recipientPKP + let secretBE = leftPadTo 32 (i2osp (ECDSA.private_d privateKey)) + candidates = [secretBE, B.reverse secretBE] + matchesCandidate candidate = + case CE.eitherCryptoError (C25519.secretKey candidate) of + Right sk -> + let derivedPub = BA.convert (C25519.toPublic sk) :: B.ByteString + in derivedPub == recipientPublicRaw + Left _ -> False + case filter matchesCandidate candidates of + (candidate : _) -> Right candidate + [] -> Right secretBE + + v6X448Unwrap recipientPKP recipientSecretRaw esk = do + recipientPublicRaw <- + either fail pure (extractX448RecipientPublic recipientPKP) + (ephemeralBytes, wrappedSessionKeyBytes) <- + either fail pure (parsePKESKv6ECDHEsk X448 esk) + ephBytes <- + either fail pure (normalizeX448EphemeralPublic ephemeralBytes) + recipientSecret <- + either fail pure + . first show + . CE.eitherCryptoError + $ C448.secretKey (leftPadTo 56 recipientSecretRaw) + ephPub <- + either fail pure + . first show + . CE.eitherCryptoError + $ C448.publicKey ephBytes + let sharedSecret = BA.convert (C448.dh ephPub recipientSecret) :: B.ByteString + kek = deriveX448Kek ephBytes recipientPublicRaw sharedSecret + case aesKeyUnwrapRFC3394 AES256 kek wrappedSessionKeyBytes of + Left err -> fail err + Right decoded -> pure decoded + + x25519UnwrapV3 recipientCtx mpis recipientSecretRaw = do + recipientPKP <- + maybe + ( fail + "X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback" + ) + pure + (pkeskRecipientPKPayload recipientCtx) + recipientPublicRaw <- + either fail pure (extractX25519RecipientPublic recipientPKP) + (ephemeralBytes, eskBytes) <- + either fail pure (parseECDHPKESKMPIs mpis) + ephBytes <- + either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + recipientSecret <- + either fail pure + . first show + . CE.eitherCryptoError + $ C25519.secretKey (leftPadTo 32 recipientSecretRaw) + ephPub <- + either fail pure + . first show + . CE.eitherCryptoError + $ C25519.publicKey ephBytes + let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString + kek9580 = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret + -- RFC9580 interpretation: eskBytes = algo_byte || AES-KW(raw_session_key) + rfc9580Result = do + (sessionAlgorithm, wrappedKey) <- + parsePKESKv3X25519EskBytes eskBytes + rawKey <- aesKeyUnwrapRFC3394 AES128 kek9580 wrappedKey + expectedLen <- symmetricKeyLength sessionAlgorithm + when (B.length rawKey /= expectedLen) $ + Left + ( "X25519 PKESKv3 unwrapped session key length mismatch for " + ++ show sessionAlgorithm + ++ ": expected " + ++ show expectedLen + ++ ", got " + ++ show (B.length rawKey) + ) + Right + ( B.singleton (fromIntegral (fromFVal sessionAlgorithm)) + <> rawKey + <> checksum16Bytes rawKey + ) + case rfc9580Result of + Right result -> pure result + Left rfc9580Err -> + -- Fallback: legacy ECDH interpretation where the full eskBytes is + -- AES-KW(algo || key || checksum || padding). Try with the RFC9580 + -- X25519 KEK and, when available, the RFC6637 ECDH KEK derived from + -- any ECDH parameters on the recipient public key. + let kekPairs = + (kek9580, AES128) + : x25519LegacyECDHKekCandidates recipientPKP sharedSecret + wrapped = LegacyECDHWrappedRFC3394Ciphertext eskBytes + candidates = candidateWrappedRFC3394CiphertextsForLegacyECDH wrapped + validResults = + [ encodeLegacyECDHSessionMaterial material + | (kek, kekSA) <- kekPairs + , candidate <- candidates + , Right decoded <- + [ aesKeyUnwrapRFC3394 + kekSA + kek + (unLegacyECDHWrappedRFC3394Ciphertext candidate) + ] + , Right material <- [parseLegacyECDHDecodedSessionMaterial decoded] + ] + in case validResults of + (result : _) -> pure result + [] -> + fail + ( "X25519 PKESKv3 unwrap failed (RFC9580: " + ++ rfc9580Err + ++ "; legacy ECDH-style fallback also failed)" + ) + + -- \| Derive RFC6637 ECDH KEK candidates for legacy X25519 PKESKv3 fallback. + -- Returns @(kek, kekAlgorithm)@ pairs for each plausible ECDH KDF + -- parameterisation found on the recipient public key. + x25519LegacyECDHKekCandidates + :: SomePKPayload + -> B.ByteString + -> [(B.ByteString, SymmetricAlgorithm)] + x25519LegacyECDHKekCandidates pkPayload sharedSecret = + case _pubkey pkPayload of + ECDHPubKey ecdhPub kdfHA kdfSA -> + [ (kek, kdfSA) + | Right param <- + [buildECDHKDFParam pkPayload X25519 ecdhPub kdfHA kdfSA] + , Right kek <- [deriveECDHKek kdfHA kdfSA sharedSecret param] + ] + _ -> [] + +rsaModulusBytes :: RSATypes.PrivateKey -> Int +rsaModulusBytes + ( RSATypes.PrivateKey + (RSATypes.PublicKey sizeField _ _) + _ + _ + _ + _ + _ + _ + ) = + sizeField + +edPointBytes :: EdPoint -> B.ByteString +edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x +edPointBytes (NativeEPoint (EPoint x)) = i2osp x + +parseECDHPKESKMPIs + :: NonEmpty MPI -> Either String (B.ByteString, B.ByteString) +parseECDHPKESKMPIs (ephemeralMPI :| [wrappedMPI]) = + Right (i2osp (unMPI ephemeralMPI), i2osp (unMPI wrappedMPI)) +parseECDHPKESKMPIs _ = + Left + "ECDH PKESK must contain exactly two MPIs (ephemeral key, wrapped session key)" + +newtype LegacyECDHWrappedRFC3394Ciphertext + = LegacyECDHWrappedRFC3394Ciphertext + { unLegacyECDHWrappedRFC3394Ciphertext :: B.ByteString + } + deriving (Eq) + +newtype LegacyECDHSessionKey = LegacyECDHSessionKey {unLegacyECDHSessionKey :: B.ByteString} + +newtype LegacyECDHSessionPadding = LegacyECDHSessionPadding + {unLegacyECDHSessionPadding :: B.ByteString} + +data LegacyECDHDecodedSessionMaterial + = LegacyECDHDecodedSessionMaterial + { legacyECDHSessionAlgorithm :: SymmetricAlgorithm + , legacyECDHSessionKey :: LegacyECDHSessionKey + , legacyECDHSessionPadding :: LegacyECDHSessionPadding + } + +candidateWrappedRFC3394CiphertextsForLegacyECDH + :: LegacyECDHWrappedRFC3394Ciphertext + -> [LegacyECDHWrappedRFC3394Ciphertext] +candidateWrappedRFC3394CiphertextsForLegacyECDH wrapped = + let observedLen = B.length (unLegacyECDHWrappedRFC3394Ciphertext wrapped) + plausibleWrappedLens = legacyECDHRFC3394WrappedLengths + reconstructed = + [ LegacyECDHWrappedRFC3394Ciphertext + ( if observedLen == targetLen + then unLegacyECDHWrappedRFC3394Ciphertext wrapped + else + leftPadTo + targetLen + (unLegacyECDHWrappedRFC3394Ciphertext wrapped) + ) + | targetLen <- plausibleWrappedLens + , targetLen >= observedLen + ] + in nub (wrapped : reconstructed) + +legacyECDHRFC3394WrappedLengths :: [Int] +legacyECDHRFC3394WrappedLengths = + map legacyRFC3394WrappedLenForKeyLen [16, 24, 32] + where + legacyRFC3394WrappedLenForKeyLen keyLen = + let encodedLen = 1 + keyLen + 2 + paddedLen = ((encodedLen + 7) `div` 8) * 8 + in paddedLen + 8 + +parseLegacyECDHDecodedSessionMaterial + :: B.ByteString -> Either String LegacyECDHDecodedSessionMaterial +parseLegacyECDHDecodedSessionMaterial decoded = do + when (B.length decoded < 3) $ + Left "legacy ECDH decoded session material is too short" + let sessionAlgorithm = toFVal (B.head decoded) + sessionKeyLen <- symmetricKeyLength sessionAlgorithm + let payload = B.tail decoded + when (B.length payload < sessionKeyLen + 2) $ + Left + "legacy ECDH decoded session material does not contain full key and checksum" + let (sessionKey, checksumAndPad) = B.splitAt sessionKeyLen payload + (checksumBytes, padBytes) = B.splitAt 2 checksumAndPad + expectedChecksum = + fromIntegral (B.index checksumBytes 0) `shiftL` 8 + + fromIntegral (B.index checksumBytes 1) + actualChecksum = checksum16 sessionKey + when (actualChecksum /= expectedChecksum) $ + Left "legacy ECDH decoded session-key checksum mismatch" + if B.null padBytes || B.all (== 0) padBytes + then + Right + ( LegacyECDHDecodedSessionMaterial + sessionAlgorithm + (LegacyECDHSessionKey sessionKey) + (LegacyECDHSessionPadding padBytes) + ) + else do + validatePKCS7Padding padBytes + Right + ( LegacyECDHDecodedSessionMaterial + sessionAlgorithm + (LegacyECDHSessionKey sessionKey) + (LegacyECDHSessionPadding padBytes) + ) + +encodeLegacyECDHSessionMaterial + :: LegacyECDHDecodedSessionMaterial -> B.ByteString +encodeLegacyECDHSessionMaterial + ( LegacyECDHDecodedSessionMaterial + sessionAlgorithm + (LegacyECDHSessionKey sessionKey) + _ + ) = + B.singleton (fromIntegral (fromFVal sessionAlgorithm)) + <> sessionKey + <> checksum16Bytes sessionKey + +parsePKESKv6ECDHEsk + :: PubKeyAlgorithm + -> B.ByteString + -> Either String (B.ByteString, B.ByteString) +parsePKESKv6ECDHEsk pka esk + | pka == X25519 = + case parseFixedEphemeralWithWrappedLen 32 esk of + Right parsed -> Right parsed + Left _ -> parseLenPrefixedEphemeral 32 esk + | pka == X448 = + case parseFixedEphemeralWithWrappedLen 56 esk of + Right parsed -> Right parsed + Left _ -> parseLenPrefixedEphemeral 56 esk + | B.length esk < 33 = + Left "PKESKv6 ECDH ESK is too short" + | otherwise = + let withLen = + let ephLen = fromIntegral (B.head esk) + rest = B.tail esk + in if ephLen > 0 && B.length rest > ephLen + then + let (eph, wrapped) = B.splitAt ephLen rest + in if validWrappedPayload wrapped + then Just (eph, wrapped) + else Nothing + else Nothing + fixed32WithWrappedLen = parseFixedEphemeralWithWrappedLenMaybe 32 esk + fixed32 = + let (eph, wrapped) = B.splitAt 32 esk + in if validWrappedPayload wrapped + then Just (eph, wrapped) + else Nothing + mpiWithWrappedLen = + if B.length esk >= 4 + then + let mpiBits = + fromIntegral (B.index esk 0) `shiftL` 8 + + fromIntegral (B.index esk 1) + mpiLen = (mpiBits + 7) `div` 8 + rest = B.drop (2 + mpiLen) esk + in if mpiLen > 0 && B.length esk > 2 + mpiLen && not (B.null rest) + then + let eph = B.take mpiLen (B.drop 2 esk) + wrappedLen = fromIntegral (B.head rest) + wrapped = B.tail rest + in if wrappedLen == B.length wrapped && validWrappedPayload wrapped + then Just (eph, wrapped) + else Nothing + else Nothing + else Nothing + in case fixed32WithWrappedLen + <|> withLen + <|> fixed32 + <|> mpiWithWrappedLen of + Just x -> Right x + Nothing -> + Left + "PKESKv6 ECDH ESK could not be parsed as {ephemeral32||len||wrapped}, {len||ephemeral||wrapped}, {ephemeral32||wrapped}, or {mpi(ephemeral)||len||wrapped}" + where + validWrappedPayload wrapped = B.length wrapped >= 24 && B.length wrapped `mod` 8 == 0 + + parseFixedEphemeralWithWrappedLenMaybe ephLen payload = + let (eph, rest) = B.splitAt ephLen payload + in if B.length rest >= 2 + then + let wrappedLen = fromIntegral (B.head rest) + wrapped = B.tail rest + in if wrappedLen == B.length wrapped && validWrappedPayload wrapped + then Just (eph, wrapped) + else Nothing + else Nothing + + parseFixedEphemeralWithWrappedLen ephLen payload = + maybe + ( Left + ( "PKESKv6 XDH ESK expected {ephemeral" + ++ show ephLen + ++ "||len||wrapped} framing" + ) + ) + Right + (parseFixedEphemeralWithWrappedLenMaybe ephLen payload) + + parseLenPrefixedEphemeral expectedLen payload = + if B.null payload + then Left "PKESKv6 XDH ESK is empty" + else + let ephLen = fromIntegral (B.head payload) + rest = B.tail payload + in if ephLen == expectedLen && B.length rest > ephLen + then + let (eph, wrapped) = B.splitAt ephLen rest + in if validWrappedPayload wrapped + then Right (eph, wrapped) + else Left "PKESKv6 XDH ESK wrapped payload has invalid length" + else + Left + ( "PKESKv6 XDH ESK expected " + ++ show expectedLen + ++ "-octet ephemeral value" + ) + +normalizeX25519EphemeralPublic + :: B.ByteString -> Either String B.ByteString +normalizeX25519EphemeralPublic = + normalizeMontgomeryPublic + 32 + "invalid X25519 ephemeral public key length/prefix: " + +normalizeX448EphemeralPublic + :: B.ByteString -> Either String B.ByteString +normalizeX448EphemeralPublic = + normalizeMontgomeryPublic + 56 + "invalid X448 ephemeral public key length/prefix: " + +parseUncompressedPointForCurve + :: MonadFail m => ECCT.Curve -> B.ByteString -> m ECCT.Point +parseUncompressedPointForCurve curve bs + | B.length bs < 1 = fail "ECDH ephemeral point is empty" + | Just expectedLen <- expectedUncompressedPointLength curve + , B.length bs /= expectedLen = + fail + ( "ECDH ephemeral point has invalid length for recipient curve: expected " + ++ show expectedLen + ++ ", got " + ++ show (B.length bs) + ) + | B.head bs /= 0x04 = + fail "ECDH ephemeral point must be uncompressed (0x04)" + | otherwise = + let xy = B.tail bs + in if odd (B.length xy) + then fail "ECDH ephemeral point has malformed coordinate length" + else + let (xb, yb) = B.splitAt (B.length xy `div` 2) xy + in pure (ECCT.Point (os2ip xb) (os2ip yb)) + +expectedUncompressedPointLength :: ECCT.Curve -> Maybe Int +expectedUncompressedPointLength curve + | curve == ECCT.getCurveByName ECCT.SEC_p256r1 = Just 65 + | curve == ECCT.getCurveByName ECCT.SEC_p384r1 = Just 97 + | curve == ECCT.getCurveByName ECCT.SEC_p521r1 = Just 133 + | otherwise = Nothing + +deriveX25519Kek + :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +deriveX25519Kek ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHA.SHA256 B.empty ikm + info :: B.ByteString + info = "OpenPGP X25519" + okm :: B.ByteString + okm = expand @CHA.SHA256 prk info 16 + in okm + +deriveX448Kek + :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +deriveX448Kek ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHA.SHA512 B.empty ikm + info :: B.ByteString + info = "OpenPGP X448" + okm :: B.ByteString + okm = expand @CHA.SHA512 prk info 32 + in okm + +aesKeyUnwrapRFC3394 + :: SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> Either String B.ByteString +aesKeyUnwrapRFC3394 sa kek wrapped = + withAESCipher + "ECDH PKESK currently supports AES KEK algorithms only" + sa + kek + unwrapWithCipher + where + unwrapWithCipher + :: CCT.BlockCipher cipher + => cipher + -> Either String B.ByteString + unwrapWithCipher cipher = do + when (B.length wrapped < 24 || B.length wrapped `mod` 8 /= 0) $ + Left + "ECDH wrapped session key must be at least 24 octets and a multiple of 8" + let (a0, rBytes) = B.splitAt 8 wrapped + rs = chunksOf8 rBytes + when (length rs < 2) $ + Left + "ECDH wrapped session key must contain at least two 64-bit blocks" + (aFinal, rFinal) <- unwrapRounds cipher a0 rs + when (aFinal /= B.replicate 8 0xA6) $ + Left "ECDH wrapped session key integrity check failed" + Right (B.concat rFinal) + + unwrapRounds + :: CCT.BlockCipher cipher + => cipher + -> B.ByteString + -> [B.ByteString] + -> Either String (B.ByteString, [B.ByteString]) + unwrapRounds cipher aInit rsInit = goJ 5 aInit rsInit + where + n = length rsInit + goJ j aState rsState + | j < 0 = Right (aState, rsState) + | otherwise = do + (a', rs') <- goI n aState rsState + goJ (j - 1) a' rs' + where + goI i aCurrent rsCurrent + | i <= 0 = Right (aCurrent, rsCurrent) + | otherwise = do + let t = fromIntegral (n * j + i) :: Word64 + aXorT = xorBS aCurrent (encodeWord64be t) + rI = rsCurrent !! (i - 1) + block = CCT.ecbDecrypt cipher (aXorT <> rI) + (aNext, rNext) = B.splitAt 8 block + rsNext = (ix (i - 1) .~ rNext) rsCurrent + goI (i - 1) aNext rsNext + +chunksOf8 :: B.ByteString -> [B.ByteString] +chunksOf8 bs + | B.null bs = [] + | otherwise = + let (h, t) = B.splitAt 8 bs + in h : chunksOf8 t + +xorBS :: B.ByteString -> B.ByteString -> B.ByteString +xorBS a b = B.pack (B.zipWith xor a b) + +decodePKESKSessionKey + :: Maybe SymmetricAlgorithm + -> B.ByteString + -> Either String (SymmetricAlgorithm, B.ByteString) +decodePKESKSessionKey expectedSymAlgo encodedSessionKey = + case decodeOpenPGPEncodedSessionKey encodedSessionKey of + Right (symalgo, sessionKey) -> + case expectedSymAlgo of + Just expected + | expected /= symalgo -> + Left "Decrypted PKESK symmetric algorithm does not match payload" + _ -> Right (symalgo, sessionKey) + Left decodeErr -> + case expectedSymAlgo of + Nothing -> + Left + ( "PKESK session key material must be OpenPGP encoded when payload algorithm is unknown: " + ++ renderEncodedSessionKeyError decodeErr + ) + Just expected -> do + expectedLen <- symmetricKeyLength expected + case decodeExpectedRawOrPaddedSessionKey + expected + expectedLen + encodedSessionKey of + Left err -> Left err + Right sessionKey -> Right (expected, sessionKey) + +parsePKESKv3X25519EskBytes + :: B.ByteString -> Either String (SymmetricAlgorithm, B.ByteString) +parsePKESKv3X25519EskBytes eskBytes = do + when (B.length eskBytes < 2) $ + Left "PKESKv3 X25519 ESK field is too short" + let sessionAlgorithm = toFVal (B.head eskBytes) + wrappedSessionKeyBytes = B.tail eskBytes + when (sessionAlgorithm `notElem` [AES128, AES192, AES256]) $ + Left + "PKESKv3 X25519 ESK field uses unsupported symmetric algorithm" + when + ( B.length wrappedSessionKeyBytes < 24 + || B.length wrappedSessionKeyBytes `mod` 8 /= 0 + ) + $ Left + "PKESKv3 X25519 wrapped session key must be at least 24 octets and a multiple of 8" + pure (sessionAlgorithm, wrappedSessionKeyBytes) + +decodeExpectedRawOrPaddedSessionKey + :: SymmetricAlgorithm + -> Int + -> B.ByteString + -> Either String B.ByteString +decodeExpectedRawOrPaddedSessionKey expected expectedLen encodedSessionKey + | B.length encodedSessionKey == expectedLen = + Right encodedSessionKey + | otherwise = + case decodeV6PaddedSessionKeyWithoutAlgo expectedLen encodedSessionKey of + Right sessionKey -> Right sessionKey + Left _ -> + case decodeV6PaddedSessionKeyWithAlgo + expected + expectedLen + encodedSessionKey of + Right sessionKey -> Right sessionKey + Left _ -> + Left + "PKESK raw session key length does not match payload algorithm" + +decodeV6PaddedSessionKeyWithoutAlgo + :: Int -> B.ByteString -> Either String B.ByteString +decodeV6PaddedSessionKeyWithoutAlgo expectedLen encodedSessionKey = do + when (B.length encodedSessionKey < expectedLen + 2) $ + Left "v6 ECDH decoded session material is too short" + let (sessionKey, rest) = B.splitAt expectedLen encodedSessionKey + (checksumBytes, padBytes) = B.splitAt 2 rest + expectedChecksum = + fromIntegral (B.index checksumBytes 0) `shiftL` 8 + + fromIntegral (B.index checksumBytes 1) + actualChecksum = checksum16 sessionKey + when (actualChecksum /= expectedChecksum) $ + Left "v6 ECDH decoded session-key checksum mismatch" + validatePKCS7Padding padBytes + Right sessionKey + +decodeV6PaddedSessionKeyWithAlgo + :: SymmetricAlgorithm + -> Int + -> B.ByteString + -> Either String B.ByteString +decodeV6PaddedSessionKeyWithAlgo expected expectedLen encodedSessionKey = do + when (B.length encodedSessionKey < expectedLen + 3) $ + Left + "v6 ECDH decoded session material with algorithm octet is too short" + let algOctet = B.head encodedSessionKey + when (toFVal algOctet /= expected) $ + Left "v6 ECDH decoded session material algorithm mismatch" + let rest = B.tail encodedSessionKey + (sessionKey, checksumAndPad) = B.splitAt expectedLen rest + (checksumBytes, padBytes) = B.splitAt 2 checksumAndPad + expectedChecksum = + fromIntegral (B.index checksumBytes 0) `shiftL` 8 + + fromIntegral (B.index checksumBytes 1) + actualChecksum = checksum16 sessionKey + when (actualChecksum /= expectedChecksum) $ + Left "v6 ECDH decoded session-key checksum mismatch" + validatePKCS7Padding padBytes + Right sessionKey + +validatePKCS7Padding :: B.ByteString -> Either String () +validatePKCS7Padding padBytes + | B.null padBytes = Right () + | otherwise = do + let padLen = fromIntegral (B.last padBytes) :: Int + when (padLen <= 0 || padLen > 8 || B.length padBytes /= padLen) $ + Left + "v6 ECDH decoded session material has invalid PKCS#7-style padding length" + when (B.any (/= fromIntegral padLen) padBytes) $ + Left + "v6 ECDH decoded session material has invalid PKCS#7-style padding bytes" + +symmetricKeyLength :: SymmetricAlgorithm -> Either String Int +symmetricKeyLength = first renderCipherError . keySize + +checksum16 :: B.ByteString -> Word16 +checksum16 = + fromIntegral + . B.foldl' + (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) + 0 + +checksum16Bytes :: B.ByteString -> B.ByteString +checksum16Bytes sessionKey = + B.pack [fromIntegral (chk `shiftR` 8), fromIntegral chk] where chk = checksum16 sessionKey diff --git a/Data/Conduit/OpenPGP/Keyring.hs b/Data/Conduit/OpenPGP/Keyring.hs --- a/Data/Conduit/OpenPGP/Keyring.hs +++ b/Data/Conduit/OpenPGP/Keyring.hs @@ -2,496 +2,502 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} module Data.Conduit.OpenPGP.Keyring - ( conduitToUnknownTKs - , TypedTKConduitError(..) - , conduitToSomeTKsEither - , conduitToSomeTKsDropping - , conduitToSomeTKsDroppingEither - , conduitToTKs - , conduitToPublicTKs - , conduitToPublicViewTKs - , conduitToSecretTKs - , AuthSecretSubkeyUID(..) - , AuthSecretSubkeyAtTime(..) - , AuthSecretSubkeyRejectionReason(..) - , AuthSecretSubkeyRejectedAtTime(..) - , AuthSecretSubkeysAtReport(..) - , authSecretSubkeysAt - , authSecretSubkeysAtReport - , conduitToAuthSecretSubkeysAt - , conduitToAuthSecretSubkeysAtReport - , conduitToTKsDropping - , conduitToTKsEither - , conduitToTKsDroppingEither - , conduitToTKsWithWireRep - , conduitToTKsDroppingWithWireRep - , conduitToTKsWithWireRepEither - , conduitToTKsDroppingWithWireRepEither - , KeyringChunkParseError(..) - , sinkPublicKeyringMap - , sinkSecretKeyringMap - , publicTKToKeyring - , secretTKToKeyring - , partitionSomeTKs - ) where + ( TypedTKConduitError (..) + , conduitToSomeTKsEither + , conduitToSomeTKsDroppingEither + , AuthSecretSubkeyUID (..) + , AuthSecretSubkeyAtTime (..) + , AuthSecretSubkeyRejectionReason (..) + , AuthSecretSubkeyRejectedAtTime (..) + , AuthSecretSubkeysAtReport (..) + , authSecretSubkeysAt + , authSecretSubkeysAtReport + , conduitToAuthSecretSubkeysAt + , conduitToAuthSecretSubkeysAtReport + , conduitToTKsEither + , conduitToTKsDroppingEither + , conduitToTKsWithWireRepEither + , conduitToTKsDroppingWithWireRepEither + , conduitDropErrorsAndNothings + , KeyringChunkParseError (..) + , sinkPublicKeyringMap + , sinkSecretKeyringMap + , publicTKToKeyring + , secretTKToKeyring + , partitionSomeTKs + ) where +import Data.Bifunctor (first) import Data.Conduit import qualified Data.Conduit.List as CL -import Data.Bifunctor (first) +import Data.IxSet.Typed (empty, insert) import Data.List (find) import Data.Maybe (maybeToList) import qualified Data.Set as Set import Data.Text (Text) import Data.Time.Clock (UTCTime) -import Data.IxSet.Typed (empty, insert) import Codec.Encryption.OpenPGP.Expirations - ( isCertificationSig - , isPKTimeValidWithSelfSignatures - , isTKTimeValid - , newestByCreationTime - , signatureCreationTime - , signatureEffectiveAt - ) + ( isCertificationSig + , isPKTimeValidWithSelfSignatures + , isTKTimeValid + , newestByCreationTime + , signatureCreationTime + , signatureEffectiveAt + ) import Codec.Encryption.OpenPGP.KeyringParser - ( KeyringChunkParseError(..) - , anyTK - , anyTKWithWireRep - , finalizeParsingEither - , parseAChunkEither - ) -import Codec.Encryption.OpenPGP.Ontology (isSubkeyBindingSig, isTrustPkt) + ( KeyringChunkParseError (..) + , anyTK + , anyTKWithWireRep + , finalizeParsingEither + , parseAChunkEither + ) +import Codec.Encryption.OpenPGP.Ontology + ( isSubkeyBindingSig + , isTrustPkt + ) +import Codec.Encryption.OpenPGP.Policy + ( defaultVerificationPolicy + ) import Codec.Encryption.OpenPGP.SignatureQualities - ( signatureHashedSubpacketsKnown - ) + ( signatureHashedSubpacketsKnown + ) import Codec.Encryption.OpenPGP.Signatures - ( verifyAgainstKeys - , verifySigWith - , verifyTKWith - ) + ( verifyAgainstKeys + , verifySigWith + , verifyTKWith + ) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances () data Phase - = MainKey - | Revs - | Uids - | UAts - | Subs - | SkippingBroken - deriving (Eq, Ord, Show) + = MainKey + | Revs + | Uids + | UAts + | Subs + | SkippingBroken + deriving (Eq, Ord, Show) data TypedTKConduitError - = TypedTKParseError KeyringChunkParseError - | TypedTKConversionError TKConversionError - deriving (Eq, Show) - --- | Deprecated: this conduit silently drops parse failures and parse-time --- omissions. Prefer 'conduitToTKsEither' and handle errors explicitly. -conduitToUnknownTKs :: Monad m => ConduitT Pkt TKUnknown m () -conduitToUnknownTKs = - conduitToTKsEither .| - conduitDropErrorsAndNothings -{-# DEPRECATED conduitToUnknownTKs "Use conduitToTKsEither and handle Left/Maybe explicitly." #-} + = TypedTKParseError KeyringChunkParseError + | TypedTKConversionError TKConversionError + deriving (Eq, Show) -- | Canonical strict typed conduit with explicit parse+conversion error channel. -conduitToSomeTKsEither :: - Monad m => ConduitT Pkt (Either TypedTKConduitError (Maybe SomeTK)) m () +conduitToSomeTKsEither + :: (Monad m) + => ConduitT Pkt (Either TypedTKConduitError (Maybe SomeTK)) m () conduitToSomeTKsEither = - conduitToTKsEither .| - CL.map toTypedSomeTKEither - --- | Deprecated: this conduit silently drops parse+conversion failures. --- Prefer 'conduitToSomeTKsEither' and handle errors explicitly. -conduitToSomeTKsDropping :: Monad m => ConduitT Pkt SomeTK m () -conduitToSomeTKsDropping = - conduitToSomeTKsDroppingEither .| - conduitDropErrorsAndNothings -{-# DEPRECATED conduitToSomeTKsDropping "Use conduitToSomeTKsEither and handle Left/Maybe explicitly." #-} + conduitToTKsEither + .| CL.map toTypedSomeTKEither --- | Tolerant typed conduit (broken transferable-key chunks may be omitted), --- while still surfacing parse+conversion failures. -conduitToSomeTKsDroppingEither :: - Monad m => ConduitT Pkt (Either TypedTKConduitError (Maybe SomeTK)) m () +{- | Tolerant typed conduit (broken transferable-key chunks may be omitted), +while still surfacing parse+conversion failures. +-} +conduitToSomeTKsDroppingEither + :: (Monad m) + => ConduitT Pkt (Either TypedTKConduitError (Maybe SomeTK)) m () conduitToSomeTKsDroppingEither = - conduitToTKsDroppingEither .| - CL.map toTypedSomeTKEither - --- | Deprecated: this conduit silently drops parse+conversion failures. --- Prefer 'conduitToSomeTKsEither' and handle errors explicitly. -conduitToTKs :: Monad m => ConduitT Pkt SomeTK m () -conduitToTKs = - conduitToUnknownTKs .| - CL.mapMaybe (either (const Nothing) Just . fromUnknownToTKEither) -{-# DEPRECATED conduitToTKs "Use conduitToSomeTKsEither and handle Left/Maybe explicitly." #-} + conduitToTKsDroppingEither + .| CL.map toTypedSomeTKEither -toTypedSomeTKEither :: - Either KeyringChunkParseError (Maybe TKUnknown) - -> Either TypedTKConduitError (Maybe SomeTK) +toTypedSomeTKEither + :: Either KeyringChunkParseError (Maybe TKUnknown) + -> Either TypedTKConduitError (Maybe SomeTK) toTypedSomeTKEither = - either - (Left . TypedTKParseError) - (\maybeUnknown -> - case maybeUnknown of - Nothing -> Right Nothing - Just unknown -> first TypedTKConversionError (Just <$> fromUnknownToTKEither unknown)) - -conduitToPublicTKs :: Monad m => ConduitT Pkt (TK 'PublicTK) m () -conduitToPublicTKs = - conduitToTKs .| - CL.mapMaybe someTKToPublicTK -{-# DEPRECATED conduitToPublicTKs "Use conduitToSomeTKsEither and perform explicit projection/filtering." #-} - --- | Yield public TKs from any input: native public TKs pass through, --- secret TKs are stripped to their public view -conduitToPublicViewTKs :: Monad m => ConduitT Pkt (TK 'PublicTK) m () -conduitToPublicViewTKs = - conduitToTKs .| - CL.map someTKToPublicViewTK -{-# DEPRECATED conduitToPublicViewTKs "Use conduitToSomeTKsEither and perform explicit projection." #-} - -conduitToSecretTKs :: Monad m => ConduitT Pkt (TK 'SecretTK) m () -conduitToSecretTKs = - conduitToTKs .| - CL.mapMaybe someTKToSecretTK -{-# DEPRECATED conduitToSecretTKs "Use conduitToSomeTKsEither and perform explicit projection/filtering." #-} + either + (Left . TypedTKParseError) + ( \maybeUnknown -> + case maybeUnknown of + Nothing -> Right Nothing + Just unknown -> + first + TypedTKConversionError + (Just <$> fromUnknownToTKEither unknown) + ) -data AuthSecretSubkeyUID = - AuthSecretSubkeyUID +data AuthSecretSubkeyUID + = AuthSecretSubkeyUID { authSecretSubkeyUIDValue :: Text , authSecretSubkeyUIDIsPrimary :: Bool } - deriving (Eq, Show) + deriving (Eq, Show) -data AuthSecretSubkeyAtTime = - AuthSecretSubkeyAtTime +data AuthSecretSubkeyAtTime + = AuthSecretSubkeyAtTime { authSecretSubkeyPrimaryKey :: KeyPkt 'SecretPkt , authSecretSubkeyValue :: KeyPkt 'SecretPkt , authSecretSubkeyUIDs :: [AuthSecretSubkeyUID] , authSecretSubkeyPrimaryUID :: Maybe Text } - deriving (Eq, Show) + deriving (Eq, Show) data AuthSecretSubkeyRejectionReason - = AuthSecretSubkeyTKVerificationFailed - | AuthSecretSubkeyPrimaryKeyInvalidAtTime - | AuthSecretSubkeyNotSecretSubkeyPacket - | AuthSecretSubkeyNotSubkeyPacket - | AuthSecretSubkeySubkeyInvalidAtTime - | AuthSecretSubkeyMissingAuthCapability - deriving (Eq, Show) + = AuthSecretSubkeyTKVerificationFailed + | AuthSecretSubkeyPrimaryKeyInvalidAtTime + | AuthSecretSubkeyNotSecretSubkeyPacket + | AuthSecretSubkeyNotSubkeyPacket + | AuthSecretSubkeySubkeyInvalidAtTime + | AuthSecretSubkeyMissingAuthCapability + deriving (Eq, Show) -data AuthSecretSubkeyRejectedAtTime = - AuthSecretSubkeyRejectedAtTime +data AuthSecretSubkeyRejectedAtTime + = AuthSecretSubkeyRejectedAtTime { authSecretSubkeyRejectedPrimaryKey :: KeyPkt 'SecretPkt , authSecretSubkeyRejectedValue :: Maybe (KeyPkt 'SecretPkt) , authSecretSubkeyRejectedUIDs :: [AuthSecretSubkeyUID] , authSecretSubkeyRejectedPrimaryUID :: Maybe Text , authSecretSubkeyRejectedReason :: AuthSecretSubkeyRejectionReason } - deriving (Eq, Show) + deriving (Eq, Show) -data AuthSecretSubkeysAtReport = - AuthSecretSubkeysAtReport +data AuthSecretSubkeysAtReport + = AuthSecretSubkeysAtReport { authSecretSubkeysAccepted :: [AuthSecretSubkeyAtTime] , authSecretSubkeysRejected :: [AuthSecretSubkeyRejectedAtTime] } - deriving (Eq, Show) + deriving (Eq, Show) -conduitToAuthSecretSubkeysAtReport :: - Monad m - => UTCTime - -> ConduitT (TK 'SecretTK) AuthSecretSubkeysAtReport m () +conduitToAuthSecretSubkeysAtReport + :: Monad m + => UTCTime + -> ConduitT (TK 'SecretTK) AuthSecretSubkeysAtReport m () conduitToAuthSecretSubkeysAtReport validationTime = - CL.map (authSecretSubkeysAtReport validationTime) + CL.map (authSecretSubkeysAtReport validationTime) -conduitToAuthSecretSubkeysAt :: - Monad m - => UTCTime - -> ConduitT (TK 'SecretTK) AuthSecretSubkeyAtTime m () +conduitToAuthSecretSubkeysAt + :: Monad m + => UTCTime + -> ConduitT (TK 'SecretTK) AuthSecretSubkeyAtTime m () conduitToAuthSecretSubkeysAt validationTime = - CL.concatMap (authSecretSubkeysAccepted . authSecretSubkeysAtReport validationTime) + CL.concatMap + ( authSecretSubkeysAccepted + . authSecretSubkeysAtReport validationTime + ) -authSecretSubkeysAt :: UTCTime -> TK 'SecretTK -> [AuthSecretSubkeyAtTime] +authSecretSubkeysAt + :: UTCTime -> TK 'SecretTK -> [AuthSecretSubkeyAtTime] authSecretSubkeysAt validationTime = - authSecretSubkeysAccepted . authSecretSubkeysAtReport validationTime + authSecretSubkeysAccepted + . authSecretSubkeysAtReport validationTime -authSecretSubkeysAtReport :: UTCTime -> TK 'SecretTK -> AuthSecretSubkeysAtReport +authSecretSubkeysAtReport + :: UTCTime -> TK 'SecretTK -> AuthSecretSubkeysAtReport authSecretSubkeysAtReport validationTime typedTk = - case verifyTKWith (verifySigWith (verifyAgainstKeys [untyped])) (Just validationTime) typedTk of - Left _ -> - AuthSecretSubkeysAtReport - [] - [ AuthSecretSubkeyRejectedAtTime - { authSecretSubkeyRejectedPrimaryKey = primaryKey - , authSecretSubkeyRejectedValue = Nothing - , authSecretSubkeyRejectedUIDs = [] - , authSecretSubkeyRejectedPrimaryUID = Nothing - , authSecretSubkeyRejectedReason = AuthSecretSubkeyTKVerificationFailed - } - ] - Right verifiedTk - | not (isTKTimeValid validationTime (tkToUnknown verifiedTk)) -> - let uids = uidContextsAt validationTime (tkToUnknown verifiedTk) - primaryUid = authSecretSubkeyUIDValue <$> find authSecretSubkeyUIDIsPrimary uids - in AuthSecretSubkeysAtReport + case verifyTKWith + ( verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys [untyped]) + ) + (Just validationTime) + typedTk of + Left _ -> + AuthSecretSubkeysAtReport [] [ AuthSecretSubkeyRejectedAtTime { authSecretSubkeyRejectedPrimaryKey = primaryKey , authSecretSubkeyRejectedValue = Nothing - , authSecretSubkeyRejectedUIDs = uids - , authSecretSubkeyRejectedPrimaryUID = primaryUid - , authSecretSubkeyRejectedReason = AuthSecretSubkeyPrimaryKeyInvalidAtTime + , authSecretSubkeyRejectedUIDs = [] + , authSecretSubkeyRejectedPrimaryUID = Nothing + , authSecretSubkeyRejectedReason = + AuthSecretSubkeyTKVerificationFailed } ] - | otherwise -> - let uids = uidContextsAt validationTime (tkToUnknown verifiedTk) - primaryUid = authSecretSubkeyUIDValue <$> find authSecretSubkeyUIDIsPrimary uids - in foldr - (\subCandidate acc -> - case classifySecretSubkeyAtTime validationTime primaryKey uids primaryUid subCandidate of - Left rejected -> - acc {authSecretSubkeysRejected = rejected : authSecretSubkeysRejected acc} - Right accepted -> - acc {authSecretSubkeysAccepted = accepted : authSecretSubkeysAccepted acc}) - (AuthSecretSubkeysAtReport [] []) - (_tkSubs verifiedTk) + Right verifiedTk + | not (isTKTimeValid validationTime (tkToUnknown verifiedTk)) -> + let uids = uidContextsAt validationTime (tkToUnknown verifiedTk) + primaryUid = + authSecretSubkeyUIDValue + <$> find authSecretSubkeyUIDIsPrimary uids + in AuthSecretSubkeysAtReport + [] + [ AuthSecretSubkeyRejectedAtTime + { authSecretSubkeyRejectedPrimaryKey = primaryKey + , authSecretSubkeyRejectedValue = Nothing + , authSecretSubkeyRejectedUIDs = uids + , authSecretSubkeyRejectedPrimaryUID = primaryUid + , authSecretSubkeyRejectedReason = + AuthSecretSubkeyPrimaryKeyInvalidAtTime + } + ] + | otherwise -> + let uids = uidContextsAt validationTime (tkToUnknown verifiedTk) + primaryUid = + authSecretSubkeyUIDValue + <$> find authSecretSubkeyUIDIsPrimary uids + in foldr + ( \subCandidate acc -> + case classifySecretSubkeyAtTime + validationTime + primaryKey + uids + primaryUid + subCandidate of + Left rejected -> + acc + { authSecretSubkeysRejected = + rejected : authSecretSubkeysRejected acc + } + Right accepted -> + acc + { authSecretSubkeysAccepted = + accepted : authSecretSubkeysAccepted acc + } + ) + (AuthSecretSubkeysAtReport [] []) + (_tkSubs verifiedTk) where untyped = tkToUnknown typedTk primaryKey = _tkPrimaryKey typedTk -classifySecretSubkeyAtTime :: - UTCTime - -> KeyPkt 'SecretPkt - -> [AuthSecretSubkeyUID] - -> Maybe Text - -> (KeyPkt 'SecretPkt, [SignaturePayload]) - -> Either AuthSecretSubkeyRejectedAtTime AuthSecretSubkeyAtTime +classifySecretSubkeyAtTime + :: UTCTime + -> KeyPkt 'SecretPkt + -> [AuthSecretSubkeyUID] + -> Maybe Text + -> (KeyPkt 'SecretPkt, [SignaturePayload]) + -> Either AuthSecretSubkeyRejectedAtTime AuthSecretSubkeyAtTime classifySecretSubkeyAtTime validationTime primaryKey uids primaryUid (subkey, sigs) - | keyPktRole subkey /= KeyPktSubkey = - Left - AuthSecretSubkeyRejectedAtTime - { authSecretSubkeyRejectedPrimaryKey = primaryKey - , authSecretSubkeyRejectedValue = Just subkey - , authSecretSubkeyRejectedUIDs = uids - , authSecretSubkeyRejectedPrimaryUID = primaryUid - , authSecretSubkeyRejectedReason = AuthSecretSubkeyNotSubkeyPacket - } - | not (isPKTimeValidWithSelfSignatures validationTime (keyPktPKPayload subkey) sigs) = - Left - AuthSecretSubkeyRejectedAtTime - { authSecretSubkeyRejectedPrimaryKey = primaryKey - , authSecretSubkeyRejectedValue = Just subkey - , authSecretSubkeyRejectedUIDs = uids - , authSecretSubkeyRejectedPrimaryUID = primaryUid - , authSecretSubkeyRejectedReason = AuthSecretSubkeySubkeyInvalidAtTime - } - | not (subkeyAuthCapableAt validationTime sigs) = - Left - AuthSecretSubkeyRejectedAtTime - { authSecretSubkeyRejectedPrimaryKey = primaryKey - , authSecretSubkeyRejectedValue = Just subkey - , authSecretSubkeyRejectedUIDs = uids - , authSecretSubkeyRejectedPrimaryUID = primaryUid - , authSecretSubkeyRejectedReason = AuthSecretSubkeyMissingAuthCapability - } - | otherwise = - Right - AuthSecretSubkeyAtTime - { authSecretSubkeyPrimaryKey = primaryKey - , authSecretSubkeyValue = subkey - , authSecretSubkeyUIDs = uids - , authSecretSubkeyPrimaryUID = primaryUid - } + | keyPktRole subkey /= KeyPktSubkey = + Left + AuthSecretSubkeyRejectedAtTime + { authSecretSubkeyRejectedPrimaryKey = primaryKey + , authSecretSubkeyRejectedValue = Just subkey + , authSecretSubkeyRejectedUIDs = uids + , authSecretSubkeyRejectedPrimaryUID = primaryUid + , authSecretSubkeyRejectedReason = AuthSecretSubkeyNotSubkeyPacket + } + | not + ( isPKTimeValidWithSelfSignatures + validationTime + (keyPktPKPayload subkey) + sigs + ) = + Left + AuthSecretSubkeyRejectedAtTime + { authSecretSubkeyRejectedPrimaryKey = primaryKey + , authSecretSubkeyRejectedValue = Just subkey + , authSecretSubkeyRejectedUIDs = uids + , authSecretSubkeyRejectedPrimaryUID = primaryUid + , authSecretSubkeyRejectedReason = + AuthSecretSubkeySubkeyInvalidAtTime + } + | not (subkeyAuthCapableAt validationTime sigs) = + Left + AuthSecretSubkeyRejectedAtTime + { authSecretSubkeyRejectedPrimaryKey = primaryKey + , authSecretSubkeyRejectedValue = Just subkey + , authSecretSubkeyRejectedUIDs = uids + , authSecretSubkeyRejectedPrimaryUID = primaryUid + , authSecretSubkeyRejectedReason = + AuthSecretSubkeyMissingAuthCapability + } + | otherwise = + Right + AuthSecretSubkeyAtTime + { authSecretSubkeyPrimaryKey = primaryKey + , authSecretSubkeyValue = subkey + , authSecretSubkeyUIDs = uids + , authSecretSubkeyPrimaryUID = primaryUid + } uidContextsAt :: UTCTime -> TKUnknown -> [AuthSecretSubkeyUID] uidContextsAt validationTime tk = - map - (\(uid, _) -> - AuthSecretSubkeyUID - { authSecretSubkeyUIDValue = uid - , authSecretSubkeyUIDIsPrimary = Just uid == primaryUid - }) - (_tkuUIDs tk) + map + ( \(uid, _) -> + AuthSecretSubkeyUID + { authSecretSubkeyUIDValue = uid + , authSecretSubkeyUIDIsPrimary = Just uid == primaryUid + } + ) + (_tkuUIDs tk) where primaryUid = primaryUIDAt validationTime (_tkuUIDs tk) -primaryUIDAt :: UTCTime -> [(Text, [SignaturePayload])] -> Maybe Text +primaryUIDAt + :: UTCTime -> [(Text, [SignaturePayload])] -> Maybe Text primaryUIDAt validationTime uids = - snd <$> newestByCreationTime candidates + snd <$> newestByCreationTime candidates where candidates = - [ (createdAt, uid) - | (uid, sigs) <- uids - , cert <- maybeToList (latestEffectiveCertificationAt validationTime sigs) - , signatureMarksPrimaryUID cert - , createdAt <- maybeToList (signatureCreationTime cert) - ] + [ (createdAt, uid) + | (uid, sigs) <- uids + , cert <- + maybeToList (latestEffectiveCertificationAt validationTime sigs) + , signatureMarksPrimaryUID cert + , createdAt <- maybeToList (signatureCreationTime cert) + ] subkeyAuthCapableAt :: UTCTime -> [SignaturePayload] -> Bool subkeyAuthCapableAt validationTime sigs = - maybe False signatureHasAuthKeyFlag (latestEffectiveBindingSignatureAt validationTime sigs) + maybe + False + signatureHasAuthKeyFlag + (latestEffectiveBindingSignatureAt validationTime sigs) -latestEffectiveBindingSignatureAt :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload +latestEffectiveBindingSignatureAt + :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload latestEffectiveBindingSignatureAt validationTime sigs = - snd <$> - newestByCreationTime - [ (createdAt, sig) - | sig <- sigs - , isSubkeyBindingSig sig - , signatureEffectiveAt validationTime sig - , createdAt <- maybeToList (signatureCreationTime sig) - ] + snd + <$> newestByCreationTime + [ (createdAt, sig) + | sig <- sigs + , isSubkeyBindingSig sig + , signatureEffectiveAt validationTime sig + , createdAt <- maybeToList (signatureCreationTime sig) + ] -latestEffectiveCertificationAt :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload +latestEffectiveCertificationAt + :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload latestEffectiveCertificationAt validationTime sigs = - snd <$> - newestByCreationTime - [ (createdAt, sig) - | sig <- sigs - , isCertificationSig sig - , signatureEffectiveAt validationTime sig - , createdAt <- maybeToList (signatureCreationTime sig) - ] + snd + <$> newestByCreationTime + [ (createdAt, sig) + | sig <- sigs + , isCertificationSig sig + , signatureEffectiveAt validationTime sig + , createdAt <- maybeToList (signatureCreationTime sig) + ] signatureHasAuthKeyFlag :: SignaturePayload -> Bool signatureHasAuthKeyFlag sig = - Set.member AuthKey (signatureKeyFlags sig) + Set.member AuthKey (signatureKeyFlags sig) signatureKeyFlags :: SignaturePayload -> Set.Set KeyFlag signatureKeyFlags sig = - foldr - (\sp acc -> - case sp of - SigSubPacket _ (KeyFlags flags) -> Set.union flags acc - _ -> acc) - Set.empty - (maybe [] id (signatureHashedSubpacketsKnown sig)) + foldr + ( \sp acc -> + case sp of + SigSubPacket _ (KeyFlags flags) -> Set.union flags acc + _ -> acc + ) + Set.empty + (maybe [] id (signatureHashedSubpacketsKnown sig)) signatureMarksPrimaryUID :: SignaturePayload -> Bool signatureMarksPrimaryUID sig = - any - (\sp -> - case sp of - SigSubPacket _ (PrimaryUserId True) -> True - _ -> False) - (maybe [] id (signatureHashedSubpacketsKnown sig)) + any + ( \sp -> + case sp of + SigSubPacket _ (PrimaryUserId True) -> True + _ -> False + ) + (maybe [] id (signatureHashedSubpacketsKnown sig)) -conduitToTKsEither :: - Monad m => ConduitT Pkt (Either KeyringChunkParseError (Maybe TKUnknown)) m () +conduitToTKsEither + :: Monad m + => ConduitT + Pkt + (Either KeyringChunkParseError (Maybe TKUnknown)) + m + () conduitToTKsEither = conduitToTKsEither' True --- | Deprecated: this conduit silently drops parse failures and parse-time --- omissions. Prefer 'conduitToTKsDroppingEither' when tolerant parsing is --- needed, or 'conduitToTKsEither' for strict parsing. -conduitToTKsDropping :: Monad m => ConduitT Pkt TKUnknown m () -conduitToTKsDropping = - conduitToTKsDroppingEither .| - conduitDropErrorsAndNothings -{-# DEPRECATED conduitToTKsDropping "Use conduitToTKsDroppingEither or conduitToTKsEither and handle Left/Maybe explicitly." #-} - -conduitToTKsDroppingEither :: - Monad m => ConduitT Pkt (Either KeyringChunkParseError (Maybe TKUnknown)) m () +conduitToTKsDroppingEither + :: Monad m + => ConduitT + Pkt + (Either KeyringChunkParseError (Maybe TKUnknown)) + m + () conduitToTKsDroppingEither = conduitToTKsEither' False -conduitToTKsWithWireRep :: Monad m => ConduitT PktWithWireRep TKWithWireRep m () -conduitToTKsWithWireRep = - conduitToTKsWithWireRepEither .| - conduitDropErrorsAndNothings -{-# DEPRECATED conduitToTKsWithWireRep "Use conduitToTKsWithWireRepEither and handle Left/Maybe explicitly." #-} - -conduitToTKsWithWireRepEither :: - Monad m - => ConduitT - PktWithWireRep - (Either KeyringChunkParseError (Maybe TKWithWireRep)) - m - () +conduitToTKsWithWireRepEither + :: Monad m + => ConduitT + PktWithWireRep + (Either KeyringChunkParseError (Maybe TKWithWireRep)) + m + () conduitToTKsWithWireRepEither = conduitToTKsWithWireRepEither' True -conduitToTKsDroppingWithWireRep :: - Monad m => ConduitT PktWithWireRep TKWithWireRep m () -conduitToTKsDroppingWithWireRep = - conduitToTKsDroppingWithWireRepEither .| - conduitDropErrorsAndNothings -{-# DEPRECATED conduitToTKsDroppingWithWireRep "Use conduitToTKsDroppingWithWireRepEither or conduitToTKsWithWireRepEither and handle Left/Maybe explicitly." #-} - -conduitToTKsDroppingWithWireRepEither :: - Monad m - => ConduitT - PktWithWireRep - (Either KeyringChunkParseError (Maybe TKWithWireRep)) - m - () +conduitToTKsDroppingWithWireRepEither + :: Monad m + => ConduitT + PktWithWireRep + (Either KeyringChunkParseError (Maybe TKWithWireRep)) + m + () conduitToTKsDroppingWithWireRepEither = conduitToTKsWithWireRepEither' False -fakecmAccumEither :: - Monad m - => (accum -> Either e (accum, [b])) - -> (a -> accum -> Either e (accum, [b])) - -> accum - -> ConduitT a (Either e b) m () +fakecmAccumEither + :: Monad m + => (accum -> Either e (accum, [b])) + -> (a -> accum -> Either e (accum, [b])) + -> accum + -> ConduitT a (Either e b) m () fakecmAccumEither finalizer f initialAccum = loop initialAccum where loop accum = - await >>= - maybe - (case finalizer accum of - Left err -> yield (Left err) - Right (_, bs) -> mapM_ (yield . Right) bs) - go - where - go a = do - case f a accum of - Left err -> do - yield (Left err) - loop initialAccum - Right (accum', bs) -> do - mapM_ (yield . Right) bs - loop accum' + await + >>= maybe + ( case finalizer accum of + Left err -> yield (Left err) + Right (_, bs) -> mapM_ (yield . Right) bs + ) + go + where + go a = do + case f a accum of + Left err -> do + yield (Left err) + loop initialAccum + Right (accum', bs) -> do + mapM_ (yield . Right) bs + loop accum' -conduitDropErrorsAndNothings :: - Monad m => ConduitT (Either e (Maybe a)) a m () +conduitDropErrorsAndNothings + :: Monad m => ConduitT (Either e (Maybe a)) a m () conduitDropErrorsAndNothings = - CL.mapMaybe (either (const Nothing) id) + CL.mapMaybe (either (const Nothing) id) -conduitToTKsEither' :: - Monad m => Bool -> ConduitT Pkt (Either KeyringChunkParseError (Maybe TKUnknown)) m () +conduitToTKsEither' + :: Monad m + => Bool + -> ConduitT + Pkt + (Either KeyringChunkParseError (Maybe TKUnknown)) + m + () conduitToTKsEither' intolerant = - CL.filter notTrustPacket .| CL.map (: []) .| - fakecmAccumEither - finalizeParsingEither - (parseAChunkEither (anyTK intolerant)) - ([], Just (Nothing, anyTK intolerant)) + CL.filter notTrustPacket + .| CL.map (: []) + .| fakecmAccumEither + finalizeParsingEither + (parseAChunkEither (anyTK intolerant)) + ([], Just (Nothing, anyTK intolerant)) where notTrustPacket = not . isTrustPkt -conduitToTKsWithWireRepEither' :: - Monad m - => Bool - -> ConduitT - PktWithWireRep - (Either KeyringChunkParseError (Maybe TKWithWireRep)) - m - () +conduitToTKsWithWireRepEither' + :: Monad m + => Bool + -> ConduitT + PktWithWireRep + (Either KeyringChunkParseError (Maybe TKWithWireRep)) + m + () conduitToTKsWithWireRepEither' intolerant = - CL.filter notTrustPacket .| CL.map (: []) .| - fakecmAccumEither - finalizeParsingEither - (parseAChunkEither (anyTKWithWireRep intolerant)) - ([], Just (Nothing, anyTKWithWireRep intolerant)) + CL.filter notTrustPacket + .| CL.map (: []) + .| fakecmAccumEither + finalizeParsingEither + (parseAChunkEither (anyTKWithWireRep intolerant)) + ([], Just (Nothing, anyTKWithWireRep intolerant)) where notTrustPacket = not . isTrustPkt . _pktValue -sinkPublicKeyringMap :: Monad m => ConduitT (TK 'PublicTK) Void m PublicKeyring +sinkPublicKeyringMap + :: Monad m => ConduitT (TK 'PublicTK) Void m PublicKeyring sinkPublicKeyringMap = CL.fold (flip insert) empty -sinkSecretKeyringMap :: Monad m => ConduitT (TK 'SecretTK) Void m SecretKeyring +sinkSecretKeyringMap + :: Monad m => ConduitT (TK 'SecretTK) Void m SecretKeyring sinkSecretKeyringMap = CL.fold (flip insert) empty -- | Lift a single typed TK into its kinded keyring diff --git a/Data/Conduit/OpenPGP/Verify.hs b/Data/Conduit/OpenPGP/Verify.hs --- a/Data/Conduit/OpenPGP/Verify.hs +++ b/Data/Conduit/OpenPGP/Verify.hs @@ -2,98 +2,105 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} module Data.Conduit.OpenPGP.Verify - ( VerificationMode(..) - , VerificationModeW(..) - , conduitVerify - , verifyPacketsBatch - , verifyPacketsWithModeTyped - , verifyPacketsWithMode - ) where + ( VerificationMode (..) + , VerificationModeW (..) + , conduitVerify + , verifyPacketsBatch + , verifyPacketsWithModeTyped + , verifyPacketsWithMode + ) where import Data.Conduit +import qualified Data.Conduit.List as CL import Data.Time.Clock (UTCTime) -import Data.List (foldl') -import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), emptyPSC) +import Codec.Encryption.OpenPGP.Internal + ( PktStreamContext (..) + , emptyPSC + ) +import Codec.Encryption.OpenPGP.Policy + ( defaultVerificationPolicy + ) import Codec.Encryption.OpenPGP.Signatures - ( VerificationError(..) - , verifyAgainstKeyring - , verifySigWith - ) + ( VerificationError (..) + , verifyAgainstKeyring + , verifySigWith + ) import Codec.Encryption.OpenPGP.Types -import qualified Data.Conduit.List as CL data VerificationMode - = VerificationStreaming - | VerificationBatch - deriving (Eq, Show) + = VerificationStreaming + | VerificationBatch + deriving (Eq, Show) data VerificationModeW (mode :: VerificationMode) where - VerificationStreamingW :: VerificationModeW 'VerificationStreaming - VerificationBatchW :: VerificationModeW 'VerificationBatch + VerificationStreamingW + :: VerificationModeW 'VerificationStreaming + VerificationBatchW :: VerificationModeW 'VerificationBatch -conduitVerify :: - Monad m - => PublicKeyring - -> Maybe UTCTime - -> ConduitT Pkt (Either VerificationError Verification) m () +conduitVerify + :: Monad m + => PublicKeyring + -> Maybe UTCTime + -> ConduitT Pkt (Either VerificationError Verification) m () conduitVerify kr mt = - CL.concatMapAccum (\pkt state -> pushPacketTyped kr mt pkt state) emptyPSC + CL.concatMapAccum + (\pkt state -> pushPacketTyped kr mt pkt state) + emptyPSC -verifyPacketsBatch :: - PublicKeyring - -> Maybe UTCTime - -> [Pkt] - -> [Either VerificationError Verification] +verifyPacketsBatch + :: PublicKeyring + -> Maybe UTCTime + -> [Pkt] + -> [Either VerificationError Verification] verifyPacketsBatch kr mt = - verifyPacketsBatchTyped kr mt + verifyPacketsBatchTyped kr mt -verifyPacketsBatchTyped :: - PublicKeyring - -> Maybe UTCTime - -> [Pkt] - -> [Either VerificationError Verification] +verifyPacketsBatchTyped + :: PublicKeyring + -> Maybe UTCTime + -> [Pkt] + -> [Either VerificationError Verification] verifyPacketsBatchTyped kr mt = - reverse . snd . foldl' step (emptyPSC, []) + reverse . snd . foldl' step (emptyPSC, []) where step (state, outputs) pkt = - let (nextState, newOutputs) = pushPacketTyped kr mt pkt state - in (nextState, reverse newOutputs ++ outputs) + let (nextState, newOutputs) = pushPacketTyped kr mt pkt state + in (nextState, reverse newOutputs ++ outputs) -verifyPacketsWithMode :: - Monad m - => VerificationMode - -> PublicKeyring - -> Maybe UTCTime - -> ConduitT Pkt (Either VerificationError Verification) m () +verifyPacketsWithMode + :: Monad m + => VerificationMode + -> PublicKeyring + -> Maybe UTCTime + -> ConduitT Pkt (Either VerificationError Verification) m () verifyPacketsWithMode VerificationStreaming kr mt = - verifyPacketsWithModeTyped VerificationStreamingW kr mt + verifyPacketsWithModeTyped VerificationStreamingW kr mt verifyPacketsWithMode VerificationBatch kr mt = - verifyPacketsWithModeTyped VerificationBatchW kr mt + verifyPacketsWithModeTyped VerificationBatchW kr mt -verifyPacketsWithModeTyped :: - Monad m - => VerificationModeW mode - -> PublicKeyring - -> Maybe UTCTime - -> ConduitT Pkt (Either VerificationError Verification) m () +verifyPacketsWithModeTyped + :: Monad m + => VerificationModeW mode + -> PublicKeyring + -> Maybe UTCTime + -> ConduitT Pkt (Either VerificationError Verification) m () verifyPacketsWithModeTyped modeW kr mt = - case modeW of - VerificationStreamingW -> conduitVerify kr mt - VerificationBatchW -> CL.consume >>= mapM_ yield . verifyPacketsBatch kr mt + case modeW of + VerificationStreamingW -> conduitVerify kr mt + VerificationBatchW -> CL.consume >>= mapM_ yield . verifyPacketsBatch kr mt -pushPacketTyped :: - PublicKeyring - -> Maybe UTCTime - -> Pkt - -> PktStreamContext - -> (PktStreamContext, [Either VerificationError Verification]) +pushPacketTyped + :: PublicKeyring + -> Maybe UTCTime + -> Pkt + -> PktStreamContext + -> (PktStreamContext, [Either VerificationError Verification]) pushPacketTyped _ _ ld@LiteralDataPkt {} state = (state {lastLD = ld}, []) pushPacketTyped _ _ uid@(UserIdPkt _) state = (state {lastUIDorUAt = uid}, []) pushPacketTyped _ _ uat@(UserAttributePkt _) state = (state {lastUIDorUAt = uat}, []) @@ -102,37 +109,54 @@ pushPacketTyped _ _ sk@(SecretKeyPkt _ _) state = (state {lastPrimaryKey = sk}, []) pushPacketTyped _ _ sk@(SecretSubkeyPkt _ _) state = (state {lastSubkey = sk}, []) pushPacketTyped kr mt sig@(SignaturePkt signature) state = - case fromSignaturePayloadVerifiableSignatureV signature of - Just _ -> - ( state {lastSig = sig} - , [verifySigWith (verifyAgainstKeyring kr) sig state mt] - ) - Nothing -> (state, []) -pushPacketTyped _ _ (OtherPacketPkt t _) state | t < 40 = - (state, [Left (UnknownCriticalPacketInStream t)]) -pushPacketTyped _ _ (BrokenPacketPkt err t _) state | t < 40 = - (state, [Left (BrokenCriticalPacketInStream t err)]) + case fromSignaturePayloadVerifiableSignatureV signature of + Just _ -> + ( state {lastSig = sig} + , + [ verifySigWith + defaultVerificationPolicy + (verifyAgainstKeyring kr) + sig + state + mt + ] + ) + Nothing -> (state, []) +pushPacketTyped _ _ (OtherPacketPkt t _) state + | t < 40 = + (state, [Left (UnknownCriticalPacketInStream t)]) +pushPacketTyped _ _ (BrokenPacketPkt err t _) state + | t < 40 = + (state, [Left (BrokenCriticalPacketInStream t err)]) pushPacketTyped _ _ pkt@(OnePassSignaturePkt _) state - | isOpeningOnePassSignature pkt = (state, []) + | isOpeningOnePassSignature pkt = (state, []) pushPacketTyped _ _ _ state = (state, []) data VerifiableSignatureV where - VerifiableSignatureV4 :: SignaturePayloadV 'SigPayloadV4 -> VerifiableSignatureV - VerifiableSignatureV6 :: SignaturePayloadV 'SigPayloadV6 -> VerifiableSignatureV + VerifiableSignatureV4 + :: SignaturePayloadV 'SigPayloadV4 -> VerifiableSignatureV + VerifiableSignatureV6 + :: SignaturePayloadV 'SigPayloadV6 -> VerifiableSignatureV -fromSignaturePayloadVerifiableSignatureV :: - SignaturePayload -> Maybe VerifiableSignatureV +fromSignaturePayloadVerifiableSignatureV + :: SignaturePayload -> Maybe VerifiableSignatureV fromSignaturePayloadVerifiableSignatureV sigPayload = - case toSomeSignaturePayload sigPayload of - SomeSignaturePayload (payload@SigPayloadV4Data {}) -> - Just (VerifiableSignatureV4 payload) - SomeSignaturePayload (payload@SigPayloadV6Data {}) -> - Just (VerifiableSignatureV6 payload) - _ -> Nothing + case toSomeSignaturePayload sigPayload of + SomeSignaturePayload (payload@SigPayloadV4Data {}) -> + Just (VerifiableSignatureV4 payload) + SomeSignaturePayload (payload@SigPayloadV6Data {}) -> + Just (VerifiableSignatureV6 payload) + _ -> Nothing isOpeningOnePassSignature :: Pkt -> Bool -isOpeningOnePassSignature (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 _ _ _ _ _ False))) = - True -isOpeningOnePassSignature (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 _ _ _ _ _ False))) = - True +isOpeningOnePassSignature + ( OnePassSignaturePkt + (OPSPayloadV3Packet (OPSPayloadV3 _ _ _ _ _ False)) + ) = + True +isOpeningOnePassSignature + ( OnePassSignaturePkt + (OPSPayloadV6Packet (OPSPayloadV6 _ _ _ _ _ False)) + ) = + True isOpeningOnePassSignature _ = False diff --git a/bench/mark.hs b/bench/mark.hs --- a/bench/mark.hs +++ b/bench/mark.hs @@ -2,105 +2,124 @@ -- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - {-# LANGUAGE FlexibleContexts #-} import Criterion.Main - -import Codec.Encryption.OpenPGP.Serialize - ( conduitParsePktsWithWireRep - , parsePkts - , parsePktsEither - , parsePktsWithWireRep - ) -import Codec.Encryption.OpenPGP.Signatures - ( verifyAgainstKeyring - , verifyAgainstKeys - , verifySigWith - , verifyTKWith - , verifyUnknownTKWith - ) -import Codec.Encryption.OpenPGP.Types - ( someTKToPublicViewTK - , wireRepRef - ) - import Data.Binary (get) -import Data.Conduit.OpenPGP.Keyring - ( conduitToSomeTKsEither - , conduitToTKsEither - ) -import Data.Conduit.Serialization.Binary (conduitGet) -import qualified Data.IxSet.Typed as IxSet import qualified Data.ByteString.Lazy as BL -import Data.Either (rights) -import Data.Maybe (catMaybes) - import qualified Data.Conduit as DC import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.Either (rights) +import qualified Data.IxSet.Typed as IxSet +import Data.Maybe (catMaybes) +import Codec.Encryption.OpenPGP.Policy + ( defaultVerificationPolicy + ) +import Codec.Encryption.OpenPGP.Serialize + ( conduitParsePktsWithWireRep + , parsePkts + , parsePktsEither + , parsePktsWithWireRep + ) +import Codec.Encryption.OpenPGP.Signatures + ( verifyAgainstKeyring + , verifyAgainstKeys + , verifySigWith + , verifyTKWith + , verifyUnknownTKWith + ) +import Codec.Encryption.OpenPGP.Types + ( someTKToPublicViewTK + , wireRepRef + ) +import Data.Conduit.OpenPGP.Keyring + ( conduitToSomeTKsEither + , conduitToTKsEither + ) + main :: IO () main = - defaultMain - [ bgroup - "keyring" - [ bench "load keys" $ whnfIO (loadKeys "tests/data/pubring.gpg") - , bench "load keyring" $ whnfIO (loadKeyring "tests/data/pubring.gpg") - , bench "self-verify keys" $ - whnfIO (selfVerifyKeys "tests/data/pubring.gpg") - , bench "self-verify keyring" $ - whnfIO (selfVerifyKeyring "tests/data/pubring.gpg") + defaultMain + [ bgroup + "keyring" + [ bench "load keys" $ whnfIO (loadKeys "tests/data/pubring.gpg") + , bench "load keyring" $ + whnfIO (loadKeyring "tests/data/pubring.gpg") + , bench "self-verify keys" $ + whnfIO (selfVerifyKeys "tests/data/pubring.gpg") + , bench "self-verify keyring" $ + whnfIO (selfVerifyKeyring "tests/data/pubring.gpg") + ] + , env (BL.readFile "tests/data/pubring.gpg") $ \pubringPayload -> + let pubringRef = wireRepRef pubringPayload + in bgroup + "packet-parse" + [ bench "parsePkts/count" $ nf (length . parsePkts) pubringPayload + , bench "parsePktsEither/count" $ + nf + (either (const 0) length . parsePktsEither) + pubringPayload + , bench "parsePktsWithWireRep/count" $ + nf + (length . parsePktsWithWireRep pubringRef) + pubringPayload + , bench "conduitParsePktsWithWireRep/count" $ + whnfIO + ( fmap + length + ( DC.runConduitRes $ + CB.sourceLbs pubringPayload + DC..| conduitParsePktsWithWireRep Nothing + DC..| CL.consume + ) + ) + ] ] - , env (BL.readFile "tests/data/pubring.gpg") $ \pubringPayload -> - let pubringRef = wireRepRef pubringPayload - in - bgroup - "packet-parse" - [ bench "parsePkts/count" $ nf (length . parsePkts) pubringPayload - , bench "parsePktsEither/count" $ - nf - (either (const 0) length . parsePktsEither) - pubringPayload - , bench "parsePktsWithWireRep/count" $ - nf - (length . parsePktsWithWireRep pubringRef) - pubringPayload - , bench "conduitParsePktsWithWireRep/count" $ - whnfIO - (fmap - length - (DC.runConduitRes $ - CB.sourceLbs pubringPayload DC..| conduitParsePktsWithWireRep Nothing DC..| - CL.consume)) - ] - ] where loadKeys fp = - fmap - (catMaybes . rights) - (DC.runConduitRes $ - CB.sourceFile fp DC..| conduitGet get DC..| conduitToTKsEither DC..| - CL.consume) + fmap + (catMaybes . rights) + ( DC.runConduitRes $ + CB.sourceFile fp + DC..| conduitGet get + DC..| conduitToTKsEither + DC..| CL.consume + ) loadKeyring fp = - fmap - (sinkFromSomeTKs . rights) - (DC.runConduitRes $ - CB.sourceFile fp DC..| conduitGet get DC..| conduitToSomeTKsEither DC..| - CL.consume) + fmap + (sinkFromSomeTKs . rights) + ( DC.runConduitRes $ + CB.sourceFile fp + DC..| conduitGet get + DC..| conduitToSomeTKsEither + DC..| CL.consume + ) selfVerifyKeys fp = - fmap - (\ks -> - mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks) - (loadKeys fp) + fmap + ( \ks -> + mapM + ( verifyUnknownTKWith + (verifySigWith defaultVerificationPolicy (verifyAgainstKeys ks)) + Nothing + ) + ks + ) + (loadKeys fp) selfVerifyKeyring fp = - fmap - (\kr -> - mapM - (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) Nothing) - (IxSet.toList kr)) - (loadKeyring fp) + fmap + ( \kr -> + mapM + ( verifyTKWith + (verifySigWith defaultVerificationPolicy (verifyAgainstKeyring kr)) + Nothing + ) + (IxSet.toList kr) + ) + (loadKeyring fp) sinkFromSomeTKs = - IxSet.fromList . - map someTKToPublicViewTK . - catMaybes + IxSet.fromList + . map someTKToPublicViewTK + . catMaybes diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP -Version: 3.0.2.2 +Version: 3.1 Synopsis: native Haskell implementation of OpenPGP (RFC9580) Description: native Haskell implementation of OpenPGP (RFC9580), with some backwards compatibility Homepage: https://salsa.debian.org/clint/hOpenPGP @@ -332,4 +332,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git - tag: v3.0.2.2 + tag: v3.1 diff --git a/tests/Tests/Common.hs b/tests/Tests/Common.hs --- a/tests/Tests/Common.hs +++ b/tests/Tests/Common.hs @@ -2,1537 +2,1927 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TypeApplications #-} - -module Tests.Common - ( addTimestampSeconds - , armorPayload - , assertFalse - , assertTrue - , collectSecretKeyInfos - , conduitDecryptWithPKESKContext - , loadArmor - , loadAndDecompressPkts - , loadSEIPDv2FixtureWithV4Secret - , loadUnencryptedRsaSigner - , loadV4EncryptedSecretKeyFixtureForProperty - , loadV6UnencryptedSecretKeyFixtureForProperty - , prependUnusableLatestPKESK - , readFixtureLazy - , readFixturePackets - , readFixturePayload - , reorderPrecedingPKESKs - , reverseIf - , runGet -- FIXME: this is confusing - , selectRecipientKeyInfo - , setKeyTimestamp - , signCertificationAt - , signSubkeyBindingWithRSAExtrasAt - , signSubkeyRevocationWithRSAAt - , timestampToUTCTime - , assertSingleFailureContainsTimeline - , assertSingleSignerFingerprint - , encryptMessageDefault - , expectV4PKPayload - , expectV6PKPayload - , extractV4SignatureAlgorithmFields - , fp - , loadKeyring - , loadDeterministicEd25519Signer - , loadDeterministicEd25519SignerV6 - , loadDeterministicEd448Signer - , loadDeterministicEd448SignerV6 - , loadUnencryptedRsaSignerV6 - , messageIssuerSubpacketsAt - , mkTestKeyring - , setPKAlgorithm - , signBinaryMessageWithRSAAt - , signBinaryMessageWithEd25519At - , signKeyRevocationWithReasonAt - , signKeyRevocationWithReasonAndExtrasAt - , signSubkeyBindingWithRSAAt - , verifyTimelinePackets - , signCertificationRevocationWithEd25519At - , signCertificationWithEd25519At - , verificationFixtureGroup - , verifyMessageFromBytestring - , verifyMessageFromBytestringBatch - , verifyMessageFromPackets - , verifyMessageFromPacketsBatch - , certificateVerificationFixtures - , fixturePath - , messageVerificationFixtures - , readPKIPassphrase - , setKeyVersion - , signCertificationRevocationAt - , aesKeyWrapRFC3394ForTest - , assertX25519EskShape - , assertX448EskShape - , buildCurve25519LegacyKdfParamForTest - , buildECDHKDFParamForTest - , cgp - , conduitDecrypt -- FIXME: this is confusing - , conduitDecryptChecked - , conduitDecryptCheckedWithDecryptPolicy - , conduitDecryptWithCandidatesCallbackAndPolicy - , conduitDecryptWithDecryptPolicy - , deriveECDHKekForTest - , deriveX25519KekForTest - , deriveX448KekForTest - , doPkeyAndSkeyMatch - , encodeChecksum16 - , forceVersionedRecipientIdentifier - , isPrecedingESK - , mkPKESKSessionMaterialOrFail - , readFixtureStrict - , selectRecipientKeyInfoByRawRecipientId - , signDirectKeyWithRSAExtrasAt - , testEncodeOpenPGPSessionMaterial - , testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized - , testSEIPDv2ForV4KeyArmor - , testSEIPDv2TwoRecipientsArmor - , testSEIPDv2ThreeRecipientsArmor - ) -where - -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) - -import Codec.Encryption.OpenPGP.Arbitrary () -import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA -import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..)) -import Codec.Encryption.OpenPGP.Compression (decompressPkt) -import Codec.Encryption.OpenPGP.Encrypt - ( PKESKSessionMaterial - , mkPKESKSessionMaterial - , encodeOpenPGPSessionMaterial - ) - -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) -import Codec.Encryption.OpenPGP.Internal - ( curveFromCurve - , curveToCurveoidBS - , emptyPSC - , lastPrimaryKey - , lastUIDorUAt - , lastSubkey - ) -import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint) -import Codec.Encryption.OpenPGP.Message - ( asV4PKPayload - , asV6PKPayload - , ClearPayload - , EncryptedPayload - , encryptMessage - , EncryptMessageOptions(..) - , Passphrase - , MessageError(..) - , RecoveredSessionMaterial(..) - , SessionMaterialExposure(..) - , VersionedPKPayload - ) -import Codec.Encryption.OpenPGP.SecretKey - ( decryptPrivateKey - ) -import Codec.Encryption.OpenPGP.Serialize - ( dearmorIfAsciiArmored - , parsePkts - ) -import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig) -import Codec.Encryption.OpenPGP.Signatures - ( VerificationError(..) - , renderVerificationError - , renderSignError - , signCertificationWithRSA - , signCertRevocationWithRSA - , signSubkeyRevocationWithRSA - , signDataWithRSA - , signDataWithEd25519 - , signDirectKeyWithRSA - , signKeyRevocationWithRSA - ) -import Codec.Encryption.OpenPGP.Types -import Control.Monad (unless, void) -import qualified "crypton" Crypto.Cipher.AES as AES -import qualified "crypton" Crypto.Cipher.Types as CCT -import qualified Crypto.Error as CE -import qualified Crypto.Hash as CH -import qualified Crypto.Hash.Algorithms as CHA -import Crypto.KDF.HKDF (expand, extract) -import qualified Crypto.PubKey.Ed25519 as Ed25519 -import qualified Crypto.PubKey.Ed448 as Ed448 -import qualified Crypto.PubKey.RSA.PKCS15 as P15 -import Control.Monad.Trans.Resource (ResourceT) -import Crypto.Number.Serialize (os2ip) -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.RSA as RSA -import qualified Data.ByteArray as BA -import Data.Bifunctor (bimap, first) -import Data.Binary (get) -import Data.Binary.Get - ( Get - , getLazyByteString - , getRemainingLazyByteString - , getWord16be - , getWord8 - , runGetOrFail - ) -import Data.Binary.Put (putWord64be, runPut) -import Data.Bits (xor) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BLC8 -import qualified Data.ByteString.Base16.Lazy as B16L -import Data.Char (toUpper) -import Data.Conduit.OpenPGP.Compression (conduitDecompress) -import Data.Conduit.OpenPGP.Decrypt - ( DecryptKeyResolution(..) - , DecryptOptions(..) - , PKESKRecipientKey(..) - , DecryptOutcome(..) - ) -import qualified Data.Conduit.OpenPGP.Decrypt as DCD -import Codec.Encryption.OpenPGP.Policy - ( DecryptPolicy - , defaultDecryptPolicy - ) -import Data.Conduit.OpenPGP.Keyring - ( conduitToPublicViewTKs - , sinkPublicKeyringMap - , partitionSomeTKs - ) -import Data.Conduit.OpenPGP.Message - ( VerificationOptions(..) - , VerificationPolicy(..) - , defaultVerificationOptions - , VerificationMode(..) - , verifyMessage - , verifyMessagePackets - ) -import Data.Conduit.Serialization.Binary (conduitGet) -import Data.List (isInfixOf) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (catMaybes, listToMaybe) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.Word (Word32, Word64) - -import qualified Data.Conduit as DC -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL - -import qualified Crypto.PubKey.ECC.Types as ECCT - --- Test assertion helpers -assertTrue :: String -> Bool -> Assertion -assertTrue msg b = assertBool msg b - -assertFalse :: String -> Bool -> Assertion -assertFalse msg b = assertBool msg (not b) - -fixturePath :: FilePath -> FilePath -fixturePath file = "tests/data/" ++ file - -readFixtureLazy :: FilePath -> IO BL.ByteString -readFixtureLazy = BL.readFile . fixturePath - -readFixtureStrict :: FilePath -> IO B.ByteString -readFixtureStrict = B.readFile . fixturePath - -readFixturePackets :: FilePath -> IO [Pkt] -readFixturePackets file = - DC.runConduitRes $ CB.sourceFile (fixturePath file) DC..| conduitGet get DC..| CL.consume - -readFixtureDecompressedPackets :: FilePath -> IO [Pkt] -readFixtureDecompressedPackets file = - DC.runConduitRes $ - CB.sourceFile (fixturePath file) DC..| conduitGet get DC..| conduitDecompress DC..| CL.consume - -loadFirstArmor :: FilePath -> IO Armor -loadFirstArmor file = do - armors <- loadArmor file - case armors of - (a:_) -> pure a - [] -> assertFailure (file ++ " armor file contained no armor blocks") >> fail "expected armor block" - -readPKIPassphrase :: IO BL.ByteString -readPKIPassphrase = readFixtureLazy "pki-password.txt" - --- this needs a better name -runGet :: Get a -> BL.ByteString -> Either String a -runGet g bs = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail g bs) - -extractV4SignatureAlgorithmFields :: - BL.ByteString -> Either String (PubKeyAlgorithm, B.ByteString) -extractV4SignatureAlgorithmFields = - runGet $ do - version <- getWord8 - if version /= 4 - then fail ("expected v4 signature payload, got version " ++ show version) - else do - _ <- getWord8 -- sig type - pka <- getWord8 - _ <- getWord8 -- hash algo - hlen <- getWord16be - _ <- getLazyByteString (fromIntegral hlen) - ulen <- getWord16be - _ <- getLazyByteString (fromIntegral ulen) - _ <- getWord16be -- left16 - algorithmFields <- getRemainingLazyByteString - pure (toFVal pka, BL.toStrict algorithmFields) - -conduitDecrypt :: - (String -> IO BL.ByteString) - -> DC.ConduitT Pkt Pkt (ResourceT IO) () -conduitDecrypt cb = - void $ - DCD.conduitDecrypt - DecryptOptions - { decryptOptionsKeyResolution = DecryptWithoutPKESK - , decryptOptionsPolicy = defaultDecryptPolicy - , decryptOptionsPassphraseCallback = cb - } - -conduitDecryptWithPKESKContext :: - (Pkt -> IO (Maybe PKESKRecipientKey)) - -> (String -> IO BL.ByteString) - -> DC.ConduitT Pkt Pkt (ResourceT IO) () -conduitDecryptWithPKESKContext pkcb cb = - void $ - DCD.conduitDecrypt - DecryptOptions - { decryptOptionsKeyResolution = DecryptWithUnwrapCandidatesCallback (asPKESKUnwrapCandidatesCallback pkcb) - , decryptOptionsPolicy = defaultDecryptPolicy - , decryptOptionsPassphraseCallback = cb - } - -conduitDecryptWithDecryptPolicy :: - DecryptPolicy - -> (Pkt -> IO (Maybe PKESKRecipientKey)) - -> (String -> IO BL.ByteString) - -> DC.ConduitT Pkt Pkt (ResourceT IO) () -conduitDecryptWithDecryptPolicy dp pkcb cb = - void $ - DCD.conduitDecrypt - DecryptOptions - { decryptOptionsKeyResolution = DecryptWithUnwrapCandidatesCallback (asPKESKUnwrapCandidatesCallback pkcb) - , decryptOptionsPolicy = dp - , decryptOptionsPassphraseCallback = cb - } - -conduitDecryptChecked :: - (String -> IO BL.ByteString) - -> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome -conduitDecryptChecked cb = - DCD.conduitDecrypt - DecryptOptions - { decryptOptionsKeyResolution = DecryptWithoutPKESK - , decryptOptionsPolicy = defaultDecryptPolicy - , decryptOptionsPassphraseCallback = cb - } - -conduitDecryptCheckedWithDecryptPolicy :: - DecryptPolicy - -> (Pkt -> IO (Maybe PKESKRecipientKey)) - -> (String -> IO BL.ByteString) - -> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome -conduitDecryptCheckedWithDecryptPolicy dp pkcb cb = - DCD.conduitDecrypt - DecryptOptions - { decryptOptionsKeyResolution = DecryptWithUnwrapCandidatesCallback (asPKESKUnwrapCandidatesCallback pkcb) - , decryptOptionsPolicy = dp - , decryptOptionsPassphraseCallback = cb - } - -conduitDecryptWithCandidatesCallbackAndPolicy :: - DecryptPolicy - -> (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]) - -> (String -> IO BL.ByteString) - -> DC.ConduitT Pkt Pkt (ResourceT IO) () -conduitDecryptWithCandidatesCallbackAndPolicy dp candCb cb = - void $ - DCD.conduitDecrypt - DecryptOptions - { decryptOptionsKeyResolution = DecryptWithUnwrapCandidatesCallback candCb - , decryptOptionsPolicy = dp - , decryptOptionsPassphraseCallback = cb - } - -asPKESKUnwrapCandidatesCallback :: - (Pkt -> IO (Maybe PKESKRecipientKey)) - -> KeyIdentifier - -> PubKeyAlgorithm - -> IO [PKESKRecipientKey] -asPKESKUnwrapCandidatesCallback pkcb keyIdentifier pka = do - mk <- pkcb (pkeskProbePacket keyIdentifier pka) - pure (maybe [] (: []) mk) - -pkeskProbePacket :: KeyIdentifier -> PubKeyAlgorithm -> Pkt -pkeskProbePacket keyIdentifier pka = - case keyIdentifier of - KeyIdentifierWildcard -> - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 3 (EightOctetKeyId (BL.replicate 8 0)) pka (MPI 0 :| []))) - KeyIdentifierEightOctet rid -> - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 3 rid pka (MPI 0 :| []))) - KeyIdentifierFingerprint rid -> - PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 (unFingerprint rid) pka mempty)) - -readFixturePayload :: FilePath -> IO BL.ByteString -readFixturePayload fpr = do - bs <- BL.readFile ("tests/data/" ++ fpr) - case dearmorIfAsciiArmored bs of - Left err -> assertFailure ("ASCII armor decode failed for " ++ fpr ++ ": " ++ err) >> pure mempty - Right (_, payload) -> pure payload - -testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized :: Assertion -testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized = do - secretPackets <- - DC.runConduitRes $ - CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| CL.consume - (publicKey, privateKey) <- - case secretPackets of - (SecretKeyPkt pkp ska:_) -> - case (_pubkey pkp, ska) of - (RSAPubKey (RSA_PublicKey pub), SUUnencrypted (RSAPrivateKey (RSA_PrivateKey prv)) _) -> - pure (pub, prv) - _ -> - assertFailure "unencrypted.seckey did not contain a parseable unencrypted RSA key pair" >> - fail "expected RSA key pair from parsed secret key packet" - _ -> - assertFailure "unencrypted.seckey did not begin with a secret key packet" >> - fail "expected secret key packet" - let plaintext = "pkcs1-v1.5 regression payload" :: B.ByteString - encrypted <- (P15.encrypt publicKey plaintext :: IO (Either RSA.Error B.ByteString)) - ciphertext <- - case encrypted of - Left err -> - assertFailure ("RSA PKCS#1 v1.5 encryption failed: " ++ show err) >> pure mempty - Right ct -> pure ct - decrypted <- (P15.decryptSafer privateKey ciphertext :: IO (Either RSA.Error B.ByteString)) - case decrypted of - Left RSA.MessageNotRecognized -> - assertFailure "parsed RSA private key decryption failed with MessageNotRecognized" - Left err -> - assertFailure ("parsed RSA private key decryption failed: " ++ show err) - Right got -> - assertEqual - "parsed RSA private key decrypts PKCS#1 v1.5 payload" - plaintext - got - -testEncodeOpenPGPSessionMaterial :: Assertion -testEncodeOpenPGPSessionMaterial = do - let keyBytes = B.pack [1 .. 32] - expected = - B.singleton (fromFVal AES256) <> keyBytes <> encodeChecksum16 keyBytes - case encodeOpenPGPSessionMaterial AES256 (SessionKey keyBytes) of - Left err -> - assertFailure ("encodeOpenPGPSessionMaterial failed: " ++ show err) - Right encoded -> - assertEqual "OpenPGP session material encoding" expected encoded - -mkPKESKSessionMaterialOrFail :: - SymmetricAlgorithm -> SessionKey -> IO PKESKSessionMaterial -mkPKESKSessionMaterialOrFail symalgo sessionKey = - case mkPKESKSessionMaterial symalgo sessionKey of - Left err -> - assertFailure ("mkPKESKSessionMaterial failed: " ++ show err) >> - fail "mkPKESKSessionMaterial failed" - Right material -> pure material - -armorPayload :: Armor -> BL.ByteString -armorPayload (Armor _ _ bs) = BL.fromStrict (BLC8.toStrict bs) -armorPayload (ClearSigned _ _ inner) = armorPayload inner - -selectRecipientKeyInfo :: Pkt -> [PKESKRecipientKey] -> Maybe PKESKRecipientKey -selectRecipientKeyInfo (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) keyInfos = - listToMaybe - [ keyInfo - | keyInfo <- keyInfos - , supportsPKESKAlgorithm pka keyInfo - , matchesRecipientIdentifier rid keyInfo - ] -selectRecipientKeyInfo _ keyInfos = listToMaybe keyInfos - -supportsPKESKAlgorithm :: PubKeyAlgorithm -> PKESKRecipientKey -> Bool -supportsPKESKAlgorithm pka keyInfo = - case pkeskRecipientSKey keyInfo of - RSAPrivateKey {} -> pka == RSA - ECDHPrivateKey {} -> pka == ECDH || pka == X25519 - X25519PrivateKey {} -> pka == X25519 - X448PrivateKey {} -> pka == X448 - _ -> False - -matchesRecipientIdentifier :: BL.ByteString -> PKESKRecipientKey -> Bool -matchesRecipientIdentifier rid keyInfo = - case pkeskRecipientPKPayload keyInfo of - Nothing -> False - Just pkp -> - let fingerprintBytes = BL.toStrict (unFingerprint (fingerprint pkp)) - identifier = BL.toStrict rid - in identifier == fingerprintBytes || - identifier == B.cons 0x04 fingerprintBytes || - identifier == B.cons 0x06 fingerprintBytes - -buildECDHKDFParamForTest :: - SomePKPayload - -> PubKeyAlgorithm - -> ECCT.Curve - -> HashAlgorithm - -> SymmetricAlgorithm - -> B.ByteString -buildECDHKDFParamForTest recipientPKP pka curve kdfHA kdfSA = - B.singleton (fromIntegral (B.length curveOid)) <> curveOid <> - B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA] <> - "Anonymous Sender " <> - BL.toStrict (unFingerprint (fingerprint recipientPKP)) - where - curveOid = either (const B.empty) id (curveToCurveoidBS (curveFromCurve curve)) - -buildCurve25519LegacyKdfParamForTest :: - SomePKPayload - -> PubKeyAlgorithm - -> HashAlgorithm - -> SymmetricAlgorithm - -> B.ByteString -buildCurve25519LegacyKdfParamForTest recipientPKP pka kdfHA kdfSA = - B.singleton (fromIntegral (B.length curveOid)) <> curveOid <> - B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA] <> - "Anonymous Sender " <> - BL.toStrict (unFingerprint (fingerprint recipientPKP)) - where - curveOid = "\x2b\x06\x01\x04\x01\x97\x55\x01\x05\x01" - -deriveECDHKekForTest :: - HashAlgorithm - -> SymmetricAlgorithm - -> B.ByteString - -> B.ByteString - -> B.ByteString -deriveECDHKekForTest kdfHA kdfSA sharedSecret kdfParam = - B.take (keyLengthForTest kdfSA) digest - where - digest = - case kdfHA of - SHA256 -> BA.convert (CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) :: CH.Digest CHA.SHA256) - SHA384 -> BA.convert (CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) :: CH.Digest CHA.SHA384) - SHA512 -> BA.convert (CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) :: CH.Digest CHA.SHA512) - _ -> BA.convert (CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) :: CH.Digest CHA.SHA256) - -deriveX448KekForTest :: - B.ByteString - -> B.ByteString - -> B.ByteString - -> B.ByteString -deriveX448KekForTest ephemeralPublic recipientPublic sharedSecret = - let ikm = ephemeralPublic <> recipientPublic <> sharedSecret - prk = extract @CHA.SHA512 B.empty ikm - info = "OpenPGP X448" :: B.ByteString - in expand @CHA.SHA512 prk info 32 - -deriveX25519KekForTest :: - B.ByteString - -> B.ByteString - -> B.ByteString - -> B.ByteString -deriveX25519KekForTest ephemeralPublic recipientPublic sharedSecret = - let ikm = ephemeralPublic <> recipientPublic <> sharedSecret - prk = extract @CHA.SHA256 B.empty ikm - info = "OpenPGP X25519" :: B.ByteString - in expand @CHA.SHA256 prk info 16 - -keyLengthForTest :: SymmetricAlgorithm -> Int -keyLengthForTest AES128 = 16 -keyLengthForTest AES192 = 24 -keyLengthForTest AES256 = 32 -keyLengthForTest _ = 16 - -aesKeyWrapRFC3394ForTest :: - SymmetricAlgorithm -> B.ByteString -> B.ByteString -> B.ByteString -aesKeyWrapRFC3394ForTest sa kek plain = - case sa of - AES128 -> wrapWithCipher (initCipher kek :: AES.AES128) plain - AES192 -> wrapWithCipher (initCipher kek :: AES.AES192) plain - AES256 -> wrapWithCipher (initCipher kek :: AES.AES256) plain - _ -> error "unsupported KEK algorithm in test" - where - initCipher keyBytes = - case CE.eitherCryptoError (CCT.cipherInit keyBytes) of - Left err -> error ("cipher init failed: " ++ show err) - Right c -> c - wrapWithCipher cipher plainBytes = - let rs = chunksOf8ForTest plainBytes - n = length rs - a0 = B.replicate 8 0xA6 - (aFinal, rFinal) = foldl (\(a, r) j -> wrapRound cipher n j a r) (a0, rs) [0 .. 5] - in aFinal <> B.concat rFinal - wrapRound cipher n j a rs = foldl step (a, rs) [1 .. n] - where - step (aCurr, rCurr) i = - let b = CCT.ecbEncrypt cipher (aCurr <> (rCurr !! (i - 1))) - (aMsb, rLsb) = B.splitAt 8 b - t = fromIntegral (n * j + i) :: Word64 - aNext = xorBSForTest aMsb (encodeWord64beForTest t) - in (aNext, replaceAtForTest (i - 1) rLsb rCurr) - -encodeWord64beForTest :: Word64 -> B.ByteString -encodeWord64beForTest = BL.toStrict . runPut . putWord64be - -chunksOf8ForTest :: B.ByteString -> [B.ByteString] -chunksOf8ForTest bs - | B.null bs = [] - | otherwise = - let (h, t) = B.splitAt 8 bs - in h : chunksOf8ForTest t - -replaceAtForTest :: Int -> a -> [a] -> [a] -replaceAtForTest idx x xs = - let (prefix, suffix) = splitAt idx xs - in case suffix of - [] -> xs - (_:rest) -> prefix <> (x : rest) - -xorBSForTest :: B.ByteString -> B.ByteString -> B.ByteString -xorBSForTest a b = B.pack (B.zipWith xor a b) - -encodeChecksum16 :: B.ByteString -> B.ByteString -encodeChecksum16 bs = - B.pack - [fromIntegral (s `div` 256), fromIntegral (s `mod` 256)] - where - s = B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Int)) 0 bs - -verifyMessageFromPackets :: PublicKeyring -> BL.ByteString -> [Either String Verification] -verifyMessageFromPackets keyring signedMessage = - map (either (Left . renderVerificationError) Right) $ - verifyMessagePackets - defaultVerificationOptions - { verificationPolicy = VerifyInformational - , verificationMode = VerificationStreaming - } - keyring - (concatMap (either (const []) id . decompressPkt) (parsePkts signedMessage)) - -verifyMessageFromPacketsBatch :: PublicKeyring -> BL.ByteString -> [Either String Verification] -verifyMessageFromPacketsBatch keyring signedMessage = - map (either (Left . renderVerificationError) Right) $ - verifyMessagePackets - defaultVerificationOptions - { verificationPolicy = VerifyInformational - , verificationMode = VerificationBatch - } - keyring - (concatMap (either (const []) id . decompressPkt) (parsePkts signedMessage)) - -verifyMessageFromBytestring :: PublicKeyring -> BL.ByteString -> [Either String Verification] -verifyMessageFromBytestring keyring signedMessage = - map (either (Left . renderVerificationError) Right) $ - verifyMessage - defaultVerificationOptions - { verificationPolicy = VerifyInformational - , verificationMode = VerificationStreaming - } - keyring - signedMessage - -verifyMessageFromBytestringBatch :: PublicKeyring -> BL.ByteString -> [Either String Verification] -verifyMessageFromBytestringBatch keyring signedMessage = - map (either (Left . renderVerificationError) Right) $ - verifyMessage - defaultVerificationOptions - { verificationPolicy = VerifyInformational - , verificationMode = VerificationBatch - } - keyring - signedMessage - -assertMessageVerification :: - (PublicKeyring -> BL.ByteString -> [Either String Verification]) - -> FilePath - -> FilePath - -> [Fingerprint] - -> Assertion -assertMessageVerification verifier keyringFile messageFile issuers = do - kr <- loadKeyring keyringFile - signedMessage <- readFixtureLazy messageFile - let verification = verifier kr signedMessage - actual = map (fmap (fingerprint . _verificationSigner)) verification - assertEqual - (keyringFile ++ " for " ++ messageFile) - (map Right issuers) - actual - -loadKeyring :: FilePath -> IO PublicKeyring -loadKeyring keyring = - DC.runConduitRes $ - CB.sourceFile (fixturePath keyring) DC..| conduitGet get DC..| conduitToPublicViewTKs DC..| - sinkPublicKeyringMap - -loadAndDecompressPkts :: FilePath -> IO [Pkt] -loadAndDecompressPkts = readFixtureDecompressedPackets - -loadArmor :: FilePath -> IO [Armor] -loadArmor file = do - armored <- readFixtureLazy file - case AA.decodeLazy armored :: Either String [Armor] of - Left err -> - assertFailure ("Failed to decode armored fixture " ++ file ++ ": " ++ err) >> pure [] - Right armors -> pure armors - -encryptMessageDefault :: - SessionMaterialExposure - -> Passphrase - -> ClearPayload - -> Either - MessageError - (EncryptedPayload, Maybe RecoveredSessionMaterial) -encryptMessageDefault exposure passphrase payload = - encryptMessage - (RFC9580EncryptMessageOptions - { rfc9580EncryptMessageExposure = exposure - , rfc9580EncryptMessageSymmetricAlgorithm = AES256 - , rfc9580EncryptMessageS2K = Argon2 (Salt16 (B.pack [0x80 .. 0x8f])) 1 4 15 - , rfc9580EncryptMessageIV = IV "0123456789ABCDEF" - }) - passphrase - payload - -mkTestKeyring :: [TKUnknown] -> PublicKeyring -mkTestKeyring tks = - let someTKs = [stk | Right stk <- map fromUnknownToTKEither tks] - in fst (partitionSomeTKs someTKs) - -addTimestampSeconds :: ThirtyTwoBitTimeStamp -> Word32 -> ThirtyTwoBitTimeStamp -addTimestampSeconds (ThirtyTwoBitTimeStamp ts) seconds = ThirtyTwoBitTimeStamp (ts + seconds) - -timestampToUTCTime :: ThirtyTwoBitTimeStamp -> UTCTime -timestampToUTCTime = posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp - -signCertificationAt :: - SomePKPayload - -> RSA.PrivateKey - -> UserId - -> ThirtyTwoBitTimeStamp - -> [SigSubPacket] - -> IO SignaturePayload -signCertificationAt signer signingKey uid creationTime hashedExtras = do - (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime - case signCertificationWithRSA - GenericCert - signer - uid - (hashedExtras ++ hashed) - unhashed - signingKey of - Left err -> - assertFailure ("failed to sign certification: " ++ renderSignError err) >> - fail "expected certification signature" - Right sigPayload -> pure sigPayload - -signCertificationRevocationAt :: - SomePKPayload - -> RSA.PrivateKey - -> UserId - -> ThirtyTwoBitTimeStamp - -> [SigSubPacket] - -> IO SignaturePayload -signCertificationRevocationAt signer signingKey uid creationTime hashedExtras = do - (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime - case signCertRevocationWithRSA - signer - uid - (hashedExtras ++ hashed) - unhashed - signingKey of - Left err -> - assertFailure ("failed to sign certification revocation: " ++ renderSignError err) >> - fail "expected certification revocation signature" - Right sigPayload -> pure sigPayload - -messageIssuerSubpacketsAt :: - SomePKPayload - -> ThirtyTwoBitTimeStamp - -> IO ([SigSubPacket], [SigSubPacket]) -messageIssuerSubpacketsAt signer creationTime = - case eightOctetKeyID signer of - Left err -> - assertFailure ("failed to derive issuer key id for timeline test: " ++ err) >> - fail "expected issuer key id" - Right issuerKeyId -> - pure - ( [ SigSubPacket False (SigCreationTime creationTime) - , SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer)) - ] - , [SigSubPacket False (Issuer issuerKeyId)] - ) - -loadUnencryptedRsaSigner :: IO (SomePKPayload, RSA.PrivateKey) -loadUnencryptedRsaSigner = do - secretPackets <- - DC.runConduitRes $ - CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| CL.consume - case secretPackets of - (SecretKeyPkt pkp ska:_) -> - case ska of - SUUnencrypted (RSAPrivateKey (RSA_PrivateKey privateKey)) _ -> - pure (pkp, privateKey) - _ -> - assertFailure "unencrypted.seckey did not contain an unencrypted RSA key" >> - fail "expected decrypted RSA private key" - _ -> - assertFailure "unencrypted.seckey did not begin with a secret key packet" >> - fail "expected secret key packet" - -loadUnencryptedRsaSignerV6 :: IO (SomePKPayload, RSA.PrivateKey) -loadUnencryptedRsaSignerV6 = do - (signer, signingKey) <- loadUnencryptedRsaSigner - pure (setKeyVersion V6 signer, signingKey) - -setKeyVersion :: KeyVersion -> SomePKPayload -> SomePKPayload -setKeyVersion keyVersion (PKPayload _ ts v3e pka pubkey) = - PKPayload keyVersion ts v3e pka pubkey - -setKeyTimestamp :: ThirtyTwoBitTimeStamp -> SomePKPayload -> SomePKPayload -setKeyTimestamp ts (PKPayload keyVersion _ v3e pka pubkey) = - PKPayload keyVersion ts v3e pka pubkey - -setPKAlgorithm :: PubKeyAlgorithm -> SomePKPayload -> SomePKPayload -setPKAlgorithm algorithm (PKPayload keyVersion ts v3e _ pubkey) = - PKPayload keyVersion ts v3e algorithm pubkey - -expectV4PKPayload :: String -> SomePKPayload -> IO (VersionedPKPayload V4) -expectV4PKPayload label pk = - case asV4PKPayload pk of - Left err -> - assertFailure (label ++ " should have a v4 PKPayload: " ++ err) >> - fail "expected v4 PKPayload" - Right v4pk -> pure v4pk - -expectV6PKPayload :: String -> SomePKPayload -> IO (VersionedPKPayload V6) -expectV6PKPayload label pk = - case asV6PKPayload pk of - Left err -> - assertFailure (label ++ " should have a v6 PKPayload: " ++ err) >> - fail "expected v6 PKPayload" - Right v6pk -> pure v6pk - -loadDeterministicEd25519Signer :: IO (SomePKPayload, Ed25519.SecretKey) -loadDeterministicEd25519Signer = do - let seed = B.pack [1 .. 32] - secretKey <- - case CE.eitherCryptoError (Ed25519.secretKey seed) of - Left err -> - assertFailure ("failed to initialize deterministic Ed25519 secret key: " ++ show err) >> - fail "expected deterministic Ed25519 secret key" - Right sk -> pure sk - let publicKeyBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString - signer = - PKPayload - V4 - 0 - 0 - EdDSA - (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 publicKeyBytes))))) - pure (signer, secretKey) - -loadDeterministicEd25519SignerV6 :: IO (SomePKPayload, Ed25519.SecretKey) -loadDeterministicEd25519SignerV6 = do - let seed = B.pack [1 .. 32] - secretKey <- - case CE.eitherCryptoError (Ed25519.secretKey seed) of - Left err -> - assertFailure ("failed to initialize deterministic Ed25519 secret key: " ++ show err) >> - fail "expected deterministic Ed25519 secret key" - Right sk -> pure sk - let publicKeyBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString - signer = - PKPayload - V6 - 0 - 0 - EdDSA - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip publicKeyBytes)))) - pure (signer, secretKey) - -loadDeterministicEd448Signer :: IO (SomePKPayload, Ed448.SecretKey) -loadDeterministicEd448Signer = do - let seed = B.pack [1 .. 57] - secretKey <- - case CE.eitherCryptoError (Ed448.secretKey seed) of - Left err -> - assertFailure ("failed to initialize deterministic Ed448 secret key: " ++ show err) >> - fail "expected deterministic Ed448 secret key" - Right sk -> pure sk - let publicKeyBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString - signer = - PKPayload - V4 - 0 - 0 - EdDSA - (EdDSAPubKey Ed448 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 publicKeyBytes))))) - pure (signer, secretKey) - -loadDeterministicEd448SignerV6 :: IO (SomePKPayload, Ed448.SecretKey) -loadDeterministicEd448SignerV6 = do - let seed = B.pack [1 .. 57] - secretKey <- - case CE.eitherCryptoError (Ed448.secretKey seed) of - Left err -> - assertFailure ("failed to initialize deterministic Ed448 secret key: " ++ show err) >> - fail "expected deterministic Ed448 secret key" - Right sk -> pure sk - let publicKeyBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString - signer = - PKPayload - V6 - 0 - 0 - EdDSA - (EdDSAPubKey Ed448 (NativeEPoint (EPoint (os2ip publicKeyBytes)))) - pure (signer, secretKey) - -testSEIPDv2ForV4KeyArmor :: Assertion -testSEIPDv2ForV4KeyArmor = do - armors <- loadArmor "seipdv2-for-v4-key.pgp.aa" - armor <- - case armors of - [a] -> pure a - _ -> - assertFailure "seipdv2-for-v4-key fixture should contain one armored payload" >> - fail "expected one armored payload" - payload <- - case armor of - Armor ArmorMessage _ p -> pure p - Armor atype _ _ -> - assertFailure - ("seipdv2-for-v4-key fixture should decode as a message block, got " ++ - show atype) >> - fail "expected message block" - _ -> - assertFailure "seipdv2-for-v4-key fixture should decode as an armored payload" >> - fail "expected armored payload" - let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload)) - case packets of - [PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _)), SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _)] -> do - let ridHex = map toUpper (BLC8.unpack (B16L.encode rid)) - if ridHex `elem` ["C8263FC6D676044B6E973959C2F2C2CAE30DE908", "04C8263FC6D676044B6E973959C2F2C2CAE30DE908"] - then pure () - else - assertFailure - ("seipdv2-for-v4-key fixture should target the expected recipient fingerprint, got " ++ - ridHex) - assertEqual - "seipdv2-for-v4-key fixture should use ECDH PKESKv6" - ECDH - pka - assertEqual - "seipdv2-for-v4-key fixture should use AES-256" - AES256 - sa - assertEqual - "seipdv2-for-v4-key fixture should use OCB" - OCB - aa - assertEqual - "seipdv2-for-v4-key fixture should use 4KiB chunks" - 6 - chunkSize - _ -> - assertFailure - ("seipdv2-for-v4-key fixture should contain [PKESKPkt (PKESK6 ...), SymEncIntegrityProtectedDataPkt (SEIPD2 ...)], got: " ++ - show packets) - -loadSEIPDv2FixtureWithV4Secret :: FilePath -> IO ([Pkt], [Pkt], BL.ByteString) -loadSEIPDv2FixtureWithV4Secret fixture = do - messageArmor <- loadFirstArmor fixture - encryptedSecretArmor <- loadFirstArmor "v4-encrypted-secret.pgp.aa" - passphrase <- readPKIPassphrase - pure - ( parsePkts (armorPayload messageArmor) - , parsePkts (armorPayload encryptedSecretArmor) - , passphrase - ) - -forceVersionedRecipientIdentifier :: Pkt -> Pkt -forceVersionedRecipientIdentifier pkt = - case pkt of - PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk)) - | BL.length rid == 20 -> - PKESKPkt - (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x04 rid) pka esk)) - | BL.length rid == 32 -> - PKESKPkt - (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x06 rid) pka esk)) - | otherwise -> pkt - _ -> pkt - -selectRecipientKeyInfoByRawRecipientId :: Pkt -> [PKESKRecipientKey] -> Maybe PKESKRecipientKey -selectRecipientKeyInfoByRawRecipientId (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) keyInfos = - listToMaybe - [ keyInfo - | keyInfo <- keyInfos - , supportsPKESKAlgorithm pka keyInfo - , matchesRawRecipientFingerprint rid keyInfo - ] -selectRecipientKeyInfoByRawRecipientId _ keyInfos = listToMaybe keyInfos - -matchesRawRecipientFingerprint :: BL.ByteString -> PKESKRecipientKey -> Bool -matchesRawRecipientFingerprint rid keyInfo = - case pkeskRecipientPKPayload keyInfo of - Nothing -> False - Just pkp -> - BL.toStrict rid == BL.toStrict (unFingerprint (fingerprint pkp)) - -testSEIPDv2TwoRecipientsArmor :: Assertion -testSEIPDv2TwoRecipientsArmor = - testSEIPDv2RecipientFixtureArmor "seipdv2-two-recipients.pgp.aa" 2 - -testSEIPDv2ThreeRecipientsArmor :: Assertion -testSEIPDv2ThreeRecipientsArmor = - testSEIPDv2RecipientFixtureArmor "seipdv2-three-recipients.pgp.aa" 3 - -testSEIPDv2RecipientFixtureArmor :: FilePath -> Int -> Assertion -testSEIPDv2RecipientFixtureArmor file expectedRecipients = do - armors <- loadArmor file - armor <- - case armors of - [a] -> pure a - _ -> - assertFailure (file ++ " fixture should contain one armored payload") >> - fail "expected one armored payload" - payload <- - case armor of - Armor ArmorMessage _ p -> pure p - Armor atype _ _ -> - assertFailure - (file ++ " fixture should decode as a message block, got " ++ show atype) >> - fail "expected message block" - _ -> - assertFailure (file ++ " fixture should decode as an armored payload") >> - fail "expected armored payload" - let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload)) - pkesks = [(rid, pka) | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _)) <- packets] - x25519Esks = [BL.toStrict esk | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 esk)) <- packets] - x448Esks = [BL.toStrict esk | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 esk)) <- packets] - seipdv2Packets = - [(sa, aa, chunkSize) | SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _) <- packets] - assertEqual - (file ++ " fixture should contain expected number of PKESKv6 packets") - expectedRecipients - (length pkesks) - if all (\(_, pka) -> pka == ECDH || pka == X25519) pkesks - then pure () - else - assertFailure - (file ++ " fixture should use only ECDH/X25519 PKESKv6 packets, got " ++ - show (map snd pkesks)) - if any ((== ECDH) . snd) pkesks - then pure () - else - assertFailure (file ++ " fixture should include an ECDH recipient for the v4 key") - mapM_ (assertX25519EskShape file) x25519Esks - mapM_ (assertX448EskShape file) x448Esks - if all - (\(rid, _) -> - let l = BL.length rid - in l == 20 || l == 21 || l == 32 || l == 33) - pkesks - then pure () - else - assertFailure - (file ++ " fixture should use 20/21-byte or 32/33-byte recipient identifiers") - case seipdv2Packets of - [(sa, aa, chunkSize)] -> do - assertEqual (file ++ " fixture should use AES-256") AES256 sa - assertEqual (file ++ " fixture should use OCB") OCB aa - assertEqual (file ++ " fixture should use 4KiB chunks") 6 chunkSize - _ -> - assertFailure - (file ++ " fixture should contain one SymEncIntegrityProtectedDataV2 packet") - -assertX25519EskShape :: FilePath -> B.ByteString -> Assertion -assertX25519EskShape file x25519Esk - | B.length x25519Esk < 33 = - assertFailure - (file ++ " X25519 PKESKv6 ESK should contain 32-octet ephemeral and wrapped-len") - | otherwise = do - let wrappedLen = fromIntegral (B.index x25519Esk 32) :: Int - wrapped = B.drop 33 x25519Esk - assertEqual - (file ++ " X25519 PKESKv6 wrapped length octet") - wrappedLen - (B.length wrapped) - -assertX448EskShape :: FilePath -> B.ByteString -> Assertion -assertX448EskShape file x448Esk - | B.length x448Esk < 57 = - assertFailure - (file ++ " X448 PKESKv6 ESK should contain 56-octet ephemeral and wrapped-len") - | otherwise = do - let wrappedLen = fromIntegral (B.index x448Esk 56) :: Int - wrapped = B.drop 57 x448Esk - assertEqual - (file ++ " X448 PKESKv6 wrapped length octet") - wrappedLen - (B.length wrapped) - -prependUnusableLatestPKESK :: [Pkt] -> [Pkt] -prependUnusableLatestPKESK packets = - let bogusRid = BL.pack (0x06 : replicate 32 0x99) - bogusPKESK = PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk")) - (eskPrefix, encryptedSuffix) = span isPrecedingESK packets - in eskPrefix ++ [bogusPKESK] ++ encryptedSuffix - -reorderPrecedingPKESKs :: [Pkt] -> [Pkt] -reorderPrecedingPKESKs packets = - let (eskPrefix, encryptedSuffix) = span isPrecedingESK packets - reorderedPKESKs = reverse [pkt | pkt@(PKESKPkt _) <- eskPrefix] - in refillPKESKSlots eskPrefix reorderedPKESKs ++ encryptedSuffix - where - refillPKESKSlots [] _ = [] - refillPKESKSlots (pkt:rest) pkesks = - case pkt of - PKESKPkt {} -> - case pkesks of - [] -> pkt : refillPKESKSlots rest [] - (replacement:remaining) -> - replacement : refillPKESKSlots rest remaining - _ -> pkt : refillPKESKSlots rest pkesks - -isPrecedingESK :: Pkt -> Bool -isPrecedingESK (PKESKPkt _) = True -isPrecedingESK (SKESKPkt _) = True -isPrecedingESK _ = False - -messageVerificationFixtures :: [(String, FilePath, FilePath, [Fingerprint])] -messageVerificationFixtures = - [ ( "uncompressed-ops-dsa" - , "pubring.gpg" - , "uncompressed-ops-dsa.gpg" - , [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"]) - , ( "uncompressed-ops-dsa-sha384" - , "pubring.gpg" - , "uncompressed-ops-dsa-sha384.txt.gpg" - , [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"]) - , ( "uncompressed-ops-rsa" - , "pubring.gpg" - , "uncompressed-ops-rsa.gpg" - , [fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"]) - , ( "compressedsig" - , "pubring.gpg" - , "compressedsig.gpg" - , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , ( "compressedsig-zlib" - , "pubring.gpg" - , "compressedsig-zlib.gpg" - , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , ( "compressedsig-bzip2" - , "pubring.gpg" - , "compressedsig-bzip2.gpg" - , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - ] - -certificateVerificationFixtures :: [(String, FilePath, FilePath, [Fingerprint])] -certificateVerificationFixtures = - [ ( "userid" - , "pubring.gpg" - , "minimized.gpg" - , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , ( "subkey" - , "pubring.gpg" - , "subkey.gpg" - , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , ( "primary key binding" - , "signing-subkey.gpg" - , "primary-binding.gpg" - , [fp "ED1B D216 F70E 5D5F 4444 48F9 B830 F2C4 83A9 9AE5"]) - , ( "attribute" - , "pubring.gpg" - , "uat.gpg" - , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , ( "primary key revocation" - , "pubring.gpg" - , "prikey-rev.gpg" - , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , ( "subkey revocation" - , "pubring.gpg" - , "subkey-rev.gpg" - , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , ( "6F87040E" - , "pubring.gpg" - , "6F87040E.pubkey" - , [ fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E" - , fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D" - , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" - ]) - , ( "6F87040E-cr" - , "pubring.gpg" - , "6F87040E-cr.pubkey" - , [ fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" - , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" - , fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E" - , fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D" - , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" - ]) - , ( "simple RSA secret key" - , "pubring.gpg" - , "simple.seckey" - , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]) - , ( "simple ECDSA public key" - , "ecdsa-key-without-ecdh.pubkey" - , "ecdsa-key-without-ecdh.pubkey" - , [fp "174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224"]) - ] - -verificationFixtureGroup :: - String - -> (PublicKeyring -> BL.ByteString -> [Either String Verification]) - -> [(String, FilePath, FilePath, [Fingerprint])] - -> TestTree -verificationFixtureGroup groupName verifier fixtures = - testGroup - groupName - [ testCase name (assertMessageVerification verifier keyringFile messageFile issuers) - | (name, keyringFile, messageFile, issuers) <- fixtures - ] - -loadV6UnencryptedSecretKeyFixtureForProperty :: IO (Either String (SomePKPayload, SKAddendum, SKey)) -loadV6UnencryptedSecretKeyFixtureForProperty = do - armored <- readFixtureLazy "v6-secret.pgp.aa" - pure $ do - armors <- first ("failed to decode v6 secret fixture: " ++) (AA.decodeLazy armored) - armor <- - case armors of - (a:_) -> Right a - [] -> Left "v6-secret.pgp.aa should contain one armored payload" - let packets = parsePkts (armorPayload armor) - (pkp, ska) <- - case packets of - (SecretKeyPkt pkpayload skaddendum:_) -> Right (pkpayload, skaddendum) - _ -> Left "v6-secret.pgp.aa should begin with a secret key packet" - skey <- - case ska of - SUUnencrypted x _ -> Right x - _ -> Left "v6-secret.pgp.aa should contain unencrypted secret key material" - Right (pkp, ska, skey) - -loadV4EncryptedSecretKeyFixtureForProperty :: - IO (Either String (SomePKPayload, SKAddendum, SKey, BL.ByteString)) -loadV4EncryptedSecretKeyFixtureForProperty = do - passphrase <- readPKIPassphrase - packets <- - DC.runConduitRes $ - CB.sourceFile "tests/data/aes256-sha512.seckey" DC..| conduitGet get DC..| - CL.consume - pure $ do - (pkp, ska) <- - case packets of - (SecretKeyPkt pkpayload skaddendum:_) -> Right (pkpayload, skaddendum) - _ -> Left "aes256-sha512.seckey should begin with a secret key packet" - skey <- - case decryptPrivateKey (pkp, ska) passphrase of - Right (SUUnencrypted x _) -> Right x - Right other -> - Left ("unexpected decrypted key shape for v4 fixture: " ++ show other) - Left err -> - Left ("failed to decrypt v4 fixture secret key: " ++ err) - Right (pkp, ska, skey, passphrase) - -reverseIf :: Bool -> [a] -> [a] -reverseIf shouldReverse xs - | shouldReverse = reverse xs - | otherwise = xs - -cgp :: DC.ConduitT B.ByteString Pkt (ResourceT IO) () -cgp = conduitGet (get :: Get Pkt) - -fp :: Text -> Fingerprint -fp = either error id . parseFingerprint - -doPkeyAndSkeyMatch :: PKey -> SKey -> Assertion -doPkeyAndSkeyMatch (RSAPubKey (RSA_PublicKey rpub)) (RSAPrivateKey (RSA_PrivateKey rpriv)) = - assertEqual - "RSA private key matches RSA public key" - rpub - (RSA.private_pub rpriv) -doPkeyAndSkeyMatch (ECDSAPubKey (ECDSA_PublicKey ecpub)) (ECDSAPrivateKey (ECDSA_PrivateKey ecpriv)) = - assertEqual - "ECDSA private key curve matches ECDSA public key curve" - (ECDSA.public_curve ecpub) - (ECDSA.private_curve ecpriv) -doPkeyAndSkeyMatch _ _ = assertFailure "matching unimplemented" - -collectSecretKeyInfos :: [Pkt] -> BL.ByteString -> IO [PKESKRecipientKey] -collectSecretKeyInfos pkts passphrase = do - let keyInfoResults = map toKeyInfo pkts - keyInfos = catMaybes [mKeyInfo | Right mKeyInfo <- keyInfoResults] - unlockErrors = [err | Left err <- keyInfoResults] - unless (null unlockErrors) $ - assertFailure - ("one or more secret key packets failed to unlock (partial failures are surfaced to\ - \ prevent silent key-context gaps):\n" ++ - unlines unlockErrors) - pure keyInfos - where - toKeyInfo (SecretKeyPkt pkp ska) = decryptToRecipientKey "SecretKeyPkt" pkp ska - toKeyInfo (SecretSubkeyPkt pkp ska) = decryptToRecipientKey "SecretSubkeyPkt" pkp ska - toKeyInfo _ = Right Nothing - - decryptToRecipientKey contextLabel pkp ska = - case ska of - SUUnencrypted skey _ -> - Right - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just pkp - , pkeskRecipientSKey = skey - })) - _ -> - case decryptPrivateKey (pkp, ska) passphrase of - Right (SUUnencrypted skey _) -> - Right - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just pkp - , pkeskRecipientSKey = skey - })) - Right decryptedSKA -> - Left - (contextLabel ++ - " " ++ - show (fingerprint pkp) ++ - ": decryptPrivateKey returned unexpected protection: " ++ - show decryptedSKA) - Left err -> - Left - (contextLabel ++ - " " ++ - show (fingerprint pkp) ++ - ": decryptPrivateKey failed: " ++ err) - -signSubkeyRevocationWithRSAAt :: - SomePKPayload - -> SomePKPayload - -> RSA.PrivateKey - -> ThirtyTwoBitTimeStamp - -> IO SignaturePayload -signSubkeyRevocationWithRSAAt signer subkey signingKey creationTime = do - (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime - case signSubkeyRevocationWithRSA signer subkey hashed unhashed signingKey of - Left err -> - assertFailure ("failed to sign subkey revocation: " ++ renderSignError err) >> - fail "expected subkey revocation signature" - Right sigPayload -> pure sigPayload - -signSubkeyBindingWithRSAAt :: - SomePKPayload - -> SomePKPayload - -> RSA.PrivateKey - -> ThirtyTwoBitTimeStamp - -> IO SignaturePayload -signSubkeyBindingWithRSAAt signer subkey signingKey creationTime = do - signSubkeyBindingWithRSAExtrasAt signer subkey signingKey creationTime [] - -signDirectKeyWithRSAExtrasAt :: - SomePKPayload - -> RSA.PrivateKey - -> ThirtyTwoBitTimeStamp - -> [SigSubPacket] - -> IO SignaturePayload -signDirectKeyWithRSAExtrasAt signer signingKey creationTime hashedExtras = do - (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime - case signDirectKeyWithRSA SignatureDirectlyOnAKey signer (hashedExtras ++ hashed) unhashed signingKey of - Left err -> - assertFailure ("failed to sign direct key self-signature: " ++ renderSignError err) >> - fail "expected direct key self-signature" - Right sigPayload -> pure sigPayload - -signSubkeyBindingWithRSAExtrasAt :: - SomePKPayload - -> SomePKPayload - -> RSA.PrivateKey - -> ThirtyTwoBitTimeStamp - -> [SigSubPacket] - -> IO SignaturePayload -signSubkeyBindingWithRSAExtrasAt signer subkey signingKey creationTime hashedExtras = do - (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime - let bindingPayload = - payloadForSig - SubkeyBindingSig - emptyPSC - { lastPrimaryKey = PublicKeyPkt signer - , lastSubkey = PublicSubkeyPkt subkey - } - case signDataWithRSA SubkeyBindingSig signingKey (hashedExtras ++ hashed) unhashed bindingPayload of - Left err -> - assertFailure ("failed to sign subkey binding: " ++ renderSignError err) >> - fail "expected subkey binding signature" - Right sigPayload -> pure sigPayload - -verifyTimelinePackets :: PublicKeyring -> BL.ByteString -> SignaturePayload -> [Either VerificationError Verification] -verifyTimelinePackets keyring payload sigPayload = - verifyMessagePackets - defaultVerificationOptions - { verificationPolicy = VerifyStrict - , verificationMode = VerificationBatch - } - keyring - [LiteralDataPkt BinaryData BL.empty 0 payload, SignaturePkt sigPayload] - -assertSingleSignerFingerprint :: - String - -> Fingerprint - -> [Either VerificationError Verification] - -> Assertion -assertSingleSignerFingerprint label expected results = - case results of - [Right verification] -> - assertEqual label expected (fingerprint (_verificationSigner verification)) - other -> - assertFailure - (label ++ - ", expected one successful verification result, got " ++ - show (length other) ++ - " result(s)") - -assertSingleFailureContainsTimeline :: - String - -> String - -> [Either VerificationError Verification] - -> Assertion -assertSingleFailureContainsTimeline label needle results = - case results of - [Left err] -> - assertBool - label - (needle `isInfixOf` renderVerificationError err) - other -> - assertFailure - (label ++ - ", expected one verification failure result, got " ++ - show (length other) ++ - " result(s)") - -signCertificationWithEd25519At :: - SomePKPayload - -> SomePKPayload - -> Ed25519.SecretKey - -> UserId - -> ThirtyTwoBitTimeStamp - -> [SigSubPacket] - -> IO SignaturePayload -signCertificationWithEd25519At certifiedSigner certifierSigner signingKey uid creationTime hashedExtras = do - (hashed, unhashed) <- messageIssuerSubpacketsAt certifierSigner creationTime - let state = - emptyPSC - { lastPrimaryKey = PublicKeyPkt certifiedSigner - , lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText) - } - case signDataWithEd25519 - GenericCert - signingKey - (hashedExtras ++ hashed) - unhashed - (payloadForSig GenericCert state) of - Left err -> - assertFailure ("failed to sign Ed25519 certification: " ++ renderSignError err) >> - fail "expected Ed25519 certification signature" - Right sigPayload -> pure sigPayload - -signCertificationRevocationWithEd25519At :: - SomePKPayload - -> SomePKPayload - -> Ed25519.SecretKey - -> UserId - -> ThirtyTwoBitTimeStamp - -> [SigSubPacket] - -> IO SignaturePayload -signCertificationRevocationWithEd25519At certifiedSigner certifierSigner signingKey uid creationTime hashedExtras = do - (hashed, unhashed) <- messageIssuerSubpacketsAt certifierSigner creationTime - let state = - emptyPSC - { lastPrimaryKey = PublicKeyPkt certifiedSigner - , lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText) - } - case signDataWithEd25519 - CertRevocationSig - signingKey - (hashedExtras ++ hashed) - unhashed - (payloadForSig CertRevocationSig state) of - Left err -> - assertFailure ("failed to sign Ed25519 certification revocation: " ++ renderSignError err) >> - fail "expected Ed25519 certification revocation signature" - Right sigPayload -> pure sigPayload - -signKeyRevocationWithReasonAt :: - SomePKPayload - -> RSA.PrivateKey - -> ThirtyTwoBitTimeStamp - -> RevocationCode - -> IO SignaturePayload -signKeyRevocationWithReasonAt signer signingKey creationTime reasonCode = - signKeyRevocationWithReasonAndExtrasAt - signer - signingKey - creationTime - reasonCode - [] - -signKeyRevocationWithReasonAndExtrasAt :: - SomePKPayload - -> RSA.PrivateKey - -> ThirtyTwoBitTimeStamp - -> RevocationCode - -> [SigSubPacket] - -> IO SignaturePayload -signKeyRevocationWithReasonAndExtrasAt signer signingKey creationTime reasonCode hashedExtras = do - (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime - case signKeyRevocationWithRSA - signer - (SigSubPacket False (ReasonForRevocation reasonCode "") : hashedExtras ++ hashed) - unhashed - signingKey of - Left err -> - assertFailure ("failed to sign key revocation: " ++ renderSignError err) >> - fail "expected key revocation signature" - Right sigPayload -> pure sigPayload - -signBinaryMessageWithRSAAt :: - SomePKPayload - -> RSA.PrivateKey - -> ThirtyTwoBitTimeStamp - -> BL.ByteString - -> IO SignaturePayload -signBinaryMessageWithRSAAt signer signingKey creationTime payload = do - (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime - case signDataWithRSA BinarySig signingKey hashed unhashed payload of - Left err -> - assertFailure ("failed to sign RSA message payload: " ++ renderSignError err) >> - fail "expected RSA message signature" - Right sigPayload -> pure sigPayload - -signBinaryMessageWithEd25519At :: - SomePKPayload - -> Ed25519.SecretKey - -> ThirtyTwoBitTimeStamp - -> BL.ByteString - -> IO SignaturePayload -signBinaryMessageWithEd25519At signer signingKey creationTime payload = do - (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime - case signDataWithEd25519 BinarySig signingKey hashed unhashed payload of - Left err -> - assertFailure ("failed to sign Ed25519 message payload: " ++ renderSignError err) >> - fail "expected Ed25519 message signature" - Right sigPayload -> pure sigPayload - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.Common + ( addTimestampSeconds + , armorPayload + , assertFalse + , assertTrue + , collectSecretKeyInfos + , conduitDecryptWithPKESKContext + , loadArmor + , loadAndDecompressPkts + , loadSEIPDv2FixtureWithV4Secret + , loadUnencryptedRsaSigner + , loadV4EncryptedSecretKeyFixtureForProperty + , loadV6UnencryptedSecretKeyFixtureForProperty + , prependUnusableLatestPKESK + , readFixtureLazy + , readFixturePackets + , readFixturePayload + , reorderPrecedingPKESKs + , reverseIf + , runGet -- FIXME: this is confusing + , selectRecipientKeyInfo + , setKeyTimestamp + , signCertificationAt + , signSubkeyBindingWithRSAExtrasAt + , signSubkeyRevocationWithRSAAt + , timestampToUTCTime + , assertSingleFailureContainsTimeline + , assertSingleSignerFingerprint + , encryptMessageDefault + , expectV4PKPayload + , expectV6PKPayload + , extractV4SignatureAlgorithmFields + , fp + , loadKeyring + , loadDeterministicEd25519Signer + , loadDeterministicEd25519SignerV6 + , loadDeterministicEd448Signer + , loadDeterministicEd448SignerV6 + , loadUnencryptedRsaSignerV6 + , messageIssuerSubpacketsAt + , mkTestKeyring + , setPKAlgorithm + , signBinaryMessageWithRSAAt + , signBinaryMessageWithEd25519At + , signKeyRevocationWithReasonAt + , signKeyRevocationWithReasonAndExtrasAt + , signSubkeyBindingWithRSAAt + , verifyTimelinePackets + , signCertificationRevocationWithEd25519At + , signCertificationWithEd25519At + , verificationFixtureGroup + , verifyMessageFromBytestring + , verifyMessageFromBytestringBatch + , verifyMessageFromPackets + , verifyMessageFromPacketsBatch + , certificateVerificationFixtures + , fixturePath + , messageVerificationFixtures + , readPKIPassphrase + , setKeyVersion + , signCertificationRevocationAt + , aesKeyWrapRFC3394ForTest + , assertX25519EskShape + , assertX448EskShape + , buildCurve25519LegacyKdfParamForTest + , buildECDHKDFParamForTest + , cgp + , conduitDecrypt -- FIXME: this is confusing + , conduitDecryptChecked + , conduitDecryptCheckedWithDecryptPolicy + , conduitDecryptWithCandidatesCallbackAndPolicy + , conduitDecryptWithDecryptPolicy + , deriveECDHKekForTest + , deriveX25519KekForTest + , deriveX448KekForTest + , doPkeyAndSkeyMatch + , encodeChecksum16 + , forceVersionedRecipientIdentifier + , isPrecedingESK + , mkPKESKSessionMaterialOrFail + , readFixtureStrict + , selectRecipientKeyInfoByRawRecipientId + , signDirectKeyWithRSAExtrasAt + , testEncodeOpenPGPSessionMaterial + , testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized + , testSEIPDv2ForV4KeyArmor + , testSEIPDv2TwoRecipientsArmor + , testSEIPDv2ThreeRecipientsArmor + ) +where + +import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA +import Codec.Encryption.OpenPGP.ASCIIArmor.Types + ( Armor (..) + , ArmorType (..) + ) +import Control.Error.Util (hush) +import Control.Monad (join, unless, void) +import Control.Monad.Trans.Resource (ResourceT) +import qualified Crypto.Error as CE +import qualified Crypto.Hash as CH +import qualified Crypto.Hash.Algorithms as CHA +import Crypto.KDF.HKDF (expand, extract) +import Crypto.Number.Serialize (os2ip) +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Types as ECCT +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 Data.Bifunctor (bimap, first) +import Data.Binary (get) +import Data.Binary.Get + ( Get + , getLazyByteString + , getRemainingLazyByteString + , getWord16be + , getWord8 + , runGetOrFail + ) +import Data.Binary.Put (putWord64be, runPut) +import Data.Bits (xor) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16.Lazy as B16L +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import Data.Char (toUpper) +import qualified Data.Conduit as DC +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) +import Data.List (isInfixOf) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes, listToMaybe) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Word (Word32, Word64) +import System.IO.Unsafe (unsafePerformIO) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + ( Assertion + , assertBool + , assertEqual + , assertFailure + , testCase + ) +import qualified "crypton" Crypto.Cipher.AES as AES +import qualified "crypton" Crypto.Cipher.Types as CCT + +import Codec.Encryption.OpenPGP.Arbitrary () +import Codec.Encryption.OpenPGP.Compression (decompressPkt) +import Codec.Encryption.OpenPGP.Encrypt + ( PKESKSessionMaterial + , encodeOpenPGPSessionMaterial + , mkPKESKSessionMaterial + ) +import Codec.Encryption.OpenPGP.Fingerprint + ( eightOctetKeyID + , fingerprint + ) +import Codec.Encryption.OpenPGP.Internal + ( curveFromCurve + , curveToCurveoidBS + , emptyPSC + , lastPrimaryKey + , lastSubkey + , lastUIDorUAt + ) +import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint) +import Codec.Encryption.OpenPGP.Message + ( ClearPayload + , EncryptMessageOptions (..) + , EncryptedPayload + , MessageError (..) + , Passphrase + , RecoveredSessionMaterial (..) + , SessionMaterialExposure (..) + , VersionedPKPayload + , asV4PKPayload + , asV6PKPayload + , encryptMessage + ) +import Codec.Encryption.OpenPGP.Policy + ( DecryptPolicy + , defaultDecryptPolicy + ) +import Codec.Encryption.OpenPGP.SecretKey + ( decryptPrivateKey + ) +import Codec.Encryption.OpenPGP.Serialize + ( dearmorIfAsciiArmored + , parsePkts + ) +import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig) +import Codec.Encryption.OpenPGP.Signatures + ( VerificationError (..) + , renderSignError + , renderVerificationError + , signCertRevocationWithRSA + , signCertificationWithRSA + , signDataWithEd25519 + , signDataWithRSA + , signDirectKeyWithRSA + , signKeyRevocationWithRSA + , signSubkeyRevocationWithRSA + ) +import Codec.Encryption.OpenPGP.Types +import Data.Conduit.OpenPGP.Compression (conduitDecompress) +import Data.Conduit.OpenPGP.Decrypt + ( DecryptKeyResolution (..) + , DecryptOptions (..) + , DecryptOutcome (..) + , PKESKRecipientKey (..) + ) +import qualified Data.Conduit.OpenPGP.Decrypt as DCD +import Data.Conduit.OpenPGP.Keyring + ( conduitToSomeTKsEither + , partitionSomeTKs + , sinkPublicKeyringMap + ) +import Data.Conduit.OpenPGP.Message + ( VerificationMode (..) + , VerificationOptions (..) + , VerificationPolicy (..) + , defaultVerificationOptions + , verifyMessage + , verifyMessagePackets + ) + +-- Test assertion helpers +assertTrue :: String -> Bool -> Assertion +assertTrue msg b = assertBool msg b + +assertFalse :: String -> Bool -> Assertion +assertFalse msg b = assertBool msg (not b) + +fixturePath :: FilePath -> FilePath +fixturePath file = "tests/data/" ++ file + +readFixtureLazy :: FilePath -> IO BL.ByteString +readFixtureLazy = BL.readFile . fixturePath + +readFixtureStrict :: FilePath -> IO B.ByteString +readFixtureStrict = B.readFile . fixturePath + +readFixturePackets :: FilePath -> IO [Pkt] +readFixturePackets file = + DC.runConduitRes $ + CB.sourceFile (fixturePath file) + DC..| conduitGet get + DC..| CL.consume + +readFixtureDecompressedPackets :: FilePath -> IO [Pkt] +readFixtureDecompressedPackets file = + DC.runConduitRes $ + CB.sourceFile (fixturePath file) + DC..| conduitGet get + DC..| conduitDecompress + DC..| CL.consume + +loadFirstArmor :: FilePath -> IO Armor +loadFirstArmor file = do + armors <- loadArmor file + case armors of + (a : _) -> pure a + [] -> + assertFailure (file ++ " armor file contained no armor blocks") + >> fail "expected armor block" + +readPKIPassphrase :: IO BL.ByteString +readPKIPassphrase = readFixtureLazy "pki-password.txt" + +-- this needs a better name +runGet :: Get a -> BL.ByteString -> Either String a +runGet g bs = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail g bs) + +extractV4SignatureAlgorithmFields + :: BL.ByteString -> Either String (PubKeyAlgorithm, B.ByteString) +extractV4SignatureAlgorithmFields = + runGet $ do + version <- getWord8 + if version /= 4 + then + fail + ("expected v4 signature payload, got version " ++ show version) + else do + _ <- getWord8 -- sig type + pka <- getWord8 + _ <- getWord8 -- hash algo + hlen <- getWord16be + _ <- getLazyByteString (fromIntegral hlen) + ulen <- getWord16be + _ <- getLazyByteString (fromIntegral ulen) + _ <- getWord16be -- left16 + algorithmFields <- getRemainingLazyByteString + pure (toFVal pka, BL.toStrict algorithmFields) + +conduitDecrypt + :: (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) () +conduitDecrypt cb = + void $ + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithoutPKESK + , decryptOptionsPolicy = defaultDecryptPolicy + , decryptOptionsPassphraseCallback = cb + } + +conduitDecryptWithPKESKContext + :: (Pkt -> IO (Maybe PKESKRecipientKey)) + -> (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) () +conduitDecryptWithPKESKContext pkcb cb = + void $ + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = + DecryptWithUnwrapCandidatesCallback + (asPKESKUnwrapCandidatesCallback pkcb) + , decryptOptionsPolicy = defaultDecryptPolicy + , decryptOptionsPassphraseCallback = cb + } + +conduitDecryptWithDecryptPolicy + :: DecryptPolicy + -> (Pkt -> IO (Maybe PKESKRecipientKey)) + -> (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) () +conduitDecryptWithDecryptPolicy dp pkcb cb = + void $ + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = + DecryptWithUnwrapCandidatesCallback + (asPKESKUnwrapCandidatesCallback pkcb) + , decryptOptionsPolicy = dp + , decryptOptionsPassphraseCallback = cb + } + +conduitDecryptChecked + :: (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome +conduitDecryptChecked cb = + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithoutPKESK + , decryptOptionsPolicy = defaultDecryptPolicy + , decryptOptionsPassphraseCallback = cb + } + +conduitDecryptCheckedWithDecryptPolicy + :: DecryptPolicy + -> (Pkt -> IO (Maybe PKESKRecipientKey)) + -> (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome +conduitDecryptCheckedWithDecryptPolicy dp pkcb cb = + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = + DecryptWithUnwrapCandidatesCallback + (asPKESKUnwrapCandidatesCallback pkcb) + , decryptOptionsPolicy = dp + , decryptOptionsPassphraseCallback = cb + } + +conduitDecryptWithCandidatesCallbackAndPolicy + :: DecryptPolicy + -> (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]) + -> (String -> IO BL.ByteString) + -> DC.ConduitT Pkt Pkt (ResourceT IO) () +conduitDecryptWithCandidatesCallbackAndPolicy dp candCb cb = + void $ + DCD.conduitDecrypt + DecryptOptions + { decryptOptionsKeyResolution = + DecryptWithUnwrapCandidatesCallback candCb + , decryptOptionsPolicy = dp + , decryptOptionsPassphraseCallback = cb + } + +asPKESKUnwrapCandidatesCallback + :: (Pkt -> IO (Maybe PKESKRecipientKey)) + -> KeyIdentifier + -> PubKeyAlgorithm + -> IO [PKESKRecipientKey] +asPKESKUnwrapCandidatesCallback pkcb keyIdentifier pka = do + mk <- pkcb (pkeskProbePacket keyIdentifier pka) + pure (maybe [] (: []) mk) + +pkeskProbePacket :: KeyIdentifier -> PubKeyAlgorithm -> Pkt +pkeskProbePacket keyIdentifier pka = + case keyIdentifier of + KeyIdentifierWildcard -> + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + pka + (MPI 0 :| []) + ) + ) + KeyIdentifierEightOctet rid -> + PKESKPkt + ( PKESKPayloadV3Packet + (PKESKPayloadV3 3 rid pka (MPI 0 :| [])) + ) + KeyIdentifierFingerprint rid -> + PKESKPkt + ( PKESKPayloadV6Packet + (PKESKPayloadV6 (unFingerprint rid) pka mempty) + ) + +readFixturePayload :: FilePath -> IO BL.ByteString +readFixturePayload fpr = do + bs <- BL.readFile ("tests/data/" ++ fpr) + case dearmorIfAsciiArmored bs of + Left err -> + assertFailure + ("ASCII armor decode failed for " ++ fpr ++ ": " ++ err) + >> pure mempty + Right (_, payload) -> pure payload + +testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized + :: Assertion +testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized = do + secretPackets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" + DC..| conduitGet get + DC..| CL.consume + (publicKey, privateKey) <- + case secretPackets of + (SecretKeyPkt pkp ska : _) -> + case (_pubkey pkp, ska) of + ( RSAPubKey (RSA_PublicKey pub) + , SUUnencrypted (RSAPrivateKey (RSA_PrivateKey prv)) _ + ) -> + pure (pub, prv) + _ -> + assertFailure + "unencrypted.seckey did not contain a parseable unencrypted RSA key pair" + >> fail "expected RSA key pair from parsed secret key packet" + _ -> + assertFailure + "unencrypted.seckey did not begin with a secret key packet" + >> fail "expected secret key packet" + let plaintext = "pkcs1-v1.5 regression payload" :: B.ByteString + encrypted <- + ( P15.encrypt publicKey plaintext + :: IO (Either RSA.Error B.ByteString) + ) + ciphertext <- + case encrypted of + Left err -> + assertFailure ("RSA PKCS#1 v1.5 encryption failed: " ++ show err) + >> pure mempty + Right ct -> pure ct + decrypted <- + ( P15.decryptSafer privateKey ciphertext + :: IO (Either RSA.Error B.ByteString) + ) + case decrypted of + Left RSA.MessageNotRecognized -> + assertFailure + "parsed RSA private key decryption failed with MessageNotRecognized" + Left err -> + assertFailure + ("parsed RSA private key decryption failed: " ++ show err) + Right got -> + assertEqual + "parsed RSA private key decrypts PKCS#1 v1.5 payload" + plaintext + got + +testEncodeOpenPGPSessionMaterial :: Assertion +testEncodeOpenPGPSessionMaterial = do + let keyBytes = B.pack [1 .. 32] + expected = + B.singleton (fromFVal AES256) + <> keyBytes + <> encodeChecksum16 keyBytes + case encodeOpenPGPSessionMaterial AES256 (SessionKey keyBytes) of + Left err -> + assertFailure + ("encodeOpenPGPSessionMaterial failed: " ++ show err) + Right encoded -> + assertEqual "OpenPGP session material encoding" expected encoded + +mkPKESKSessionMaterialOrFail + :: SymmetricAlgorithm -> SessionKey -> IO PKESKSessionMaterial +mkPKESKSessionMaterialOrFail symalgo sessionKey = + case mkPKESKSessionMaterial symalgo sessionKey of + Left err -> + assertFailure ("mkPKESKSessionMaterial failed: " ++ show err) + >> fail "mkPKESKSessionMaterial failed" + Right material -> pure material + +armorPayload :: Armor -> BL.ByteString +armorPayload (Armor _ _ bs) = BL.fromStrict (BLC8.toStrict bs) +armorPayload (ClearSigned _ _ inner) = armorPayload inner + +selectRecipientKeyInfo + :: Pkt -> [PKESKRecipientKey] -> Maybe PKESKRecipientKey +selectRecipientKeyInfo (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) keyInfos = + listToMaybe + [ keyInfo + | keyInfo <- keyInfos + , supportsPKESKAlgorithm pka keyInfo + , matchesRecipientIdentifier rid keyInfo + ] +selectRecipientKeyInfo (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) keyInfos + | isWildcardEightOctetKeyId rid = + listToMaybe + [ keyInfo | keyInfo <- keyInfos, supportsPKESKAlgorithm pka keyInfo + ] + | otherwise = + listToMaybe + [ keyInfo + | keyInfo <- keyInfos + , supportsPKESKAlgorithm pka keyInfo + , matchesEightOctetRecipientKeyId rid keyInfo + ] +selectRecipientKeyInfo _ keyInfos = listToMaybe keyInfos + +isWildcardEightOctetKeyId :: EightOctetKeyId -> Bool +isWildcardEightOctetKeyId (EightOctetKeyId rid) = + BL.length rid == 8 && BL.all (== 0) rid + +matchesEightOctetRecipientKeyId + :: EightOctetKeyId -> PKESKRecipientKey -> Bool +matchesEightOctetRecipientKeyId (EightOctetKeyId rid) keyInfo = + case pkeskRecipientPKPayload keyInfo of + Nothing -> False + Just pkp -> + let fingerprintBytes = unFingerprint (fingerprint pkp) + in BL.length fingerprintBytes >= 8 + && BL.drop (BL.length fingerprintBytes - 8) fingerprintBytes == rid + +supportsPKESKAlgorithm + :: PubKeyAlgorithm -> PKESKRecipientKey -> Bool +supportsPKESKAlgorithm pka keyInfo = + case pkeskRecipientSKey keyInfo of + RSAPrivateKey {} -> pka == RSA + ECDHPrivateKey {} -> pka == ECDH || pka == X25519 + X25519PrivateKey {} -> pka == X25519 + X448PrivateKey {} -> pka == X448 + _ -> False + +matchesRecipientIdentifier + :: BL.ByteString -> PKESKRecipientKey -> Bool +matchesRecipientIdentifier rid keyInfo = + case pkeskRecipientPKPayload keyInfo of + Nothing -> False + Just pkp -> + let fingerprintBytes = BL.toStrict (unFingerprint (fingerprint pkp)) + identifier = BL.toStrict rid + in identifier == fingerprintBytes + || identifier == B.cons 0x04 fingerprintBytes + || identifier == B.cons 0x06 fingerprintBytes + +buildECDHKDFParamForTest + :: SomePKPayload + -> PubKeyAlgorithm + -> ECCT.Curve + -> HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString +buildECDHKDFParamForTest recipientPKP pka curve kdfHA kdfSA = + B.singleton (fromIntegral (B.length curveOid)) + <> curveOid + <> B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA] + <> "Anonymous Sender " + <> BL.toStrict (unFingerprint (fingerprint recipientPKP)) + where + curveOid = + either + (const B.empty) + id + (curveToCurveoidBS (curveFromCurve curve)) + +buildCurve25519LegacyKdfParamForTest + :: SomePKPayload + -> PubKeyAlgorithm + -> HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString +buildCurve25519LegacyKdfParamForTest recipientPKP pka kdfHA kdfSA = + B.singleton (fromIntegral (B.length curveOid)) + <> curveOid + <> B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA] + <> "Anonymous Sender " + <> BL.toStrict (unFingerprint (fingerprint recipientPKP)) + where + curveOid = "\x2b\x06\x01\x04\x01\x97\x55\x01\x05\x01" + +deriveECDHKekForTest + :: HashAlgorithm + -> SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> B.ByteString +deriveECDHKekForTest kdfHA kdfSA sharedSecret kdfParam = + B.take (keyLengthForTest kdfSA) digest + where + digest = + case kdfHA of + SHA256 -> + BA.convert + ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) + :: CH.Digest CHA.SHA256 + ) + SHA384 -> + BA.convert + ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) + :: CH.Digest CHA.SHA384 + ) + SHA512 -> + BA.convert + ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) + :: CH.Digest CHA.SHA512 + ) + _ -> + BA.convert + ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam) + :: CH.Digest CHA.SHA256 + ) + +deriveX448KekForTest + :: B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString +deriveX448KekForTest ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHA.SHA512 B.empty ikm + info = "OpenPGP X448" :: B.ByteString + in expand @CHA.SHA512 prk info 32 + +deriveX25519KekForTest + :: B.ByteString + -> B.ByteString + -> B.ByteString + -> B.ByteString +deriveX25519KekForTest ephemeralPublic recipientPublic sharedSecret = + let ikm = ephemeralPublic <> recipientPublic <> sharedSecret + prk = extract @CHA.SHA256 B.empty ikm + info = "OpenPGP X25519" :: B.ByteString + in expand @CHA.SHA256 prk info 16 + +keyLengthForTest :: SymmetricAlgorithm -> Int +keyLengthForTest AES128 = 16 +keyLengthForTest AES192 = 24 +keyLengthForTest AES256 = 32 +keyLengthForTest _ = 16 + +aesKeyWrapRFC3394ForTest + :: SymmetricAlgorithm + -> B.ByteString + -> B.ByteString + -> B.ByteString +aesKeyWrapRFC3394ForTest sa kek plain = + case sa of + AES128 -> wrapWithCipher (initCipher kek :: AES.AES128) plain + AES192 -> wrapWithCipher (initCipher kek :: AES.AES192) plain + AES256 -> wrapWithCipher (initCipher kek :: AES.AES256) plain + _ -> error "unsupported KEK algorithm in test" + where + initCipher keyBytes = + case CE.eitherCryptoError (CCT.cipherInit keyBytes) of + Left err -> error ("cipher init failed: " ++ show err) + Right c -> c + wrapWithCipher cipher plainBytes = + let rs = chunksOf8ForTest plainBytes + n = length rs + a0 = B.replicate 8 0xA6 + (aFinal, rFinal) = + foldl (\(a, r) j -> wrapRound cipher n j a r) (a0, rs) [0 .. 5] + in aFinal <> B.concat rFinal + wrapRound cipher n j a rs = foldl step (a, rs) [1 .. n] + where + step (aCurr, rCurr) i = + let b = CCT.ecbEncrypt cipher (aCurr <> (rCurr !! (i - 1))) + (aMsb, rLsb) = B.splitAt 8 b + t = fromIntegral (n * j + i) :: Word64 + aNext = xorBSForTest aMsb (encodeWord64beForTest t) + in (aNext, replaceAtForTest (i - 1) rLsb rCurr) + +encodeWord64beForTest :: Word64 -> B.ByteString +encodeWord64beForTest = BL.toStrict . runPut . putWord64be + +chunksOf8ForTest :: B.ByteString -> [B.ByteString] +chunksOf8ForTest bs + | B.null bs = [] + | otherwise = + let (h, t) = B.splitAt 8 bs + in h : chunksOf8ForTest t + +replaceAtForTest :: Int -> a -> [a] -> [a] +replaceAtForTest idx x xs = + let (prefix, suffix) = splitAt idx xs + in case suffix of + [] -> xs + (_ : rest) -> prefix <> (x : rest) + +xorBSForTest :: B.ByteString -> B.ByteString -> B.ByteString +xorBSForTest a b = B.pack (B.zipWith xor a b) + +encodeChecksum16 :: B.ByteString -> B.ByteString +encodeChecksum16 bs = + B.pack + [fromIntegral (s `div` 256), fromIntegral (s `mod` 256)] + where + s = + B.foldl' + (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Int)) + 0 + bs + +verifyMessageFromPackets + :: PublicKeyring -> BL.ByteString -> [Either String Verification] +verifyMessageFromPackets keyring signedMessage = + map (either (Left . renderVerificationError) Right) $ + verifyMessagePackets + defaultVerificationOptions + { verificationPolicy = VerifyInformational + , verificationMode = VerificationStreaming + } + keyring + ( concatMap + (either (const []) id . decompressPkt) + (parsePkts signedMessage) + ) + +verifyMessageFromPacketsBatch + :: PublicKeyring -> BL.ByteString -> [Either String Verification] +verifyMessageFromPacketsBatch keyring signedMessage = + map (either (Left . renderVerificationError) Right) $ + verifyMessagePackets + defaultVerificationOptions + { verificationPolicy = VerifyInformational + , verificationMode = VerificationBatch + } + keyring + ( concatMap + (either (const []) id . decompressPkt) + (parsePkts signedMessage) + ) + +verifyMessageFromBytestring + :: PublicKeyring -> BL.ByteString -> [Either String Verification] +verifyMessageFromBytestring keyring signedMessage = + map (either (Left . renderVerificationError) Right) $ + verifyMessage + defaultVerificationOptions + { verificationPolicy = VerifyInformational + , verificationMode = VerificationStreaming + } + keyring + signedMessage + +verifyMessageFromBytestringBatch + :: PublicKeyring -> BL.ByteString -> [Either String Verification] +verifyMessageFromBytestringBatch keyring signedMessage = + map (either (Left . renderVerificationError) Right) $ + verifyMessage + defaultVerificationOptions + { verificationPolicy = VerifyInformational + , verificationMode = VerificationBatch + } + keyring + signedMessage + +assertMessageVerification + :: (PublicKeyring -> BL.ByteString -> [Either String Verification]) + -> FilePath + -> FilePath + -> [Fingerprint] + -> Assertion +assertMessageVerification verifier keyringFile messageFile issuers = do + kr <- loadKeyring keyringFile + signedMessage <- readFixtureLazy messageFile + let verification = verifier kr signedMessage + actual = map (fmap (fingerprint . _verificationSigner)) verification + assertEqual + (keyringFile ++ " for " ++ messageFile) + (map Right issuers) + actual + +loadKeyring :: FilePath -> IO PublicKeyring +loadKeyring keyring = + DC.runConduitRes $ + CB.sourceFile (fixturePath keyring) + DC..| conduitGet get + DC..| conduitToSomeTKsEither + DC..| CL.map (fmap someTKToPublicViewTK . join . hush) + DC..| CL.catMaybes + DC..| sinkPublicKeyringMap + +loadAndDecompressPkts :: FilePath -> IO [Pkt] +loadAndDecompressPkts = readFixtureDecompressedPackets + +loadArmor :: FilePath -> IO [Armor] +loadArmor file = do + armored <- readFixtureLazy file + case AA.decodeLazy armored :: Either String [Armor] of + Left err -> + assertFailure + ("Failed to decode armored fixture " ++ file ++ ": " ++ err) + >> pure [] + Right armors -> pure armors + +encryptMessageDefault + :: SessionMaterialExposure + -> Passphrase + -> ClearPayload + -> Either + MessageError + (EncryptedPayload, Maybe RecoveredSessionMaterial) +encryptMessageDefault exposure passphrase payload = + encryptMessage + ( RFC9580EncryptMessageOptions + { rfc9580EncryptMessageExposure = exposure + , rfc9580EncryptMessageSymmetricAlgorithm = AES256 + , rfc9580EncryptMessageS2K = + Argon2 (Salt16 (B.pack [0x80 .. 0x8f])) 1 4 15 + , rfc9580EncryptMessageIV = IV "0123456789ABCDEF" + } + ) + passphrase + payload + +mkTestKeyring :: [TKUnknown] -> PublicKeyring +mkTestKeyring tks = + let someTKs = [stk | Right stk <- map fromUnknownToTKEither tks] + in fst (partitionSomeTKs someTKs) + +addTimestampSeconds + :: ThirtyTwoBitTimeStamp -> Word32 -> ThirtyTwoBitTimeStamp +addTimestampSeconds (ThirtyTwoBitTimeStamp ts) seconds = ThirtyTwoBitTimeStamp (ts + seconds) + +timestampToUTCTime :: ThirtyTwoBitTimeStamp -> UTCTime +timestampToUTCTime = posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp + +signCertificationAt + :: SomePKPayload + -> RSA.PrivateKey + -> UserId + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signCertificationAt signer signingKey uid creationTime hashedExtras = do + (hashed, unhashed) <- + messageIssuerSubpacketsAt signer creationTime + case signCertificationWithRSA + GenericCert + signer + uid + (hashedExtras ++ hashed) + unhashed + signingKey of + Left err -> + assertFailure + ("failed to sign certification: " ++ renderSignError err) + >> fail "expected certification signature" + Right sigPayload -> pure sigPayload + +signCertificationRevocationAt + :: SomePKPayload + -> RSA.PrivateKey + -> UserId + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signCertificationRevocationAt signer signingKey uid creationTime hashedExtras = do + (hashed, unhashed) <- + messageIssuerSubpacketsAt signer creationTime + case signCertRevocationWithRSA + signer + uid + (hashedExtras ++ hashed) + unhashed + signingKey of + Left err -> + assertFailure + ( "failed to sign certification revocation: " + ++ renderSignError err + ) + >> fail "expected certification revocation signature" + Right sigPayload -> pure sigPayload + +messageIssuerSubpacketsAt + :: SomePKPayload + -> ThirtyTwoBitTimeStamp + -> IO ([SigSubPacket], [SigSubPacket]) +messageIssuerSubpacketsAt signer creationTime = + case eightOctetKeyID signer of + Left err -> + assertFailure + ("failed to derive issuer key id for timeline test: " ++ err) + >> fail "expected issuer key id" + Right issuerKeyId -> + pure + ( + [ SigSubPacket False (SigCreationTime creationTime) + , SigSubPacket + False + (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer)) + ] + , [SigSubPacket False (Issuer issuerKeyId)] + ) + +loadUnencryptedRsaSigner :: IO (SomePKPayload, RSA.PrivateKey) +loadUnencryptedRsaSigner = do + secretPackets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" + DC..| conduitGet get + DC..| CL.consume + case secretPackets of + (SecretKeyPkt pkp ska : _) -> + case ska of + SUUnencrypted (RSAPrivateKey (RSA_PrivateKey privateKey)) _ -> + pure (pkp, privateKey) + _ -> + assertFailure + "unencrypted.seckey did not contain an unencrypted RSA key" + >> fail "expected decrypted RSA private key" + _ -> + assertFailure + "unencrypted.seckey did not begin with a secret key packet" + >> fail "expected secret key packet" + +loadUnencryptedRsaSignerV6 :: IO (SomePKPayload, RSA.PrivateKey) +loadUnencryptedRsaSignerV6 = do + (signer, signingKey) <- loadUnencryptedRsaSigner + pure (setKeyVersion V6 signer, signingKey) + +setKeyVersion :: KeyVersion -> SomePKPayload -> SomePKPayload +setKeyVersion keyVersion (PKPayload _ ts v3e pka pubkey) = + PKPayload keyVersion ts v3e pka pubkey + +setKeyTimestamp + :: ThirtyTwoBitTimeStamp -> SomePKPayload -> SomePKPayload +setKeyTimestamp ts (PKPayload keyVersion _ v3e pka pubkey) = + PKPayload keyVersion ts v3e pka pubkey + +setPKAlgorithm + :: PubKeyAlgorithm -> SomePKPayload -> SomePKPayload +setPKAlgorithm algorithm (PKPayload keyVersion ts v3e _ pubkey) = + PKPayload keyVersion ts v3e algorithm pubkey + +expectV4PKPayload + :: String -> SomePKPayload -> IO (VersionedPKPayload V4) +expectV4PKPayload label pk = + case asV4PKPayload pk of + Left err -> + assertFailure (label ++ " should have a v4 PKPayload: " ++ err) + >> fail "expected v4 PKPayload" + Right v4pk -> pure v4pk + +expectV6PKPayload + :: String -> SomePKPayload -> IO (VersionedPKPayload V6) +expectV6PKPayload label pk = + case asV6PKPayload pk of + Left err -> + assertFailure (label ++ " should have a v6 PKPayload: " ++ err) + >> fail "expected v6 PKPayload" + Right v6pk -> pure v6pk + +loadDeterministicEd25519Signer + :: IO (SomePKPayload, Ed25519.SecretKey) +loadDeterministicEd25519Signer = do + let seed = B.pack [1 .. 32] + secretKey <- + case CE.eitherCryptoError (Ed25519.secretKey seed) of + Left err -> + assertFailure + ( "failed to initialize deterministic Ed25519 secret key: " + ++ show err + ) + >> fail "expected deterministic Ed25519 secret key" + Right sk -> pure sk + let publicKeyBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString + signer = + PKPayload + V4 + 0 + 0 + EdDSA + ( EdDSAPubKey + EdSigningCurve25519 + ( PrefixedNativeEPoint + (EPoint (os2ip (B.cons 0x40 publicKeyBytes))) + ) + ) + pure (signer, secretKey) + +loadDeterministicEd25519SignerV6 + :: IO (SomePKPayload, Ed25519.SecretKey) +loadDeterministicEd25519SignerV6 = do + let seed = B.pack [1 .. 32] + secretKey <- + case CE.eitherCryptoError (Ed25519.secretKey seed) of + Left err -> + assertFailure + ( "failed to initialize deterministic Ed25519 secret key: " + ++ show err + ) + >> fail "expected deterministic Ed25519 secret key" + Right sk -> pure sk + let publicKeyBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString + signer = + PKPayload + V6 + 0 + 0 + EdDSA + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip publicKeyBytes))) + ) + pure (signer, secretKey) + +loadDeterministicEd448Signer + :: IO (SomePKPayload, Ed448.SecretKey) +loadDeterministicEd448Signer = do + let seed = B.pack [1 .. 57] + secretKey <- + case CE.eitherCryptoError (Ed448.secretKey seed) of + Left err -> + assertFailure + ( "failed to initialize deterministic Ed448 secret key: " + ++ show err + ) + >> fail "expected deterministic Ed448 secret key" + Right sk -> pure sk + let publicKeyBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString + signer = + PKPayload + V4 + 0 + 0 + EdDSA + ( EdDSAPubKey + EdSigningCurve448 + ( PrefixedNativeEPoint + (EPoint (os2ip (B.cons 0x40 publicKeyBytes))) + ) + ) + pure (signer, secretKey) + +loadDeterministicEd448SignerV6 + :: IO (SomePKPayload, Ed448.SecretKey) +loadDeterministicEd448SignerV6 = do + let seed = B.pack [1 .. 57] + secretKey <- + case CE.eitherCryptoError (Ed448.secretKey seed) of + Left err -> + assertFailure + ( "failed to initialize deterministic Ed448 secret key: " + ++ show err + ) + >> fail "expected deterministic Ed448 secret key" + Right sk -> pure sk + let publicKeyBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString + signer = + PKPayload + V6 + 0 + 0 + EdDSA + ( EdDSAPubKey + EdSigningCurve448 + (NativeEPoint (EPoint (os2ip publicKeyBytes))) + ) + pure (signer, secretKey) + +testSEIPDv2ForV4KeyArmor :: Assertion +testSEIPDv2ForV4KeyArmor = do + armors <- loadArmor "seipdv2-for-v4-key.pgp.aa" + armor <- + case armors of + [a] -> pure a + _ -> + assertFailure + "seipdv2-for-v4-key fixture should contain one armored payload" + >> fail "expected one armored payload" + payload <- + case armor of + Armor ArmorMessage _ p -> pure p + Armor atype _ _ -> + assertFailure + ( "seipdv2-for-v4-key fixture should decode as a message block, got " + ++ show atype + ) + >> fail "expected message block" + _ -> + assertFailure + "seipdv2-for-v4-key fixture should decode as an armored payload" + >> fail "expected armored payload" + let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload)) + case packets of + [ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _)) + , SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _) + ] -> do + let ridHex = map toUpper (BLC8.unpack (B16L.encode rid)) + if ridHex + `elem` [ "C8263FC6D676044B6E973959C2F2C2CAE30DE908" + , "04C8263FC6D676044B6E973959C2F2C2CAE30DE908" + ] + then pure () + else + assertFailure + ( "seipdv2-for-v4-key fixture should target the expected recipient fingerprint, got " + ++ ridHex + ) + assertEqual + "seipdv2-for-v4-key fixture should use ECDH PKESKv6" + ECDH + pka + assertEqual + "seipdv2-for-v4-key fixture should use AES-256" + AES256 + sa + assertEqual + "seipdv2-for-v4-key fixture should use OCB" + OCB + aa + assertEqual + "seipdv2-for-v4-key fixture should use 4KiB chunks" + 6 + chunkSize + _ -> + assertFailure + ( "seipdv2-for-v4-key fixture should contain [PKESKPkt (PKESK6 ...), SymEncIntegrityProtectedDataPkt (SEIPD2 ...)], got: " + ++ show packets + ) + +loadSEIPDv2FixtureWithV4Secret + :: FilePath -> IO ([Pkt], [Pkt], BL.ByteString) +loadSEIPDv2FixtureWithV4Secret fixture = do + messageArmor <- loadFirstArmor fixture + encryptedSecretArmor <- + loadFirstArmor "v4-encrypted-secret.pgp.aa" + passphrase <- readPKIPassphrase + pure + ( parsePkts (armorPayload messageArmor) + , parsePkts (armorPayload encryptedSecretArmor) + , passphrase + ) + +forceVersionedRecipientIdentifier :: Pkt -> Pkt +forceVersionedRecipientIdentifier pkt = + case pkt of + PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk)) + | BL.length rid == 20 -> + PKESKPkt + (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x04 rid) pka esk)) + | BL.length rid == 32 -> + PKESKPkt + (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x06 rid) pka esk)) + | otherwise -> pkt + _ -> pkt + +selectRecipientKeyInfoByRawRecipientId + :: Pkt -> [PKESKRecipientKey] -> Maybe PKESKRecipientKey +selectRecipientKeyInfoByRawRecipientId (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) keyInfos = + listToMaybe + [ keyInfo + | keyInfo <- keyInfos + , supportsPKESKAlgorithm pka keyInfo + , matchesRawRecipientFingerprint rid keyInfo + ] +selectRecipientKeyInfoByRawRecipientId (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) keyInfos + | isWildcardEightOctetKeyId rid = + listToMaybe + [ keyInfo | keyInfo <- keyInfos, supportsPKESKAlgorithm pka keyInfo + ] + | otherwise = + listToMaybe + [ keyInfo + | keyInfo <- keyInfos + , supportsPKESKAlgorithm pka keyInfo + , matchesEightOctetRecipientKeyId rid keyInfo + ] +selectRecipientKeyInfoByRawRecipientId _ keyInfos = listToMaybe keyInfos + +matchesRawRecipientFingerprint + :: BL.ByteString -> PKESKRecipientKey -> Bool +matchesRawRecipientFingerprint rid keyInfo = + case pkeskRecipientPKPayload keyInfo of + Nothing -> False + Just pkp -> + BL.toStrict rid == BL.toStrict (unFingerprint (fingerprint pkp)) + +testSEIPDv2TwoRecipientsArmor :: Assertion +testSEIPDv2TwoRecipientsArmor = + testSEIPDv2RecipientFixtureArmor + "seipdv2-two-recipients.pgp.aa" + 2 + +testSEIPDv2ThreeRecipientsArmor :: Assertion +testSEIPDv2ThreeRecipientsArmor = + testSEIPDv2RecipientFixtureArmor + "seipdv2-three-recipients.pgp.aa" + 3 + +testSEIPDv2RecipientFixtureArmor :: FilePath -> Int -> Assertion +testSEIPDv2RecipientFixtureArmor file expectedRecipients = do + armors <- loadArmor file + armor <- + case armors of + [a] -> pure a + _ -> + assertFailure + (file ++ " fixture should contain one armored payload") + >> fail "expected one armored payload" + payload <- + case armor of + Armor ArmorMessage _ p -> pure p + Armor atype _ _ -> + assertFailure + ( file + ++ " fixture should decode as a message block, got " + ++ show atype + ) + >> fail "expected message block" + _ -> + assertFailure + (file ++ " fixture should decode as an armored payload") + >> fail "expected armored payload" + let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload)) + pkesks = + [ (rid, pka) + | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _)) <- + packets + ] + x25519Esks = + [ BL.toStrict esk + | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 esk)) <- + packets + ] + x448Esks = + [ BL.toStrict esk + | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 esk)) <- + packets + ] + seipdv2Packets = + [ (sa, aa, chunkSize) + | SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _) <- + packets + ] + assertEqual + ( file + ++ " fixture should contain expected number of PKESKv6 packets" + ) + expectedRecipients + (length pkesks) + if all (\(_, pka) -> pka == ECDH || pka == X25519) pkesks + then pure () + else + assertFailure + ( file + ++ " fixture should use only ECDH/X25519 PKESKv6 packets, got " + ++ show (map snd pkesks) + ) + if any ((== ECDH) . snd) pkesks + then pure () + else + assertFailure + ( file + ++ " fixture should include an ECDH recipient for the v4 key" + ) + mapM_ (assertX25519EskShape file) x25519Esks + mapM_ (assertX448EskShape file) x448Esks + if all + ( \(rid, _) -> + let l = BL.length rid + in l == 20 || l == 21 || l == 32 || l == 33 + ) + pkesks + then pure () + else + assertFailure + ( file + ++ " fixture should use 20/21-byte or 32/33-byte recipient identifiers" + ) + case seipdv2Packets of + [(sa, aa, chunkSize)] -> do + assertEqual (file ++ " fixture should use AES-256") AES256 sa + assertEqual (file ++ " fixture should use OCB") OCB aa + assertEqual + (file ++ " fixture should use 4KiB chunks") + 6 + chunkSize + _ -> + assertFailure + ( file + ++ " fixture should contain one SymEncIntegrityProtectedDataV2 packet" + ) + +assertX25519EskShape :: FilePath -> B.ByteString -> Assertion +assertX25519EskShape file x25519Esk + | B.length x25519Esk < 33 = + assertFailure + ( file + ++ " X25519 PKESKv6 ESK should contain 32-octet ephemeral and wrapped-len" + ) + | otherwise = do + let wrappedLen = fromIntegral (B.index x25519Esk 32) :: Int + wrapped = B.drop 33 x25519Esk + assertEqual + (file ++ " X25519 PKESKv6 wrapped length octet") + wrappedLen + (B.length wrapped) + +assertX448EskShape :: FilePath -> B.ByteString -> Assertion +assertX448EskShape file x448Esk + | B.length x448Esk < 57 = + assertFailure + ( file + ++ " X448 PKESKv6 ESK should contain 56-octet ephemeral and wrapped-len" + ) + | otherwise = do + let wrappedLen = fromIntegral (B.index x448Esk 56) :: Int + wrapped = B.drop 57 x448Esk + assertEqual + (file ++ " X448 PKESKv6 wrapped length octet") + wrappedLen + (B.length wrapped) + +prependUnusableLatestPKESK :: [Pkt] -> [Pkt] +prependUnusableLatestPKESK packets = + let bogusRid = BL.pack (0x06 : replicate 32 0x99) + bogusPKESK = + PKESKPkt + (PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk")) + (eskPrefix, encryptedSuffix) = span isPrecedingESK packets + in eskPrefix ++ [bogusPKESK] ++ encryptedSuffix + +reorderPrecedingPKESKs :: [Pkt] -> [Pkt] +reorderPrecedingPKESKs packets = + let (eskPrefix, encryptedSuffix) = span isPrecedingESK packets + reorderedPKESKs = reverse [pkt | pkt@(PKESKPkt _) <- eskPrefix] + in refillPKESKSlots eskPrefix reorderedPKESKs ++ encryptedSuffix + where + refillPKESKSlots [] _ = [] + refillPKESKSlots (pkt : rest) pkesks = + case pkt of + PKESKPkt {} -> + case pkesks of + [] -> pkt : refillPKESKSlots rest [] + (replacement : remaining) -> + replacement : refillPKESKSlots rest remaining + _ -> pkt : refillPKESKSlots rest pkesks + +isPrecedingESK :: Pkt -> Bool +isPrecedingESK (PKESKPkt _) = True +isPrecedingESK (SKESKPkt _) = True +isPrecedingESK _ = False + +messageVerificationFixtures + :: [(String, FilePath, FilePath, [Fingerprint])] +messageVerificationFixtures = + [ + ( "uncompressed-ops-dsa" + , "pubring.gpg" + , "uncompressed-ops-dsa.gpg" + , [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"] + ) + , + ( "uncompressed-ops-dsa-sha384" + , "pubring.gpg" + , "uncompressed-ops-dsa-sha384.txt.gpg" + , [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"] + ) + , + ( "uncompressed-ops-rsa" + , "pubring.gpg" + , "uncompressed-ops-rsa.gpg" + , [fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"] + ) + , + ( "compressedsig" + , "pubring.gpg" + , "compressedsig.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"] + ) + , + ( "compressedsig-zlib" + , "pubring.gpg" + , "compressedsig-zlib.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"] + ) + , + ( "compressedsig-bzip2" + , "pubring.gpg" + , "compressedsig-bzip2.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"] + ) + ] + +certificateVerificationFixtures + :: [(String, FilePath, FilePath, [Fingerprint])] +certificateVerificationFixtures = + [ + ( "userid" + , "pubring.gpg" + , "minimized.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"] + ) + , + ( "subkey" + , "pubring.gpg" + , "subkey.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"] + ) + , + ( "primary key binding" + , "signing-subkey.gpg" + , "primary-binding.gpg" + , [fp "ED1B D216 F70E 5D5F 4444 48F9 B830 F2C4 83A9 9AE5"] + ) + , + ( "attribute" + , "pubring.gpg" + , "uat.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"] + ) + , + ( "primary key revocation" + , "pubring.gpg" + , "prikey-rev.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"] + ) + , + ( "subkey revocation" + , "pubring.gpg" + , "subkey-rev.gpg" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"] + ) + , + ( "6F87040E" + , "pubring.gpg" + , "6F87040E.pubkey" + , + [ fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E" + , fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D" + , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" + ] + ) + , + ( "6F87040E-cr" + , "pubring.gpg" + , "6F87040E-cr.pubkey" + , + [ fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" + , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" + , fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E" + , fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D" + , fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC" + ] + ) + , + ( "simple RSA secret key" + , "pubring.gpg" + , "simple.seckey" + , [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"] + ) + , + ( "simple ECDSA public key" + , "ecdsa-key-without-ecdh.pubkey" + , "ecdsa-key-without-ecdh.pubkey" + , [fp "174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224"] + ) + ] + +verificationFixtureGroup + :: String + -> (PublicKeyring -> BL.ByteString -> [Either String Verification]) + -> [(String, FilePath, FilePath, [Fingerprint])] + -> TestTree +verificationFixtureGroup groupName verifier fixtures = + testGroup + groupName + [ testCase + name + ( assertMessageVerification + verifier + keyringFile + messageFile + issuers + ) + | (name, keyringFile, messageFile, issuers) <- fixtures + ] + +loadV6UnencryptedSecretKeyFixtureForProperty + :: IO (Either String (SomePKPayload, SKAddendum, SKey)) +loadV6UnencryptedSecretKeyFixtureForProperty = do + armored <- readFixtureLazy "v6-secret.pgp.aa" + pure $ do + armors <- + first + ("failed to decode v6 secret fixture: " ++) + (AA.decodeLazy armored) + armor <- + case armors of + (a : _) -> Right a + [] -> Left "v6-secret.pgp.aa should contain one armored payload" + let packets = parsePkts (armorPayload armor) + (pkp, ska) <- + case packets of + (SecretKeyPkt pkpayload skaddendum : _) -> Right (pkpayload, skaddendum) + _ -> Left "v6-secret.pgp.aa should begin with a secret key packet" + skey <- + case ska of + SUUnencrypted x _ -> Right x + _ -> + Left + "v6-secret.pgp.aa should contain unencrypted secret key material" + Right (pkp, ska, skey) + +loadV4EncryptedSecretKeyFixtureForProperty + :: IO + (Either String (SomePKPayload, SKAddendum, SKey, BL.ByteString)) +loadV4EncryptedSecretKeyFixtureForProperty = do + passphrase <- readPKIPassphrase + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/aes256-sha512.seckey" + DC..| conduitGet get + DC..| CL.consume + pure $ do + (pkp, ska) <- + case packets of + (SecretKeyPkt pkpayload skaddendum : _) -> Right (pkpayload, skaddendum) + _ -> + Left "aes256-sha512.seckey should begin with a secret key packet" + skey <- + case decryptPrivateKey (pkp, ska) passphrase of + Right (SUUnencrypted x _) -> Right x + Right other -> + Left + ("unexpected decrypted key shape for v4 fixture: " ++ show other) + Left err -> + Left ("failed to decrypt v4 fixture secret key: " ++ err) + Right (pkp, ska, skey, passphrase) + +reverseIf :: Bool -> [a] -> [a] +reverseIf shouldReverse xs + | shouldReverse = reverse xs + | otherwise = xs + +cgp :: DC.ConduitT B.ByteString Pkt (ResourceT IO) () +cgp = conduitGet (get :: Get Pkt) + +fp :: Text -> Fingerprint +fp = either error id . parseFingerprint + +doPkeyAndSkeyMatch :: PKey -> SKey -> Assertion +doPkeyAndSkeyMatch (RSAPubKey (RSA_PublicKey rpub)) (RSAPrivateKey (RSA_PrivateKey rpriv)) = + assertEqual + "RSA private key matches RSA public key" + rpub + (RSA.private_pub rpriv) +doPkeyAndSkeyMatch (ECDSAPubKey (ECDSA_PublicKey ecpub)) (ECDSAPrivateKey (ECDSA_PrivateKey ecpriv)) = + assertEqual + "ECDSA private key curve matches ECDSA public key curve" + (ECDSA.public_curve ecpub) + (ECDSA.private_curve ecpriv) +doPkeyAndSkeyMatch _ _ = assertFailure "matching unimplemented" + +{-# NOINLINE secretKeyInfoCacheRef #-} +secretKeyInfoCacheRef + :: IORef [(([Pkt], BL.ByteString), [PKESKRecipientKey])] +secretKeyInfoCacheRef = unsafePerformIO (newIORef []) + +collectSecretKeyInfos + :: [Pkt] -> BL.ByteString -> IO [PKESKRecipientKey] +collectSecretKeyInfos pkts passphrase = do + cache <- readIORef secretKeyInfoCacheRef + case lookup (pkts, passphrase) cache of + Just cached -> pure cached + Nothing -> do + keyInfos <- computeSecretKeyInfos + modifyIORef' + secretKeyInfoCacheRef + (((pkts, passphrase), keyInfos) :) + pure keyInfos + where + computeSecretKeyInfos = do + let keyInfoResults = map toKeyInfo pkts + keyInfos = catMaybes [mKeyInfo | Right mKeyInfo <- keyInfoResults] + unlockErrors = [err | Left err <- keyInfoResults] + unless (null unlockErrors) $ + assertFailure + ( "one or more secret key packets failed to unlock (partial failures are surfaced to\ + \ prevent silent key-context gaps):\n" + ++ unlines unlockErrors + ) + pure keyInfos + + toKeyInfo (SecretKeyPkt pkp ska) = decryptToRecipientKey "SecretKeyPkt" pkp ska + toKeyInfo (SecretSubkeyPkt pkp ska) = decryptToRecipientKey "SecretSubkeyPkt" pkp ska + toKeyInfo _ = Right Nothing + + decryptToRecipientKey contextLabel pkp ska = + case ska of + SUUnencrypted skey _ -> + Right + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just pkp + , pkeskRecipientSKey = skey + } + ) + ) + _ -> + case decryptPrivateKey (pkp, ska) passphrase of + Right (SUUnencrypted skey _) -> + Right + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just pkp + , pkeskRecipientSKey = skey + } + ) + ) + Right decryptedSKA -> + Left + ( contextLabel + ++ " " + ++ show (fingerprint pkp) + ++ ": decryptPrivateKey returned unexpected protection: " + ++ show decryptedSKA + ) + Left err -> + Left + ( contextLabel + ++ " " + ++ show (fingerprint pkp) + ++ ": decryptPrivateKey failed: " + ++ err + ) + +signSubkeyRevocationWithRSAAt + :: SomePKPayload + -> SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> IO SignaturePayload +signSubkeyRevocationWithRSAAt signer subkey signingKey creationTime = do + (hashed, unhashed) <- + messageIssuerSubpacketsAt signer creationTime + case signSubkeyRevocationWithRSA + signer + subkey + hashed + unhashed + signingKey of + Left err -> + assertFailure + ("failed to sign subkey revocation: " ++ renderSignError err) + >> fail "expected subkey revocation signature" + Right sigPayload -> pure sigPayload + +signSubkeyBindingWithRSAAt + :: SomePKPayload + -> SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> IO SignaturePayload +signSubkeyBindingWithRSAAt signer subkey signingKey creationTime = do + signSubkeyBindingWithRSAExtrasAt + signer + subkey + signingKey + creationTime + [] + +signDirectKeyWithRSAExtrasAt + :: SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signDirectKeyWithRSAExtrasAt signer signingKey creationTime hashedExtras = do + (hashed, unhashed) <- + messageIssuerSubpacketsAt signer creationTime + case signDirectKeyWithRSA + SignatureDirectlyOnAKey + signer + (hashedExtras ++ hashed) + unhashed + signingKey of + Left err -> + assertFailure + ( "failed to sign direct key self-signature: " + ++ renderSignError err + ) + >> fail "expected direct key self-signature" + Right sigPayload -> pure sigPayload + +signSubkeyBindingWithRSAExtrasAt + :: SomePKPayload + -> SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signSubkeyBindingWithRSAExtrasAt signer subkey signingKey creationTime hashedExtras = do + (hashed, unhashed) <- + messageIssuerSubpacketsAt signer creationTime + let bindingPayload = + payloadForSig + SubkeyBindingSig + emptyPSC + { lastPrimaryKey = PublicKeyPkt signer + , lastSubkey = PublicSubkeyPkt subkey + } + case signDataWithRSA + SubkeyBindingSig + signingKey + (hashedExtras ++ hashed) + unhashed + bindingPayload of + Left err -> + assertFailure + ("failed to sign subkey binding: " ++ renderSignError err) + >> fail "expected subkey binding signature" + Right sigPayload -> pure sigPayload + +verifyTimelinePackets + :: PublicKeyring + -> BL.ByteString + -> SignaturePayload + -> [Either VerificationError Verification] +verifyTimelinePackets keyring payload sigPayload = + verifyMessagePackets + defaultVerificationOptions + { verificationPolicy = VerifyStrict + , verificationMode = VerificationBatch + } + keyring + [ LiteralDataPkt BinaryData BL.empty 0 payload + , SignaturePkt sigPayload + ] + +assertSingleSignerFingerprint + :: String + -> Fingerprint + -> [Either VerificationError Verification] + -> Assertion +assertSingleSignerFingerprint label expected results = + case results of + [Right verification] -> + assertEqual + label + expected + (fingerprint (_verificationSigner verification)) + other -> + assertFailure + ( label + ++ ", expected one successful verification result, got " + ++ show (length other) + ++ " result(s)" + ) + +assertSingleFailureContainsTimeline + :: String + -> String + -> [Either VerificationError Verification] + -> Assertion +assertSingleFailureContainsTimeline label needle results = + case results of + [Left err] -> + assertBool + label + (needle `isInfixOf` renderVerificationError err) + other -> + assertFailure + ( label + ++ ", expected one verification failure result, got " + ++ show (length other) + ++ " result(s)" + ) + +signCertificationWithEd25519At + :: SomePKPayload + -> SomePKPayload + -> Ed25519.SecretKey + -> UserId + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signCertificationWithEd25519At certifiedSigner certifierSigner signingKey uid creationTime hashedExtras = do + (hashed, unhashed) <- + messageIssuerSubpacketsAt certifierSigner creationTime + let state = + emptyPSC + { lastPrimaryKey = PublicKeyPkt certifiedSigner + , lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText) + } + case signDataWithEd25519 + GenericCert + signingKey + (hashedExtras ++ hashed) + unhashed + (payloadForSig GenericCert state) of + Left err -> + assertFailure + ("failed to sign Ed25519 certification: " ++ renderSignError err) + >> fail "expected Ed25519 certification signature" + Right sigPayload -> pure sigPayload + +signCertificationRevocationWithEd25519At + :: SomePKPayload + -> SomePKPayload + -> Ed25519.SecretKey + -> UserId + -> ThirtyTwoBitTimeStamp + -> [SigSubPacket] + -> IO SignaturePayload +signCertificationRevocationWithEd25519At certifiedSigner certifierSigner signingKey uid creationTime hashedExtras = do + (hashed, unhashed) <- + messageIssuerSubpacketsAt certifierSigner creationTime + let state = + emptyPSC + { lastPrimaryKey = PublicKeyPkt certifiedSigner + , lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText) + } + case signDataWithEd25519 + CertRevocationSig + signingKey + (hashedExtras ++ hashed) + unhashed + (payloadForSig CertRevocationSig state) of + Left err -> + assertFailure + ( "failed to sign Ed25519 certification revocation: " + ++ renderSignError err + ) + >> fail "expected Ed25519 certification revocation signature" + Right sigPayload -> pure sigPayload + +signKeyRevocationWithReasonAt + :: SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> RevocationCode + -> IO SignaturePayload +signKeyRevocationWithReasonAt signer signingKey creationTime reasonCode = + signKeyRevocationWithReasonAndExtrasAt + signer + signingKey + creationTime + reasonCode + [] + +signKeyRevocationWithReasonAndExtrasAt + :: SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> RevocationCode + -> [SigSubPacket] + -> IO SignaturePayload +signKeyRevocationWithReasonAndExtrasAt signer signingKey creationTime reasonCode hashedExtras = do + (hashed, unhashed) <- + messageIssuerSubpacketsAt signer creationTime + case signKeyRevocationWithRSA + signer + ( SigSubPacket False (ReasonForRevocation reasonCode "") + : hashedExtras + ++ hashed + ) + unhashed + signingKey of + Left err -> + assertFailure + ("failed to sign key revocation: " ++ renderSignError err) + >> fail "expected key revocation signature" + Right sigPayload -> pure sigPayload + +signBinaryMessageWithRSAAt + :: SomePKPayload + -> RSA.PrivateKey + -> ThirtyTwoBitTimeStamp + -> BL.ByteString + -> IO SignaturePayload +signBinaryMessageWithRSAAt signer signingKey creationTime payload = do + (hashed, unhashed) <- + messageIssuerSubpacketsAt signer creationTime + case signDataWithRSA BinarySig signingKey hashed unhashed payload of + Left err -> + assertFailure + ("failed to sign RSA message payload: " ++ renderSignError err) + >> fail "expected RSA message signature" + Right sigPayload -> pure sigPayload + +signBinaryMessageWithEd25519At + :: SomePKPayload + -> Ed25519.SecretKey + -> ThirtyTwoBitTimeStamp + -> BL.ByteString + -> IO SignaturePayload +signBinaryMessageWithEd25519At signer signingKey creationTime payload = do + (hashed, unhashed) <- + messageIssuerSubpacketsAt signer creationTime + case signDataWithEd25519 BinarySig signingKey hashed unhashed payload of + Left err -> + assertFailure + ("failed to sign Ed25519 message payload: " ++ renderSignError err) + >> fail "expected Ed25519 message signature" + Right sigPayload -> pure sigPayload diff --git a/tests/Tests/Encryption.hs b/tests/Tests/Encryption.hs --- a/tests/Tests/Encryption.hs +++ b/tests/Tests/Encryption.hs @@ -2,5090 +2,7236 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} - -module Tests.Encryption (encryptionAndCompressionTests) where - -import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA -import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..)) -import Codec.Encryption.OpenPGP.BlockCipher (keySize, withSymmetricCipher) -import Codec.Encryption.OpenPGP.CFB -import Codec.Encryption.OpenPGP.Compression (CompressionError(..), compressPkts, decompressPkt) -import Codec.Encryption.OpenPGP.Encrypt - ( PKESKEncryptError(InvalidRecipientIdentifier, InvalidRecipientKeyMaterial, PayloadBuildFailure, RecipientCapabilitySelectionFailure, RecipientKdfFailure, UnsupportedRecipientAlgorithm) - , RecipientCapabilityError(RecipientCapabilityMissingSEIPDv1Support, RecipientCapabilityNoCommonAEADAlgorithms, RecipientCapabilityNoCommonSymmetricAlgorithms, RecipientCapabilityNoEncryptableKeyMaterialInTK) - , RecipientCapabilityNegotiationMode(..) - , PassphraseSKESKVersionPolicy(..) - , PassphraseEncryptRequest(..) - , EncryptCompatibilityProfile(..) - , RecipientCapabilities(..) - , RecipientEncryptionTargetRejected(..) - , RecipientEncryptionTargetsReport(..) - , RecipientTargetRejectionReason(..) - , RecipientTargetSelectionPolicy(..) - , RecipientPKESKVersionStrategy(..) - , RecipientEncryptionTarget(..) - , RecipientPayloadShape(..) - , RecipientEncryptRequest(..) - , RecipientEncryptRequestOverrides(..) - , defaultRecipientPayloadShape - , RecipientEncryptResult(..) - , PKESKVersionPolicy(..) - , pkeskSessionAlgorithm - , pkeskV3SessionMaterial - , buildPKESKv3PayloadForRecipient - , buildPKESKPayloadForRecipient - , canonicalizePKESKRecipientId - , encryptSEIPDv2Payload - , encryptForRecipients - , encryptForRecipientsLegacy - , encryptForRecipientsWithCapabilityNegotiation - , encryptPassphraseWithPolicy - , recipientCapabilitiesFromSubpacketPayloads - , recipientEncryptionTargetFromTKAtTimestamp - , recipientEncryptionTargetFromTKAtTimestampWithPolicy - , recipientEncryptionTargetsFromTKAtTimestamp - , recipientEncryptionTargetsReportFromTKAtTimestamp - , recipientEncryptionTargetFromTK - , recipientEncryptionTargetsFromTK - , recipientEncryptionTarget - , recipientEncryptionTargetWithCapabilities - , recipientEncryptionTargetWithStrategy - , recipientVersionStrategyForProfile - ) -import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) -import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..)) -import Codec.Encryption.OpenPGP.Internal (point2MBS) -import Codec.Encryption.OpenPGP.Message - ( SessionMaterialExposure(..) - , encryptedPayloadBytes - , mkClearPayload - , mkPassphrase - ) -import Codec.Encryption.OpenPGP.Policy - ( OpenPGPPolicy(..) - , OpenPGPRFC(..) - , defaultDecryptPolicy - , defaultPolicy - , lenientDecryptPolicy - , policyForRFC - ) -import Codec.Encryption.OpenPGP.S2K - ( EncodedSessionKeyError(..) - , S2KError(..) - , decodeOpenPGPEncodedSessionKey - , renderS2KError - , skesk2SessionKey - , string2Key - ) -import Codec.Encryption.OpenPGP.Serialize (parsePkts) -import Codec.Encryption.OpenPGP.SecretKey - ( decryptPrivateKey - , encryptPrivateKeyWithPolicyAndSaltAndIV - ) -import Codec.Encryption.OpenPGP.Types -import Control.Exception.Base (SomeException, catch, try) -import Control.Monad (void) -import Control.Monad.Trans.Resource (ResourceT) -import qualified Crypto.Error as CE -import Crypto.Number.ModArithmetic (inverse) -import Crypto.Number.Serialize (i2osp, os2ip) -import qualified Crypto.PubKey.Curve25519 as C25519 -import qualified Crypto.PubKey.Curve448 as C448 -import qualified Crypto.PubKey.ECC.DH as ECCDH -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.ECC.Generate as ECCGen -import qualified Crypto.PubKey.ECC.Types as ECCT -import Crypto.PubKey.ECC.Prim (pointBaseMul) -import qualified Crypto.PubKey.RSA.PKCS15 as P15 -import qualified Crypto.PubKey.RSA as RSA -import Data.Binary.Get - ( Get - ) -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 qualified Data.ByteString.Base16.Lazy as B16L -import Data.Char (toUpper) -import qualified Data.Conduit as DC -import Data.Conduit (fuseBoth) -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL -import Data.Conduit.OpenPGP.Compression (conduitCompress) -import Data.Conduit.OpenPGP.Decrypt - ( DecryptKeyResolution(..) - , DecryptOptions(..) - , DecryptOutcome(..) - , PKESKRecipientKey(..) - ) -import qualified Data.Conduit.OpenPGP.Decrypt as DCD -import Data.Conduit.OpenPGP.Keyring - ( conduitToSomeTKsDropping - , conduitToSomeTKsDroppingEither - , conduitToSomeTKsEither - , conduitToTKsDropping - , conduitToTKsDroppingEither - , conduitToTKsEither - , conduitToUnknownTKs - ) -import Data.Conduit.Serialization.Binary (conduitGet) -import Data.Binary (get, put) -import Data.Binary.Put (putWord16be, runPut) -import Data.Word (Word16) -import Data.List (find, isInfixOf) -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (listToMaybe) -import qualified Data.Set as Set -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) -import Tests.Common - ( aesKeyWrapRFC3394ForTest - , armorPayload - , assertX25519EskShape - , assertX448EskShape - , buildCurve25519LegacyKdfParamForTest - , buildECDHKDFParamForTest - , cgp - , collectSecretKeyInfos - , conduitDecrypt - , conduitDecryptChecked - , conduitDecryptCheckedWithDecryptPolicy - , conduitDecryptWithCandidatesCallbackAndPolicy - , conduitDecryptWithDecryptPolicy - , conduitDecryptWithPKESKContext - , deriveECDHKekForTest - , deriveX25519KekForTest - , deriveX448KekForTest - , doPkeyAndSkeyMatch - , encodeChecksum16 - , encryptMessageDefault - , fixturePath - , forceVersionedRecipientIdentifier - , isPrecedingESK - , loadArmor - , loadDeterministicEd25519Signer - , loadSEIPDv2FixtureWithV4Secret - , loadUnencryptedRsaSigner - , mkPKESKSessionMaterialOrFail - , prependUnusableLatestPKESK - , readFixtureLazy - , readFixtureStrict - , readFixturePackets - , readPKIPassphrase - , reorderPrecedingPKESKs - , runGet - , selectRecipientKeyInfo - , selectRecipientKeyInfoByRawRecipientId - , setKeyTimestamp - , setKeyVersion - , signDirectKeyWithRSAExtrasAt - , signSubkeyBindingWithRSAExtrasAt - , signSubkeyRevocationWithRSAAt - , testEncodeOpenPGPSessionMaterial - , testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized - , testSEIPDv2ForV4KeyArmor - , testSEIPDv2TwoRecipientsArmor - , testSEIPDv2ThreeRecipientsArmor - ) - -mkLegacySymmetricCase :: (String, Bool, FilePath, FilePath, BL.ByteString) -> TestTree -mkLegacySymmetricCase (label, expectSEIPDv1, encFile, passFile, cleartext) = - testCase label (testLegacySymmetricEncryption expectSEIPDv1 encFile passFile cleartext) - -legacySymmetricCases :: [(String, Bool, FilePath, FilePath, BL.ByteString)] -legacySymmetricCases = - [ ("Symmetric Encryption simple S2K SHA1 3DES, no MDC", False, "encryption-sym-3des-s2k0.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted S2K SHA1 3DES, no MDC", False, "encryption-sym-3des.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption simple S2K SHA1 3DES", True, "encryption-sym-3des-mdc-s2k0.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted S2K SHA1 3DES", True, "encryption-sym-3des-mdc.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption simple S2K SHA1 CAST5, no MDC", False, "encryption-sym-cast5-s2k0.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted S2K SHA1 CAST5, no MDC", False, "encryption-sym-cast5.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption simple S2K SHA1 CAST5", True, "encryption-sym-cast5-mdc-s2k0.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted S2K SHA1 CAST5", True, "encryption-sym-cast5-mdc.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption simple S2K SHA1 Blowfish, no MDC", False, "encryption-sym-blowfish-s2k0.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted S2K SHA1 Blowfish, no MDC", False, "encryption-sym-blowfish.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption simple S2K SHA1 Blowfish", True, "encryption-sym-blowfish-mdc-s2k0.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted S2K SHA1 Blowfish", True, "encryption-sym-blowfish-mdc.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption simple S2K SHA1 AES128", True, "encryption-sym-aes128-s2k0.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted S2K SHA1 AES128", True, "encryption-sym-aes128.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption simple S2K SHA1 AES192", True, "encryption-sym-aes192-s2k0.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted S2K SHA1 AES192", True, "encryption-sym-aes192.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption simple S2K SHA1 AES256", True, "encryption-sym-aes256-s2k0.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted S2K SHA1 AES256", True, "encryption-sym-aes256.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted S2K SHA256 AES256", True, "encryption-sym-aes256-sha256.pgp", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption simple S2K SHA1 Twofish", True, "encryption-sym-twofish-s2k0.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted S2K SHA1 Twofish", True, "encryption-sym-twofish.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption simple Camellia128", True, "encryption-sym-camellia128-s2k0.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted Camellia128", True, "encryption-sym-camellia128.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted Camellia192", True, "encryption-sym-camellia192.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption iterated-salted Camellia256", True, "encryption-sym-camellia256.gpg", "symmetric-password.txt", "test\n") - , ("Symmetric Encryption pgcrypto", True, "encryption-sym-pgcrypto.pgp", "pgcrypto-passphrase.txt", "{\"t\":\"plus\"}") - ] - -mkStrictSymmetricCase :: (String, FilePath, FilePath, BL.ByteString) -> TestTree -mkStrictSymmetricCase (label, encFile, passFile, cleartext) = - testCase label (testSymmetricEncryption encFile passFile cleartext) - -strictSymmetricCases :: [(String, FilePath, FilePath, BL.ByteString)] -strictSymmetricCases = - [ ("strict policy AES128 iterated-salted S2K SEIPDv1", "encryption-sym-aes128.gpg", "symmetric-password.txt", "test\n") - , ("strict policy AES192 iterated-salted S2K SEIPDv1", "encryption-sym-aes192.gpg", "symmetric-password.txt", "test\n") - , ("strict policy AES256 iterated-salted S2K SEIPDv1", "encryption-sym-aes256.gpg", "symmetric-password.txt", "test\n") - ] - -mkSyntheticNISTP256 :: B.ByteString -> (ECDSA.PublicKey, ECDSA.PrivateKey) -mkSyntheticNISTP256 bs = - let curve = ECCT.getCurveByName ECCT.SEC_p256r1 - d = os2ip (B.pack [1 .. 32]) - q = pointBaseMul curve d - pub = ECDSA.PublicKey curve q - priv = ECDSA.PrivateKey curve d - in (pub, priv) - -syntheticNISTP256Low = mkSyntheticNISTP256 $ B.pack [1 .. 32] -syntheticNISTP256High = mkSyntheticNISTP256 $ B.pack [101 .. 132] - -encryptionAndCompressionTests :: TestTree -encryptionAndCompressionTests = - testGroup - "Encryption and compression" - [ testGroup - "Compression group" - [ testCase "compressedsig.gpg" (testCompression "compressedsig.gpg") - , testCase - "compressedsig-zlib.gpg" - (testCompression "compressedsig-zlib.gpg") - , testCase - "compressedsig-bzip2.gpg" - (testCompression "compressedsig-bzip2.gpg") - , testCase - "decompressPkt classifies empty ZIP payload" - (assertEqual "empty ZIP" - (Left (EmptyCompressedPayload ZIP)) - (decompressPkt (CompressedDataPkt ZIP ""))) - , testCase - "decompressPkt classifies empty Uncompressed payload" - (assertEqual "empty Uncompressed" - (Left (EmptyCompressedPayload Uncompressed)) - (decompressPkt (CompressedDataPkt Uncompressed ""))) - , testCase - "decompressPkt classifies marker-only ZIP payload" - (let markerPkt = MarkerPkt "\x50\x47\x50" - compressed = compressPkts ZIP [markerPkt] - in assertEqual "marker-only" - (Left (MarkerOnlyPayload ZIP)) - (decompressPkt compressed)) - , testCase - "decompressPkt passes through non-compressed packets" - (let pkt = OtherPacketPkt 255 "" - in assertEqual "passthrough" - (Right [pkt]) - (decompressPkt pkt)) - ] - , testGroup - "Conduit length group" - [ testCase - "conduitCompress (ZIP)" - (testConduitOutputLength - "pubring.gpg" - (cgp DC..| conduitCompress ZIP) - 1) - , testCase - "conduitCompress (Zlib)" - (testConduitOutputLength - "pubring.gpg" - (cgp DC..| conduitCompress ZLIB) - 1) - , testCase - "conduitCompress (BZip2)" - (testConduitOutputLength - "pubring.gpg" - (cgp DC..| conduitCompress BZip2) - 1) - , testCase - "conduitToUnknownTKs" - (testConduitOutputLength "pubring.gpg" (cgp DC..| conduitToUnknownTKs) 4) - , testCase - "conduitToTKsDropping" - (testConduitOutputLength - "pubring.gpg" - (cgp DC..| conduitToTKsDropping) - 4) - , testCase - "conduitToSomeTKsDropping" - (testConduitOutputLength - "pubring.gpg" - (cgp DC..| conduitToSomeTKsDropping) - 4) - , testCase - "conduitToTKsEither reports parse failures" - testConduitToTKsEitherReportsParseFailure - , testCase - "conduitToSomeTKsEither reports parse failures" - testConduitToSomeTKsEitherReportsParseFailure - , testCase - "conduitToTKsDroppingEither reports parse failures" - testConduitToTKsDroppingEitherReportsParseFailure - , testCase - "conduitToSomeTKsDroppingEither reports parse failures" - testConduitToSomeTKsDroppingEitherReportsParseFailure - ] - , testGroup - "Encrypted data" - ( [ testCase - "Legacy symmetric encryption fixture shape" - testLegacyEncryptionFixtureShape - , testCase - "SEIPDv1 resync nonce/MDC roundtrip" - testSEIPDv1ResyncNonceMdcRoundTrip - ] - ++ map mkLegacySymmetricCase legacySymmetricCases - ++ map mkStrictSymmetricCase strictSymmetricCases - ++ [ - testCase - "strict policy rejects SED (no MDC)" - (testStrictPolicyRejectsEncryption - "encryption-sym-cast5.gpg" - "symmetric-password.txt" - "unauthenticated SED") - , testCase - "strict policy rejects Simple S2K" - (testStrictPolicyRejectsEncryption - "encryption-sym-aes128-s2k0.gpg" - "symmetric-password.txt" - "Simple S2K specifier") - , testCase - "strict policy rejects non-encrypted packet after ESK prelude" - testRejectsNonEncryptedAfterESKPrelude - , testCase - "strict policy rejects SEIPDv2 with only misaligned ESK versions" - testRejectsMisalignedESKVersionForSEIPDv2 - , testCase - "strict policy discards misaligned ESK when aligned ESK is present" - testDiscardsMisalignedESKWhenAlignedCandidateExists - , testCase - "strict policy rejects trailing data after SEIPD v2" - testTrailingDataRejectedStrictSEIPDv2 - , testCase - "lenient policy reports DecryptTrailingData for trailing packet after SEIPD v2" - testTrailingDataReportedLenientSEIPDv2 - , testCase - "conduitDecryptChecked reports DecryptClean for well-formed SEIPD v2" - testDecryptCleanSEIPDv2 - , testCase - "conduitDecrypt matches conduitDecryptChecked (default)" - testOptionsMatchesCheckedDefaultSEIPDv2 - , testCase - "conduitDecrypt matches legacy conduitDecrypt output (default)" - testOptionsMatchesLegacyDefaultOutputSEIPDv2 - , testCase - "conduitDecrypt matches checked lenient trailing behavior" - testOptionsMatchesCheckedLenientTrailingSEIPDv2 - ] ) - , testGroup - "Encrypted secret keys" - [ testCase - "SUSSHA1 CAST5 IteratedSalted SHA1 RSA" - (testSecretKeyDecryption "simple.seckey" "pki-password.txt") - , testCase - "SUS16bit CAST5 IteratedSalted SHA1 RSA" - (testSecretKeyDecryption "16bitcksum.seckey" "pki-password.txt") - , testCase - "SUSSHA1 AES256 IteratedSalted SHA512 RSA" - (testSecretKeyDecryption "aes256-sha512.seckey" "pki-password.txt") - , testCase - "SUSSHA1 AES128 IteratedSalted SHA256 ECDSA" - (testSecretKeyDecryption - "nist_p-256_secretkey.gpg" - "pki-password.txt") - ] - , testGroup - "Encrypting secret keys" - [ testCase - "legacy secret key encryption rejects implicit SHA-1 protection" - (testLegacySecretKeyEncryptionRejected - "unencrypted.seckey" - "pki-password.txt") - , testCase - "SUSym secret key roundtrips" - testSUSymSecretKeyRoundTrip - , testCase - "v6 secret key encryption roundtrips with SUSAEAD" - testV6SecretKeyEncryptionRoundTrip - , testCase - "v4 AEAD OCB secret key compatibility roundtrip" - testV4SecretKeyAEADOCBRoundTripCompat - ] - , testGroup - "decrypt conduit stuff" - [ testCase - "conduitDecrypt supports PKESKv6 with raw session-key callback" - testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey - , testCase - "conduitDecrypt rejects invalid PKESKv6 raw session-key length" - testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength - , testCase - "conduitDecrypt unwraps PKESK RSA session keys in-library" - testConduitDecryptSEIPDv2WithPKESKRSAUnwrap - , testCase - "conduitDecrypt probes wildcard callback fallback for PKESKv3 RSA key-id packets" - testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback - , testCase - "conduitDecrypt unwraps PKESKv3 RSA session keys via SHA1-CFB protected key loaded from file" - testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey - , testCase - "parsed RSA secret key decrypts PKCS#1 v1.5 payload" - testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized - , testCase - "conduitDecrypt unwraps PKESK ECDH session keys in-library" - testConduitDecryptSEIPDv2WithPKESKECDHUnwrap - , testCase - "conduitDecrypt rejects ECDH ephemeral points with wrong curve length" - testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength - , testCase - "conduitDecrypt unwraps PKESKv3 X25519 session keys in-library" - testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap - , testCase - "conduitDecrypt retries wildcard PKESKv3 keys across callback order" - testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder - , testCase - "conduitDecrypt retries wildcard PKESKv3 keys across long callback order" - testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder - , testCase - "conduitDecrypt retries wildcard PKESKv3 keys across long callback order for SEIPDv1" - testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder - , testCase - "unwrap callback decrypts wildcard PKESKv3 via candidates list" - testMkCandidateResolverDecryptsWildcardPKESKv3 - , testCase - "conduitDecrypt wildcard resolver receives typed previous-failure diagnostics" - testConduitDecryptWildcardResolverProvidesTypedPreviousFailures - , testCase - "conduitDecryptWithReport surfaces wildcard resolver diagnostics" - testConduitDecryptWithReportCapturesWildcardResolverDiagnostics - , testCase - "conduitDecrypt rejects PKESKv3 X25519 ephemeral values with wrong length" - testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength - , testCase - "conduitDecrypt falls back from Argon2 SKESK to PKESKv3 X25519" - testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519 - , testCase - "conduitDecrypt retries earlier Argon2 SKESKs when latest is unusable" - testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK - , testCase - "conduitDecrypt rejects ECDH KDF/KEK params outside RFC9580 Table 30" - testConduitDecryptSEIPDv2RejectsECDHNonTable30Params - , testCase - "conduitDecrypt allows v4 Curve25519Legacy RFC6637 accepted parameters" - testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams - , testCase - "conduitDecrypt allows v4 Curve25519Legacy with truncated wrapped MPI" - testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI - , testCase - "conduitDecrypt keeps v6 Curve25519Legacy ECDH strict" - testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params - , testCase - "conduitDecrypt unwraps PKESK X448 session keys in-library" - testConduitDecryptSEIPDv2WithPKESKX448Unwrap - , testCase - "conduitDecrypt rejects PKESKv6 X448 ephemeral values with wrong length" - testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength - , testCase - "encrypt-side session material encoding uses OpenPGP format" - testEncodeOpenPGPSessionMaterial - , testCase - "encrypt-side PKESK builder wraps RSA recipient session key" - testBuildPKESKPayloadForRecipientRSA - , testCase - "encrypt-side PKESKv3 builder supports RSA v4 interop" - testBuildPKESKv3PayloadForRecipientRSAInterop - , testCase - "encrypt-side PKESKv3 builder supports v6 recipients" - testBuildPKESKv3PayloadForRecipientSupportsV6Key - , testCase - "encrypt-side PKESKv3 builder supports RFC6637 ECDH recipients" - testBuildPKESKv3PayloadForRecipientECDHInterop - , testCase - "PKESKv3 ECDH serializer uses RFC 6637 wire format" - testPKESKv3ECDHWireFormat - , testCase - "encrypt-side PKESKv3 builder supports RFC6637 Curve25519Legacy recipients" - testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop - , testCase - "encrypt-side PKESKv3 builder rejects non-RFC6637 Curve448Legacy recipients" - testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy - , testCase - "RFC 9580 v6 X25519 PKESK uses raw-key semantics, not v3-encoded material" - testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics - , testCase - "RFC 9580 v6 X448 PKESK uses raw-key semantics, not v3-encoded material" - testBuildPKESKv6PayloadForRecipientX448RawKeySemantics - , testCase - "encrypt-side policy builder emits PKESK3 for ForceV3Interop" - testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop - , testCase - "encrypt-side profile helper honors recipient capability hints" - testRecipientVersionStrategyForProfileHonorsHints - , testCase - "encryptForRecipients auto-detects mixed recipient PKESK strategies" - testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies - , testCase - "encryptForRecipients negotiates symmetric algorithm from recipient capabilities when enabled" - testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled - , testCase - "encryptForRecipients negotiates recipient capabilities by default" - testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault - , testCase - "encryptForRecipientsLegacy preserves capability negotiation opt-out" - testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut - , testCase - "encryptForRecipients capability negotiation fails when recipients share no symmetric algorithm" - testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm - , testCase - "recipientCapabilitiesFromSubpacketPayloads extracts preferred AEAD algorithms" - testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms - , testCase - "encryptForRecipients negotiates AEAD algorithm from recipient capabilities when enabled" - testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled - , testCase - "encryptForRecipients capability negotiation fails when recipients share no AEAD algorithm" - testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm - , testCase - "encryptForRecipients falls back to SEIPDv1 when recipients do not advertise SEIPDv2 support" - testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 - , testCase - "encryptForRecipients rejects SEIPDv1 when recipients do not advertise MDC support" - testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC - , testCase - "recipientEncryptionTargetsFromTK returns only encryption-capable candidates" - testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys - , testCase - "recipientEncryptionTargetFromTK prefers encryption-capable subkeys" - testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary - , testCase - "recipientEncryptionTargetFromTK rejects TKs without encryptable key material" - testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys - , testCase - "recipientEncryptionTargetsReportFromTKAtTimestamp reports sign-only subkey rejection reasons" - testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections - , testCase - "recipientEncryptionTargetsReportFromTKAtTimestamp reports unsupported algorithm rejections" - testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms - , testCase - "recipientEncryptionTargetsReportFromTKAtTimestamp rejects expired subkeys" - testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey - , testCase - "recipientEncryptionTargetsReportFromTKAtTimestamp rejects revoked subkeys" - testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey - , testCase - "recipientEncryptionTargetsFromTKAtTimestamp extracts effective self-signature capabilities" - testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities - , testCase - "recipientEncryptionTargetFromTKAtTimestamp filters subkey self-signatures by timestamp" - testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering - , testCase - "recipientEncryptionTargetFromTKAtTimestampWithPolicy can prefer primary key" - testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary - , testCase - "recipientEncryptionTargetFromTKAtTimestampWithPolicy can prefer newest key" - testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest - , testCase - "recipientEncryptionTargetsFromTK excludes subkeys with non-encrypt key flags" - testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags - , testCase - "recipientEncryptionTargetsFromTK includes subkeys with no key flags advertised" - testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags - , testCase - "encryptForRecipients optionally emits one-pass signature packets" - testEncryptRecipientsWithRequestEmitsOnePassSignatures - , testCase - "encryptForRecipients one-pass mode requires issuer metadata" - testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing - , testCase - "encryptForRecipients with EncryptInteropLegacy produces SEIPDv1 and PKESKv3" - testEncryptInteropLegacyProducesSEIPDv1 - , testCase - "encrypt-side PKESK builder reports unsupported recipient algorithms" - testBuildPKESKPayloadUnsupportedRecipient - , testCase - "encrypt-side ECDH PKESK builder rejects SHA1 KDF policy" - testBuildPKESKPayloadRejectsECDHSHA1 - , testCase - "encrypt-side canonicalize PKESK recipient id helper" - testCanonicalizePKESKRecipientIdHelper - , testCase - "conduitDecrypt decrypts seipdv2 fixture with matching v6 secret key" - testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey - , testCase - "seipdv2-for-v4-key fixture parses as PKESKv6+SEIPDv2" - testSEIPDv2ForV4KeyArmor - , testCase - "conduitDecrypt decrypts seipdv2-for-v4-key fixture with matching v4 secret key" - testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey - , testCase - "conduitDecrypt tries earlier PKESKs when latest is unusable" - testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK - , testCase - "conduitDecrypt matches valid recipient-id forms without caller retries" - testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations - , testCase - "conduitDecrypt fails PKESK exhaustion without manual session-key prompt" - testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial - , testCase - "seipdv2-two-recipients fixture parses as PKESKv6*2+SEIPDv2" - testSEIPDv2TwoRecipientsArmor - , testCase - "seipdv2-three-recipients fixture parses as PKESKv6*3+SEIPDv2" - testSEIPDv2ThreeRecipientsArmor - , testCase - "conduitDecrypt decrypts seipdv2-two-recipients fixture with matching v4 secret key" - testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey - , testCase - "conduitDecrypt decrypts reordered+bogus seipdv2-two-recipients PKESKs" - testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs - , testCase - "conduitDecrypt decrypts seipdv2-three-recipients fixture with matching v4 secret key" - testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey - , testCase - "conduitDecrypt decrypts reordered+bogus seipdv2-three-recipients PKESKs" - testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs - ] - , testGroup "ESK/SKESK/ArgonS2K" - [ testCase - "encoded session key rejects too-short payloads" - testDecodeOpenPGPEncodedSessionKeyRejectsTooShort - , testCase - "encoded session key rejects algorithm/key-length mismatches" - testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch - , testCase - "encoded session key rejects checksum mismatches" - testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch - , testCase "unknown SKESK version is rejected" testSKESKRejectsUnknownVersion - , testCase - "v4 SKESK encrypted session keys reject Simple S2K" - testSKESK4EncryptedSessionKeyRejectsSimpleS2K - , testCase - "v4 SKESK Argon2 encrypted ESK roundtrip across AES-128/192/256" - testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES - , testCase - "v4 SKESK Argon2 encrypted ESK rejects legacy checksum trailer" - testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum - , testCase - "passphrase SKESK policy ForceV4Interop emits SKESKv4 + SEIPDv1" - testEncryptPassphraseWithPolicyForceV4Interop - , testCase - "passphrase SKESK policy PreferV6 emits SKESKv6 + SEIPDv2" - testEncryptPassphraseWithPolicyPreferV6 - , testCase "Argon2 S2K derivation vector" testArgon2S2KVector - , testCase "Argon2 S2K Ord instance is total" testArgon2S2KOrdTotal - ] - - ] - -testCompression :: FilePath -> Assertion -testCompression fpr = do - bs <- BL.readFile $ "tests/data/" ++ fpr - let firstpass = fmap (concatMap (either (const []) id . decompressPkt) . unBlock) . runGet get $ bs - case firstpass of - Left _ -> assertFailure $ "First pass failed on " ++ fpr - Right [] -> - assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." - Right packs -> do - let roundtrip = runPut $ put . Block $ [compressPkts ZIP packs] - let secondpass = - fmap (concatMap (either (const []) id . decompressPkt) . unBlock) . runGet get $ roundtrip - if secondpass == Right [] - then assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing." - else assertEqual ("for " ++ fpr) firstpass secondpass - -counter :: Monad m => DC.ConduitT a DC.Void m Int -counter = CL.fold (const . (1 +)) 0 - -testConduitOutputLength :: - FilePath - -> DC.ConduitT B.ByteString b (ResourceT IO) () - -> Int - -> Assertion -testConduitOutputLength fpr c target = do - len <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ fpr) DC..| c DC..| counter - assertEqual ("expected length " ++ show target) target len - -testConduitToTKsEitherReportsParseFailure :: Assertion -testConduitToTKsEitherReportsParseFailure = do - results <- - DC.runConduitRes $ - CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" DC..| - conduitGet get DC..| conduitToTKsEither DC..| CL.consume - assertBool - "conduitToTKsEither should report parse failures for non-key packet streams" - (any (either (const True) (const False)) results) - -testConduitToTKsDroppingEitherReportsParseFailure :: Assertion -testConduitToTKsDroppingEitherReportsParseFailure = do - results <- - DC.runConduitRes $ - CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" DC..| - conduitGet get DC..| conduitToTKsDroppingEither DC..| CL.consume - assertBool - "conduitToTKsDroppingEither should report parse failures for non-key packet streams" - (any (either (const True) (const False)) results) - -testConduitToSomeTKsEitherReportsParseFailure :: Assertion -testConduitToSomeTKsEitherReportsParseFailure = do - results <- - DC.runConduitRes $ - CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" DC..| - conduitGet get DC..| conduitToSomeTKsEither DC..| CL.consume - assertBool - "conduitToSomeTKsEither should report parse failures for non-key packet streams" - (any (either (const True) (const False)) results) - -testConduitToSomeTKsDroppingEitherReportsParseFailure :: Assertion -testConduitToSomeTKsDroppingEitherReportsParseFailure = do - results <- - DC.runConduitRes $ - CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" DC..| - conduitGet get DC..| conduitToSomeTKsDroppingEither DC..| CL.consume - assertBool - "conduitToSomeTKsDroppingEither should report parse failures for non-key packet streams" - (any (either (const True) (const False)) results) - --- This needs a lot of work --- | Decrypt a symmetric-encrypted fixture using 'defaultDecryptPolicy' and --- assert the packet structure is SKESK + SEIPDv1 and the cleartext matches. --- Only suitable for AES-128/192/256 fixtures with iterated-salted S2K. -testSymmetricEncryption :: FilePath -> FilePath -> BL.ByteString -> Assertion -testSymmetricEncryption encfile passfile cleartext = do - passphrase <- readFixtureLazy passfile - pt <- readFixturePackets encfile - assertEqual "wrong number of packets" 2 (length pt) - skesk <- - case pt of - [] -> assertFailure ("expected SKESK packet in " ++ encfile ++ " but packet list was empty") >> fail "empty fixture packet list" - (firstPkt:_) -> - case (fromPktEither firstPkt :: Either String (SKESK 'SKESKV4)) of - Left err -> assertFailure ("failed to coerce first packet to SKESK: " ++ err) >> fail err - Right x -> pure x - assertEqual "first packet should be SKESK" SKESKType (packetType skesk) - case last pt of - SymEncIntegrityProtectedDataPkt (SEIPD1 1 _) -> pure () - other -> - assertFailure - ("second packet should be SEIPDv1 (tag 18, version 1), got: " ++ show other) - decrypted <- - catch - (DC.runConduitRes $ - CL.sourceList pt DC..| conduitDecrypt (fakeCallback passphrase) DC..| - CL.consume) - (\e -> do - let err = show (e :: SomeException) - assertFailure ("decryption threw exception: " ++ err)) - payload <- - case decrypted of - [] -> - assertFailure ("decryption produced no packets for " ++ encfile) >> - fail "expected decrypted literal packet" - (firstDecrypted:_) -> - case (fromPktEither firstDecrypted :: Either String LiteralData) of - Left err -> - assertFailure ("failed to coerce decrypted packet to literal data: " ++ err) >> - fail err - Right x -> pure (_literalDataPayload x) - assertEqual ("cleartext for " ++ encfile) cleartext payload - where - fakeCallback :: BL.ByteString -> String -> IO BL.ByteString - fakeCallback = const . return - -testSEIPDv1ResyncNonceMdcRoundTrip :: Assertion -testSEIPDv1ResyncNonceMdcRoundTrip = do - let sa = AES256 - keyBytes = B.pack [0..31] - iv = IV (B.pack [32..47]) - cleartext = B.pack [1..80] - cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext - ciphertext <- - either - (\e -> assertFailure ("encryptOpenPGPCfbRaw failed: " ++ show e) >> pure mempty) - pure - (encryptOpenPGPCfbRaw OpenPGPCFBResyncW sa iv cleartextWithMDC keyBytes) - (nonce, decrypted) <- - either - (\e -> assertFailure ("decryptOpenPGPCfbWithNonce failed: " ++ show e) >> pure (mempty, mempty)) - pure - (decryptOpenPGPCfbWithNonce sa ciphertext keyBytes) - assertEqual - "SEIPDv1 nonce should match IV||IV[-2:]" - (seipdv1NonceFromIV iv) - nonce - assertEqual - "decrypted bytes should include payload+MDC" - cleartextWithMDC - decrypted - payloadOut <- - either - (\err -> assertFailure ("validateSEIPD1MDC failed: " ++ err) >> pure mempty) - pure - (validateSEIPD1MDC nonce decrypted) - assertEqual "MDC-verified payload should round-trip" cleartext payloadOut - --- | Like 'testSymmetricEncryption' but uses 'lenientDecryptPolicy' to permit --- legacy RFC4880/RFC2440 message formats (SED, deprecated S2K, old ciphers). --- The 'Bool' indicates whether the fixture uses SEIPDv1 (True) or SED (False). -testLegacySymmetricEncryption :: Bool -> FilePath -> FilePath -> BL.ByteString -> Assertion -testLegacySymmetricEncryption expectSEIPDv1 encfile passfile cleartext = do - passphrase <- readFixtureLazy passfile - pt <- readFixturePackets encfile - assertEqual "wrong number of packets" 2 (length pt) - skesk <- - case pt of - [] -> assertFailure ("expected SKESK packet in " ++ encfile ++ " but packet list was empty") >> fail "empty fixture packet list" - (firstPkt:_) -> - case (fromPktEither firstPkt :: Either String (SKESK 'SKESKV4)) of - Left err -> assertFailure ("failed to coerce first packet to SKESK: " ++ err) >> fail err - Right x -> pure x - assertEqual "first packet should be SKESK" SKESKType (packetType skesk) - case last pt of - SymEncDataPkt {} - | not expectSEIPDv1 -> pure () - | otherwise -> - assertFailure "expected SEIPDv1 packet (tag 18) but got SED (tag 9)" - SymEncIntegrityProtectedDataPkt (SEIPD1 1 _) - | expectSEIPDv1 -> pure () - | otherwise -> - assertFailure "expected SED packet (tag 9) but got SEIPDv1 (tag 18)" - other -> assertFailure ("unexpected second packet: " ++ show other) - decrypted <- - catch - (DC.runConduitRes $ - CL.sourceList pt DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) (fakeCallback passphrase) DC..| - CL.consume) - (\e -> do - let err = show (e :: SomeException) - assertFailure ("decryption threw exception: " ++ err)) - payload <- - case decrypted of - [] -> - assertFailure ("decryption produced no packets for " ++ encfile) >> - fail "expected decrypted literal packet" - (firstDecrypted:_) -> - case (fromPktEither firstDecrypted :: Either String LiteralData) of - Left err -> - assertFailure ("failed to coerce decrypted packet to literal data: " ++ err) >> - fail err - Right x -> pure (_literalDataPayload x) - assertEqual ("cleartext for " ++ encfile) cleartext payload - where - fakeCallback :: BL.ByteString -> String -> IO BL.ByteString - fakeCallback = const . return - --- | Assert that decrypting with the strict 'defaultDecryptPolicy' throws an --- exception whose message contains the given substring. -testStrictPolicyRejectsEncryption :: FilePath -> FilePath -> String -> Assertion -testStrictPolicyRejectsEncryption encfile passfile expectedFragment = do - passphrase <- readFixtureLazy passfile - pt <- readFixturePackets encfile - result <- - try - (DC.runConduitRes $ - CL.sourceList pt DC..| - conduitDecrypt (fakeCallback passphrase) DC..| - CL.consume) :: IO (Either SomeException [Pkt]) - case result of - Right _ -> - assertFailure $ - "Expected strict policy to reject '" ++ encfile ++ - "' with error containing '" ++ expectedFragment ++ "', but decryption succeeded" - Left err -> - assertBool - ("Expected error containing '" ++ expectedFragment ++ - "', got: " ++ show err) - (expectedFragment `isInfixOf` show err) - where - fakeCallback :: BL.ByteString -> String -> IO BL.ByteString - fakeCallback = const . return - --- | Decrypt a file and check the 'DecryptOutcome'. -testDecryptOutcome :: FilePath -> FilePath -> DecryptOutcome -> Assertion -testDecryptOutcome encfile passfile expectedOutcome = do - passphrase <- readFixtureLazy passfile - pt <- readFixturePackets encfile - (outcome, _pkts) <- - catch - (DC.runConduitRes $ - CL.sourceList pt DC..| - fuseBoth (conduitDecryptChecked (fakeCallback passphrase)) CL.consume) - (\e -> do - let err = show (e :: SomeException) - assertFailure ("decryption threw unexpected exception: " ++ err) - fail "unreachable") - assertEqual - ("DecryptOutcome for " ++ encfile) - expectedOutcome - outcome - where - fakeCallback :: BL.ByteString -> String -> IO BL.ByteString - fakeCallback = const . return - --- | Build a synthetic packet list with an appended trailing packet, decrypt --- with lenient policy, and verify 'DecryptTrailingData' is reported. -testTrailingDataReportedLenient :: FilePath -> FilePath -> Assertion -testTrailingDataReportedLenient encfile passfile = do - passphrase <- readFixtureLazy passfile - pt <- readFixturePackets encfile - let trailingPkt = OtherPacketPkt 0xFE "" - ptWithTrailing = pt ++ [trailingPkt] - (outcome, _pkts) <- - catch - (DC.runConduitRes $ - CL.sourceList ptWithTrailing DC..| - fuseBoth (conduitDecryptCheckedWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) (fakeCallback passphrase)) CL.consume) - (\e -> do - let err = show (e :: SomeException) - assertFailure ("lenient decrypt threw unexpected exception: " ++ err) - fail "unreachable") - assertEqual - ("DecryptTrailingData for " ++ encfile) - DecryptTrailingData - outcome - where - fakeCallback :: BL.ByteString -> String -> IO BL.ByteString - fakeCallback = const . return - --- | Same as above but with strict policy: should throw "after message --- integrity boundary". -testTrailingDataRejectedStrict :: FilePath -> FilePath -> Assertion -testTrailingDataRejectedStrict encfile passfile = do - passphrase <- readFixtureLazy passfile - pt <- readFixturePackets encfile - let trailingPkt = OtherPacketPkt 0xFE "" - ptWithTrailing = pt ++ [trailingPkt] - result <- - try - (DC.runConduitRes $ - CL.sourceList ptWithTrailing DC..| - fuseBoth (conduitDecryptChecked (fakeCallback passphrase)) CL.consume - ) :: IO (Either SomeException (DecryptOutcome, [Pkt])) - case result of - Left err -> - assertFailure ("Expected DecryptMalformedStructure but got exception: " ++ show err) - Right (DecryptMalformedStructure malformedReason, _) -> - assertBool - ("Expected 'after message integrity boundary', got: " ++ malformedReason) - ("after message integrity boundary" `isInfixOf` malformedReason) - Right (other, _) -> - assertFailure ("Expected DecryptMalformedStructure but got: " ++ show other) - where - fakeCallback :: BL.ByteString -> String -> IO BL.ByteString - fakeCallback = const . return - -encryptedSEIPDv2Packets :: IO [Pkt] -encryptedSEIPDv2Packets = do - let passphrase = mkPassphrase (BL.pack (map (fromIntegral . fromEnum) ("test" :: String))) - payload = mkClearPayload (BL.pack (map (fromIntegral . fromEnum) ("hello" :: String))) - let result = encryptMessageDefault DoNotExposeSessionMaterial passphrase payload - case result of - Left err -> fail ("encryptedSEIPDv2Packets: encryptMessageDefault failed: " ++ show err) - Right (encPayload, _) -> - DC.runConduitRes $ - CB.sourceLbs (encryptedPayloadBytes encPayload) DC..| conduitGet get DC..| - CL.consume - -defaultOptionsForPassphrase :: BL.ByteString -> DecryptOptions -defaultOptionsForPassphrase passphrase = - DecryptOptions - { decryptOptionsKeyResolution = DecryptWithoutPKESK - , decryptOptionsPolicy = defaultDecryptPolicy - , decryptOptionsPassphraseCallback = const (pure passphrase) - } - -testDecryptCleanSEIPDv2 :: Assertion -testDecryptCleanSEIPDv2 = do - pt <- encryptedSEIPDv2Packets - let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) - cb = const (pure passphrase) - (outcome, _) <- - catch - (DC.runConduitRes $ - CL.sourceList pt DC..| fuseBoth (conduitDecryptChecked cb) CL.consume) - (\e -> assertFailure ("unexpected exception: " ++ show (e :: SomeException)) >> fail "unreachable") - assertEqual "clean SEIPD v2 should yield DecryptClean" DecryptClean outcome - -testOptionsMatchesCheckedDefaultSEIPDv2 :: Assertion -testOptionsMatchesCheckedDefaultSEIPDv2 = do - pt <- encryptedSEIPDv2Packets - let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) - cb = const (pure passphrase) - opts = defaultOptionsForPassphrase passphrase - checkedResult <- - DC.runConduitRes $ - CL.sourceList pt DC..| fuseBoth (conduitDecryptChecked cb) CL.consume - optionsResult <- - DC.runConduitRes $ - CL.sourceList pt DC..| fuseBoth (DCD.conduitDecrypt opts) CL.consume - assertEqual "options conduit should match checked conduit on clean decrypt" checkedResult optionsResult - -testOptionsMatchesLegacyDefaultOutputSEIPDv2 :: Assertion -testOptionsMatchesLegacyDefaultOutputSEIPDv2 = do - pt <- encryptedSEIPDv2Packets - let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) - cb = const (pure passphrase) - opts = defaultOptionsForPassphrase passphrase - legacyOutput <- - DC.runConduitRes $ - CL.sourceList pt DC..| conduitDecrypt cb DC..| CL.consume - (optionsOutcome, optionsOutput) <- - DC.runConduitRes $ - CL.sourceList pt DC..| fuseBoth (DCD.conduitDecrypt opts) CL.consume - assertEqual - "options conduit should report DecryptClean for clean stream" - DecryptClean - optionsOutcome - assertEqual "legacy conduit output should match options conduit output" legacyOutput optionsOutput - -testTrailingDataRejectedStrictSEIPDv2 :: Assertion -testTrailingDataRejectedStrictSEIPDv2 = do - pt <- encryptedSEIPDv2Packets - let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""] - passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) - cb = const (pure passphrase) - result <- - try - (DC.runConduitRes $ - CL.sourceList ptWithTrailing DC..| fuseBoth (conduitDecryptChecked cb) CL.consume - ) :: IO (Either SomeException (DecryptOutcome, [Pkt])) - case result of - Left err -> - assertFailure ("Expected DecryptMalformedStructure but got exception: " ++ show err) - Right (DecryptMalformedStructure reason, _) -> - assertBool - ("Expected 'after message integrity boundary', got: " ++ reason) - ("after message integrity boundary" `isInfixOf` reason) - Right (other, _) -> - assertFailure ("Expected strict policy to reject trailing data but got: " ++ show other) - -testTrailingDataReportedLenientSEIPDv2 :: Assertion -testTrailingDataReportedLenientSEIPDv2 = do - pt <- encryptedSEIPDv2Packets - let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""] - passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) - cb = const (pure passphrase) - (outcome, _) <- - catch - (DC.runConduitRes $ - CL.sourceList ptWithTrailing DC..| - fuseBoth (conduitDecryptCheckedWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) cb) CL.consume) - (\e -> assertFailure ("unexpected exception: " ++ show (e :: SomeException)) >> fail "unreachable") - assertEqual "trailing packet should yield DecryptTrailingData" DecryptTrailingData outcome - -testOptionsMatchesCheckedLenientTrailingSEIPDv2 :: Assertion -testOptionsMatchesCheckedLenientTrailingSEIPDv2 = do - pt <- encryptedSEIPDv2Packets - let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""] - passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) - cb = const (pure passphrase) - opts = - DecryptOptions - { decryptOptionsKeyResolution = DecryptWithoutPKESK - , decryptOptionsPolicy = lenientDecryptPolicy - , decryptOptionsPassphraseCallback = cb - } - checkedResult <- - DC.runConduitRes $ - CL.sourceList ptWithTrailing DC..| - fuseBoth (conduitDecryptCheckedWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) cb) CL.consume - optionsResult <- - DC.runConduitRes $ - CL.sourceList ptWithTrailing DC..| - fuseBoth (DCD.conduitDecrypt opts) CL.consume - assertEqual "options conduit should match checked lenient conduit with trailing data" checkedResult optionsResult - -testRejectsNonEncryptedAfterESKPrelude :: Assertion -testRejectsNonEncryptedAfterESKPrelude = do - pt <- encryptedSEIPDv2Packets - let malformed = - case pt of - [] -> [] - esk:_ -> - [ esk - , LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) "not-encrypted" - ] - passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) - cb = const (pure passphrase) - result <- - try - (DC.runConduitRes $ - CL.sourceList malformed DC..| fuseBoth (conduitDecryptChecked cb) CL.consume - ) :: IO (Either SomeException (DecryptOutcome, [Pkt])) - case result of - Left err -> - assertFailure ("Expected DecryptMalformedStructure but got exception: " ++ show err) - Right (DecryptMalformedStructure reason, _) -> - assertBool - ("Expected ESK prelude shape failure, got: " ++ reason) - ("ESK packets must immediately precede encrypted data" `isInfixOf` reason) - Right (other, _) -> - assertFailure ("Expected DecryptMalformedStructure but got: " ++ show other) - -testRejectsMisalignedESKVersionForSEIPDv2 :: Assertion -testRejectsMisalignedESKVersionForSEIPDv2 = do - pt <- encryptedSEIPDv2Packets - let malformed = - case pt of - (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa _ s2k _ _ _)):rest) -> - SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) : rest - _ -> pt - passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) - cb = const (pure passphrase) - result <- - try - (DC.runConduitRes $ - CL.sourceList malformed DC..| fuseBoth (conduitDecryptChecked cb) CL.consume - ) :: IO (Either SomeException (DecryptOutcome, [Pkt])) - case result of - Left err -> - assertFailure ("Expected DecryptMalformedStructure but got exception: " ++ show err) - Right (DecryptMalformedStructure reason, _) -> - assertBool - ("Expected payload/ESK alignment failure, got: " ++ reason) - ("version-aligned" `isInfixOf` reason) - Right (other, _) -> - assertFailure ("Expected DecryptMalformedStructure but got: " ++ show other) - -testDiscardsMisalignedESKWhenAlignedCandidateExists :: Assertion -testDiscardsMisalignedESKWhenAlignedCandidateExists = do - pt <- encryptedSEIPDv2Packets - let withMixedPrelude = - case pt of - (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)):rest) -> - SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) : SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) : rest - _ -> pt - passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) - cb = const (pure passphrase) - (outcome, _) <- - catch - (DC.runConduitRes $ - CL.sourceList withMixedPrelude DC..| fuseBoth (conduitDecryptChecked cb) CL.consume) - (\e -> assertFailure ("unexpected exception: " ++ show (e :: SomeException)) >> fail "unreachable") - assertEqual - "misaligned ESKs should be discarded when an aligned ESK is present" - DecryptClean - outcome - -testSecretKeyDecryption :: FilePath -> FilePath -> Assertion -testSecretKeyDecryption keyfile passfile = do - passphrase <- readFixtureLazy passfile - kr <- - DC.runConduitRes $ - CB.sourceFile (fixturePath keyfile) DC..| conduitGet get DC..| - CL.consume - SecretKey pkp ska <- - case kr of - [] -> - assertFailure ("no packets found in secret key fixture " ++ keyfile) >> - fail "empty secret key fixture" - (firstPkt:_) -> - case (fromPktEither firstPkt :: Either String SecretKey) of - Left err -> assertFailure ("failed to coerce key packet to SecretKey: " ++ err) >> fail err - Right x -> pure x - decrypted <- - case decryptPrivateKey (pkp, ska) passphrase of - Left err -> - assertFailure ("secret key decryption failed: " ++ err) >> - fail "secret key decryption failed" - Right x -> pure x - case decrypted of - SUUnencrypted skey _ -> doPkeyAndSkeyMatch (_pubkey pkp) skey - other -> - assertFailure - ("secret key decryption should produce an unencrypted secret key, got: " ++ - show other) - -testLegacySecretKeyEncryptionRejected :: FilePath -> FilePath -> Assertion -testLegacySecretKeyEncryptionRejected keyfile passfile = do - passphrase <- readFixtureLazy passfile - kr <- - DC.runConduitRes $ - CB.sourceFile (fixturePath keyfile) DC..| conduitGet get DC..| - CL.consume - SecretKey pkp ska <- - case kr of - [] -> - assertFailure ("no packets found in secret key fixture " ++ keyfile) >> - fail "empty secret key fixture" - (firstPkt:_) -> - case (fromPktEither firstPkt :: Either String SecretKey) of - Left err -> assertFailure ("failed to coerce key packet to SecretKey: " ++ err) >> fail err - Right x -> pure x - case - encryptPrivateKeyWithPolicyAndSaltAndIV - defaultPolicy - pkp - (Salt "\226~\197\a\202#\"G") - (IV "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t") - ska - passphrase of - Left err | "explicit legacy override required" `isInfixOf` err -> pure () - Left err -> - assertFailure - ("legacy secret key encryption should be rejected with a policy error, got: " ++ - err) - Right _ -> - assertFailure "legacy secret key encryption should reject implicit SHA-1 protection" - -testV6SecretKeyEncryptionRoundTrip :: Assertion -testV6SecretKeyEncryptionRoundTrip = do - passphrase <- readPKIPassphrase - armors <- loadArmor "v6-secret.pgp.aa" - armor <- - case armors of - (a:_) -> pure a - [] -> - assertFailure "v6-secret.pgp.aa should contain one armored payload" >> - fail "expected one armored payload" - let packets = parsePkts (armorPayload armor) - SecretKey pkp ska <- - case [sk | pkt <- packets, Right sk <- [fromPktEither pkt :: Either String SecretKey]] of - (sk:_) -> pure sk - [] -> - assertFailure "v6-secret.pgp.aa should contain a secret key packet" >> - fail "expected secret key packet" - originalSKey <- - case ska of - SUUnencrypted skey _ -> pure skey - _ -> - assertFailure "v6-secret.pgp.aa should contain unencrypted secret key material" >> - fail "expected unencrypted secret key" - changed <- - case - encryptPrivateKeyWithPolicyAndSaltAndIV - defaultPolicy - pkp - (Salt "1234567890ABCDEF") - (IV "1234567890ABCDE") - ska - passphrase of - Left err -> - assertFailure ("v6 secret key encryption failed: " ++ err) >> - fail "v6 secret key encryption failed" - Right x -> pure x - case changed of - SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do - assertEqual - "v6 secret key encryption should use expected Argon2 t parameter" - 1 - t - assertEqual - "v6 secret key encryption should use expected Argon2 p parameter" - 4 - p - assertEqual - "v6 secret key encryption should use expected Argon2 encoded memory parameter" - 15 - em - assertBool - "v6 secret key encryption should emit encrypted payload" - (not (BL.null encryptedPayload)) - _ -> - assertFailure "v6 secret key encryption should emit SUSAEAD/AES256/OCB with Argon2 S2K" - let serialized = runPut (put (toPkt (SecretKey pkp changed))) - reparsed = parsePkts serialized - (parsedPKP, parsedSKA) <- - case reparsed of - (SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum) - _ -> - assertFailure "re-serialized v6 secret key should parse back as a secret key packet" >> - fail "expected serialized secret key packet" - decrypted <- - case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of - Left err -> - assertFailure ("v6 secret key roundtrip decryption failed: " ++ err) >> - fail "v6 secret key roundtrip decryption failed" - Right x -> pure x - case decrypted of - SUUnencrypted skey _ -> - assertEqual - "v6 secret key roundtrip should preserve secret key material" - originalSKey - skey - _ -> assertFailure "v6 secret key roundtrip should decrypt to unencrypted secret material" - -testV4SecretKeyAEADOCBRoundTripCompat :: Assertion -testV4SecretKeyAEADOCBRoundTripCompat = do - (pkp, privateKey) <- loadUnencryptedRsaSigner - let skey = RSAPrivateKey (RSA_PrivateKey privateKey) - passphrase = "legacy-aead-passphrase" - compatPolicy = - (policyForRFC RFC4880) - { policySecretKeyProtection = policySecretKeyProtection defaultPolicy - } - salt = Salt (B.pack [0x00 .. 0x0f]) - iv = IV (B.pack [0x10 .. 0x1e]) - encrypted <- - case - encryptPrivateKeyWithPolicyAndSaltAndIV - compatPolicy - pkp - salt - iv - (SUUnencrypted skey 0) - passphrase of - Left err -> - assertFailure ("v4 AEAD secret key encryption failed: " ++ err) >> - fail "v4 AEAD secret key encryption failed" - Right x -> pure x - case encrypted of - SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do - assertEqual "v4 AEAD secret key encryption should use expected Argon2 t" 1 t - assertEqual "v4 AEAD secret key encryption should use expected Argon2 p" 4 p - assertEqual "v4 AEAD secret key encryption should use expected Argon2 encoded-memory" 15 em - assertBool - "v4 AEAD secret key encryption should emit encrypted payload" - (not (BL.null encryptedPayload)) - _ -> - assertFailure "v4 secret key encryption should emit SUSAEAD/AES256/OCB with Argon2 S2K" - let serialized = runPut (put (toPkt (SecretKey pkp encrypted))) - reparsed = parsePkts serialized - (parsedPKP, parsedSKA) <- - case reparsed of - (SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum) - _ -> - assertFailure "re-serialized v4 AEAD secret key should parse back as a secret key packet" >> - fail "expected serialized secret key packet" - decrypted <- - case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of - Left err -> - assertFailure ("v4 AEAD secret key roundtrip decryption failed: " ++ err) >> - fail "v4 AEAD secret key roundtrip decryption failed" - Right x -> pure x - case decrypted of - SUUnencrypted skey' _ -> - assertEqual - "v4 AEAD secret key roundtrip should preserve secret key material" - skey - skey' - _ -> assertFailure "v4 AEAD secret key roundtrip should decrypt to unencrypted secret material" - -testSUSymSecretKeyRoundTrip :: Assertion -testSUSymSecretKeyRoundTrip = do - passphrase <- readPKIPassphrase - packets <- - DC.runConduitRes $ - CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| - CL.consume - (pkp, skey) <- - case packets of - (SecretKeyPkt pkpayload (SUUnencrypted sk _):_) -> pure (pkpayload, sk) - _ -> - assertFailure "unencrypted.seckey did not begin with an unencrypted secret key packet" >> - fail "expected unencrypted secret key packet" - let cleartext = legacyRsaSecretKeyBytes skey - cleartextLBS = BL.fromStrict cleartext - clearWithChecksum = cleartextLBS <> runPut (putWord16be (legacyChecksum16 cleartext)) - iv = IV (B.pack [0..15]) - sa = AES128 - keyMaterial <- - case string2Key (Simple DeprecatedMD5) 16 passphrase of - Left err -> - assertFailure ("failed to derive SUSym key material: " ++ renderS2KError err) >> - fail "failed to derive SUSym key material" - Right km -> pure km - encrypted <- - case encryptNoNonce sa (Simple DeprecatedMD5) iv (BL.toStrict clearWithChecksum) keyMaterial of - Left err -> - assertFailure ("failed to encrypt legacy SUSym secret key: " ++ show err) >> - fail "failed to encrypt legacy SUSym secret key" - Right bs -> pure bs - let legacySka = SUSym sa iv (BL.fromStrict encrypted) - serialized = runPut (put (toPkt (SecretKey pkp legacySka))) - reparsed = parsePkts serialized - (parsedPKP, parsedSKA) <- - case reparsed of - (SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum) - _ -> - assertFailure "serialized SUSym secret key should parse back as a secret key packet" >> - fail "expected serialized secret key packet" - decrypted <- - case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of - Left err -> - assertFailure ("SUSym secret key decryption failed: " ++ err) >> - fail "SUSym secret key decryption failed" - Right x -> pure x - case decrypted of - SUUnencrypted parsedSKey _ -> - assertEqual - "SUSym secret key roundtrip should preserve secret key material" - skey - parsedSKey - _ -> assertFailure "SUSym secret key roundtrip should decrypt to unencrypted secret material" - -legacyRsaSecretKeyBytes :: SKey -> B.ByteString -legacyRsaSecretKeyBytes (RSAPrivateKey (RSA_PrivateKey (RSA.PrivateKey _ d p q _ _ _))) = - BL.toStrict $ - runPut $ - case inverse q p of - Just u -> do - put (MPI d) - put (MPI p) - put (MPI q) - put (MPI u) - Nothing -> error "invalid RSA key in legacy secret key test" -legacyRsaSecretKeyBytes _ = error "legacyRsaSecretKeyBytes requires an RSA secret key" - -legacyChecksum16 :: B.ByteString -> Word16 -legacyChecksum16 = - fromIntegral . - B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0 - -testLegacyEncryptionFixtureShape :: Assertion -testLegacyEncryptionFixtureShape = do - packets <- - DC.runConduitRes $ - CB.sourceFile "tests/data/encryption.gpg" DC..| conduitGet get DC..| CL.consume - let hasKeyEncapsulation = any isKeyEncapsulation packets - hasEncryptedData = any isEncryptedData packets - assertBool - "encryption.gpg should contain PKESK or SKESK key-encapsulation" - hasKeyEncapsulation - assertBool "encryption.gpg should contain encrypted data" hasEncryptedData - where - isKeyEncapsulation (SKESKPkt _) = True - isKeyEncapsulation (PKESKPkt _) = True - isKeyEncapsulation _ = False - isEncryptedData SymEncDataPkt {} = True - isEncryptedData SymEncIntegrityProtectedDataPkt {} = True - isEncryptedData _ = False - -testBuildPKESKPayloadForRecipientRSA :: Assertion -testBuildPKESKPayloadForRecipientRSA = do - (baseRecipient, privateKey) <- loadUnencryptedRsaSigner - let recipient = setKeyVersion V6 baseRecipient - sessionKey = SessionKey (B.replicate 32 0x2e) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk builder rsa payload" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - PKESKRecipientKey - { pkeskRecipientPKPayload = Nothing - , pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey) - }) - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - pkeskPayloadResult <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial - pkeskPayload <- - case pkeskPayloadResult of - Left err -> - assertFailure ("buildPKESKPayloadForRecipient failed: " ++ show err) >> - fail "buildPKESKPayloadForRecipient failed" - Right p -> pure p - case pkeskPayload of - PKESKPayloadV6Packet (PKESKPayloadV6 _ RSA eskBytesLazy) -> do - let eskBytes = BL.toStrict eskBytesLazy - assertBool "PKESKv6 RSA ESK should include MPI framing" (B.length eskBytes >= 2) - let mpiBits = fromIntegral (B.index eskBytes 0) * 256 + fromIntegral (B.index eskBytes 1) - mpiLen = (mpiBits + 7) `div` 8 - assertEqual - "PKESKv6 RSA ESK should be exactly one RFC9580 MPI" - (2 + mpiLen) - (B.length eskBytes) - other -> - assertFailure ("Expected PKESKv6 RSA payload, got " ++ show other) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList - [ PKESKPkt pkeskPayload - , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) - ] DC..| - conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESK builder RSA decrypt payload" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testBuildPKESKv3PayloadForRecipientRSAInterop :: Assertion -testBuildPKESKv3PayloadForRecipientRSAInterop = do - (baseRecipient, privateKey) <- loadUnencryptedRsaSigner - let recipient = setKeyVersion V4 baseRecipient - sessionKey = SessionKey (B.replicate 32 0x2d) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk builder rsa v3 interop payload" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyCallback _ = pure (Just (RSAPrivateKey (RSA_PrivateKey privateKey))) - keyContextCallback pkt = do - msk <- keyCallback pkt - pure $ - fmap - (\sk -> - PKESKRecipientKey - { pkeskRecipientPKPayload = Nothing - , pkeskRecipientSKey = sk - }) - msk - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - pkeskPayloadResult <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) - pkeskPayload <- - case pkeskPayloadResult of - Left err -> - assertFailure ("buildPKESKv3PayloadForRecipient failed: " ++ show err) >> - fail "buildPKESKv3PayloadForRecipient failed" - Right p@(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ RSA _)) -> pure p - Right other -> - assertFailure ("Expected PKESK3 RSA payload, got " ++ show other) >> - fail "Unexpected PKESK payload variant" - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList - [ PKESKPkt pkeskPayload - , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) - ] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESKv3 RSA interop decrypt payload" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testBuildPKESKv3PayloadForRecipientSupportsV6Key :: Assertion -testBuildPKESKv3PayloadForRecipientSupportsV6Key = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let recipient = setKeyVersion V6 baseRecipient - sessionKey = SessionKey (B.replicate 32 0x11) - let expectedKeyId = EightOctetKeyId (BL.take 8 (unFingerprint (fingerprint recipient))) - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - result <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) - case result of - Right (PKESKPayloadV3Packet (PKESKPayloadV3 _ keyId RSA _)) -> - assertEqual - "PKESKv3 builder should derive v6 key ID from the high-order 64 bits of the fingerprint" - expectedKeyId - keyId - Right payload -> - assertFailure ("Expected PKESK3 RSA payload for v6 recipient, got " ++ show payload) - Left err -> - assertFailure ("Expected PKESK3 RSA payload for v6 recipient, got error " ++ show err) - -testBuildPKESKv3PayloadForRecipientECDHInterop :: Assertion -testBuildPKESKv3PayloadForRecipientECDHInterop = do - let (recipientPub, recipientPriv) = syntheticNISTP256Low - recipient = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - ECDH - (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA256 AES128) - sessionKey = SessionKey (B.replicate 32 0x21) - salt = Salt (B.pack [0x20 .. 0x3f]) - payload = "pkesk builder ecdh v3 interop payload" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipient - , pkeskRecipientSKey = recipientSKey - })) - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - pkeskPayloadResult <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) - pkeskPayload <- - case pkeskPayloadResult of - Left err -> - assertFailure ("buildPKESKv3PayloadForRecipient failed: " ++ show err) >> - fail "buildPKESKv3PayloadForRecipient failed" - Right p@(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ ECDH _)) -> pure p - Right other -> - assertFailure ("Expected PKESK3 ECDH payload, got " ++ show other) >> - fail "Unexpected PKESK payload variant" - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList - [ PKESKPkt pkeskPayload - , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) - ] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESKv3 ECDH interop decrypt payload" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - --- | Verify that the PKESKv3 ECDH serializer writes the wrapped-key field using the --- RFC 6637 §8 wire format (MPI(ephemeral) || 1-octet-count || C) rather than the --- old double-MPI encoding that caused interoperability failures. -testPKESKv3ECDHWireFormat :: Assertion -testPKESKv3ECDHWireFormat = do - let (recipientPub, _) = syntheticNISTP256Low - recipient = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - ECDH - (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA256 AES256) - -- Use a session key whose first byte is 0x00 so leading-zero stripping - -- is observable if i2osp truncates the wrapped key. - sessionKey = SessionKey (B.cons 0x00 (B.replicate 31 0xAB)) - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - pkeskResult <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) - case pkeskResult of - Left err -> assertFailure ("buildPKESKv3PayloadForRecipient failed: " ++ show err) - Right p -> do - -- Serialise the packet to wire bytes then parse the PKESK body manually. - let wire = BL.toStrict (runPut (put (PKESKPkt p))) - -- Skip new-format tag byte (0xC1), then parse the packet length. - -- For the test we just round-trip through parsePkts and check the body layout. - case parsePkts (BL.fromStrict wire) of - [PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ ECDH (ephMPI NE.:| [wrappedMPI])))] -> do - -- The ephemeral MPI should be non-trivially large (EC point). - assertBool "ephemeral MPI should be non-empty" (unMPI ephMPI > 0) - -- The wrapped MPI stores the raw i2osp bytes; for AES-256 the RFC 3394 - -- ciphertext is 48 bytes. i2osp strips leading zeros so the stored - -- integer may represent fewer bytes, but candidateWrappedRFC3394Ciphertexts - -- handles that. What we're checking here is the WIRE format: - -- after the ephemeral MPI there must be exactly 1-byte-len + C bytes, - -- not a second MPI header. - -- - -- Re-serialise and inspect the bytes after the ephemeral MPI manually. - let ephBytes = BL.toStrict (runPut (put ephMPI)) - pktBody = - -- wire: 0xC1 | varlen | version(1) | keyid(8) | pka(1) | body - -- skip tag(1) + len(variable) + version(1) + keyid(8) + pka(1) - -- We just serialise the body directly via putPKESKv3SessionKeyMaterial equivalent: - BL.toStrict (runPut (put (PKESKPkt (PKESKPayloadV3Packet - (PKESKPayloadV3 3 (EightOctetKeyId (BL.replicate 8 0)) ECDH - (ephMPI NE.:| [wrappedMPI])))))) - -- Find the position of the body after tag+len+version+keyid+pka. - -- Tag: 1 byte; new-format len: 1 or 2 bytes; version: 1; keyid: 8; pka: 1 = 12 or 13 bytes - -- Instead of parsing the header, just verify the body doesn't start with - -- the two-byte MPI bit-count of the wrapped key. - -- After ephBytes in the body, the next byte should be the 1-byte count (24-48), - -- not the high byte of an MPI bit-count (which would be 0x01 for 383-bit keys). - -- We search for ephBytes in pktBody and check what follows. - let stripped = dropPKESKv3Header pktBody - afterEph = B.drop (B.length ephBytes) stripped - assertBool - "PKESKv3 ECDH wire body: after ephemeral MPI there must be at least 1 byte for wrapped-key length" - (not (B.null afterEph)) - let wrappedLenByte = fromIntegral (B.head afterEph) :: Int - assertBool - ("PKESKv3 ECDH wire: wrapped-key length byte " ++ - show wrappedLenByte ++ - " should be a valid RFC 3394 wrapped-key length (24, 32, 40, or 48)") - (wrappedLenByte `elem` [24, 32, 40, 48]) - assertEqual - "PKESKv3 ECDH wire: bytes after length field must equal length" - wrappedLenByte - (B.length (B.tail afterEph)) - other -> - assertFailure ("Expected single PKESKv3 ECDH packet after round-trip, got " ++ show other) - where - -- Drop the new-format packet header (tag byte + variable-length field + - -- version byte + 8-byte key-id + pka byte) to reach the session-key material. - dropPKESKv3Header bs - | B.length bs < 3 = bs - | otherwise = - let lenByte = B.index bs 1 - headerLen - | lenByte < 192 = 2 -- 1-byte length - | lenByte < 224 = 3 -- 2-byte length - | otherwise = 6 -- 5-byte length (rare) - in B.drop (headerLen + 1 + 8 + 1) bs -testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop :: Assertion -testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop = do - let recipientSecretRaw = B.pack [1 .. 32] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize Curve25519Legacy recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - recipient = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - ECDH - (ECDHPubKey - (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 recipientPublicRaw))))) - SHA256 - AES256) - recipientSKey = - ECDHPrivateKey - (ECDSA_PrivateKey - (ECDSA.PrivateKey (ECCT.getCurveByName ECCT.SEC_p256r1) (os2ip recipientSecretRaw))) - sessionKey = SessionKey (B.replicate 32 0x22) - salt = Salt (B.pack [0x40 .. 0x5f]) - payload = "pkesk builder curve25519legacy v3 interop payload" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipient - , pkeskRecipientSKey = recipientSKey - })) - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - pkeskPayloadResult <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) - pkeskPayload <- - case pkeskPayloadResult of - Left err -> - assertFailure ("buildPKESKv3PayloadForRecipient failed: " ++ show err) >> - fail "buildPKESKv3PayloadForRecipient failed" - Right p@(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ ECDH (ephemeralMPI NE.:| _))) -> do - let ephemeralBytes = i2osp (unMPI ephemeralMPI) - assertEqual - "PKESKv3 Curve25519Legacy ephemeral point should be 0x40-prefixed 33-octet value" - 33 - (B.length ephemeralBytes) - assertEqual - "PKESKv3 Curve25519Legacy ephemeral point should use RFC6637 0x40 prefix" - 0x40 - (B.head ephemeralBytes) - pure p - Right other -> - assertFailure ("Expected PKESK3 ECDH payload, got " ++ show other) >> - fail "Unexpected PKESK payload variant" - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList - [ PKESKPkt pkeskPayload - , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) - ] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESKv3 Curve25519Legacy interop decrypt payload" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy :: Assertion -testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy = do - let recipient = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - ECDH - (ECDHPubKey - (EdDSAPubKey Ed448 (PrefixedNativeEPoint (EPoint 1))) - SHA512 - AES256) - sessionKey = SessionKey (B.replicate 32 0x23) - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - result <- buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial sessionMaterial) - case result of - Left (InvalidRecipientKeyMaterial ECDH err) - | "RFC6637-compatible" `isInfixOf` err -> pure () - | otherwise -> - assertFailure - ("Expected RFC6637 compatibility rejection, got: " ++ err) - Left err -> - assertFailure ("Expected InvalidRecipientKeyMaterial ECDH, got " ++ show err) - Right payload -> - assertFailure ("Expected RFC6637 compatibility rejection, got payload: " ++ show payload) - --- | Conformance test: v6 X25519 PKESK uses raw session key, not v3-encoded material. --- RFC 9580 specifies that v6 X25519 wraps the raw session key directly (no algorithm byte or checksum). --- When the raw 32-byte key is AES-KW wrapped with RFC3394: 32 bytes + 8-byte integrity = 40 bytes. --- If v3-encoded (1 byte algo + 32 bytes key + 2 bytes checksum + ~5 bytes padding = 40 bytes unwrapped), --- the wrapped result would be ~48 bytes, so we verify wrapped size is 40. -testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics :: Assertion -testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics = do - let recipientSecretRaw = B.pack [1 .. 32] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - v4Recipient = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - recipient = setKeyVersion V6 v4Recipient - sessionKey = SessionKey (B.replicate 32 0x24) - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - pkeskPayloadResult <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial - case pkeskPayloadResult of - Left err -> - assertFailure ("buildPKESKPayloadForRecipient failed for v6 X25519: " ++ show err) - Right (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 eskBytesLazy)) -> do - let eskBytes = BL.toStrict eskBytesLazy - assertX25519EskShape "v6 X25519 raw-key conformance" eskBytes - let wrappedLen = fromIntegral (B.index eskBytes 32) :: Int - assertEqual - "v6 X25519 wrapped session key (AES-KW RFC3394 of raw 32 bytes) must be 40 bytes" - 40 - wrappedLen - Right other -> - assertFailure ("Expected PKESKPayloadV6 with X25519, got " ++ show other) - --- | Conformance test: v6 X448 PKESK uses raw session key, not v3-encoded material. --- RFC 9580 specifies that v6 X448 wraps the raw session key directly (no algorithm byte or checksum). --- When the raw 32-byte key is AES-KW wrapped with RFC3394: 32 bytes + 8-byte integrity = 40 bytes. --- If v3-encoded (1 byte algo + 32 bytes key + 2 bytes checksum + ~5 bytes padding = 40 bytes unwrapped), --- the wrapped result would be ~48 bytes, so we verify wrapped size is 40. -testBuildPKESKv6PayloadForRecipientX448RawKeySemantics :: Assertion -testBuildPKESKv6PayloadForRecipientX448RawKeySemantics = do - let recipientSecretRaw = B.pack [1 .. 56] - recipientSecret = - case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X448 recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString - v4Recipient = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X448 - (EdDSAPubKey Ed448 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - recipient = setKeyVersion V6 v4Recipient - sessionKey = SessionKey (B.replicate 32 0x25) - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - pkeskPayloadResult <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial - case pkeskPayloadResult of - Left err -> - assertFailure ("buildPKESKPayloadForRecipient failed for v6 X448: " ++ show err) - Right (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 eskBytesLazy)) -> do - let eskBytes = BL.toStrict eskBytesLazy - assertX448EskShape "v6 X448 raw-key conformance" eskBytes - let wrappedLen = fromIntegral (B.index eskBytes 56) :: Int - assertEqual - "v6 X448 wrapped session key (AES-KW RFC3394 of raw 32 bytes) must be 40 bytes" - 40 - wrappedLen - Right other -> - assertFailure ("Expected PKESKPayloadV6 with X448, got " ++ show other) - -testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop :: Assertion -testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let recipient = setKeyVersion V4 baseRecipient - sessionKey = SessionKey (B.replicate 32 0x16) - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - result <- - buildPKESKPayloadForRecipient ForceV3Interop recipient sessionMaterial - case result of - Right (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ RSA _)) -> pure () - Right payload -> - assertFailure ("Expected PKESK3 RSA for ForceV3Interop, got " ++ show payload) - Left err -> - assertFailure ("Expected PKESK3 RSA for ForceV3Interop, got error " ++ show err) - -testRecipientVersionStrategyForProfileHonorsHints :: Assertion -testRecipientVersionStrategyForProfileHonorsHints = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let recipient = setKeyVersion V6 baseRecipient - case recipientVersionStrategyForProfile EncryptStrictDefault (recipientEncryptionTargetWithStrategy recipient RecipientForceV3Interop) of - Right RecipientForceV3Interop -> pure () - other -> - assertFailure ("Expected explicit recipient hint to win, got " ++ show other) - case recipientVersionStrategyForProfile EncryptInteropLegacy (recipientEncryptionTarget recipient) of - Right RecipientForceV3Interop -> pure () - other -> - assertFailure ("Expected legacy profile fallback to force v3, got " ++ show other) - let v4Recipient = setKeyVersion V4 recipient - case recipientVersionStrategyForProfile EncryptStrictDefault (recipientEncryptionTarget recipient) of - Right RecipientPreferV6 -> pure () - other -> - assertFailure ("Expected strict profile auto-detect to prefer v6 for v6 recipients, got " ++ show other) - case recipientVersionStrategyForProfile EncryptStrictDefault (recipientEncryptionTarget v4Recipient) of - Right RecipientForceV3Interop -> pure () - other -> - assertFailure ("Expected strict profile auto-detect to force v3 for legacy recipients, got " ++ show other) - -testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies :: Assertion -testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let v4Recipient = setKeyVersion V4 baseRecipient - v6Recipient = setKeyVersion V6 baseRecipient - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = - [ recipientEncryptionTarget v6Recipient - , recipientEncryptionTarget v4Recipient - ] - , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape - , recipientEncryptRequestPayload = "recipient autodetect" - , recipientEncryptRequestSymmetricOverride = Just AES256 - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv2Overrides - { recipientEncryptRequestAEADOverride = Just OCB - , recipientEncryptRequestChunkSizeOverride = Just 6 - , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x77)) - } - } - result <- encryptForRecipients request - case result of - Left err -> - assertFailure ("Expected mixed-recipient request to encrypt successfully, got " ++ show err) - Right RecipientEncryptResult { recipientEncryptPackets = packets } -> do - let pkesks = [p | PKESKPkt p <- packets] - assertBool - "strict profile auto-detect should emit PKESKv6 for v6 recipients" - (any isPKESK6 pkesks) - assertBool - "strict profile auto-detect should emit PKESKv3 for v4 recipients" - (any isPKESK3 pkesks) - where - isPKESK6 PKESKPayloadV6Packet {} = True - isPKESK6 _ = False - isPKESK3 PKESKPayloadV3Packet {} = True - isPKESK3 _ = False - -testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled :: Assertion -testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let v4Recipient = setKeyVersion V4 baseRecipient - v6Recipient = setKeyVersion V6 baseRecipient - v6Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V6 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.empty - , recipientCapabilityPreferredSymmetricAlgorithms = [AES128, AES256] - , recipientCapabilityPreferredAEADAlgorithms = [OCB] - } - v4Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V4 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.empty - , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] - , recipientCapabilityPreferredAEADAlgorithms = [OCB] - } - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = - [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps - , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps - ] - , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape - , recipientEncryptRequestPayload = "recipient capability negotiation payload" - , recipientEncryptRequestSymmetricOverride = Nothing - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv2Overrides - { recipientEncryptRequestAEADOverride = Just OCB - , recipientEncryptRequestChunkSizeOverride = Just 6 - , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x22)) - } - } - result <- encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn request - case result of - Left err -> - assertFailure ("Expected recipient capability negotiation to succeed, got " ++ show err) - Right RecipientEncryptResult { recipientEncryptSessionMaterial = material } -> - assertEqual - "capability negotiation should pick common preferred symmetric algorithm" - AES128 - (pkeskSessionAlgorithm material) - -testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault :: Assertion -testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let v4Recipient = setKeyVersion V4 baseRecipient - v6Recipient = setKeyVersion V6 baseRecipient - v6Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V6 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.empty - , recipientCapabilityPreferredSymmetricAlgorithms = [AES128, AES256] - , recipientCapabilityPreferredAEADAlgorithms = [OCB] - } - v4Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V4 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.empty - , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] - , recipientCapabilityPreferredAEADAlgorithms = [OCB] - } - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = - [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps - , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps - ] - , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape - , recipientEncryptRequestPayload = "default recipient capability negotiation payload" - , recipientEncryptRequestSymmetricOverride = Nothing - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv2Overrides - { recipientEncryptRequestAEADOverride = Just OCB - , recipientEncryptRequestChunkSizeOverride = Just 6 - , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x24)) - } - } - result <- encryptForRecipients request - case result of - Left err -> - assertFailure ("Expected default encryptForRecipients negotiation to succeed, got " ++ show err) - Right RecipientEncryptResult { recipientEncryptSessionMaterial = material } -> - assertEqual - "encryptForRecipients should negotiate recipient capabilities by default" - AES128 - (pkeskSessionAlgorithm material) - -testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut :: Assertion -testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let v4Recipient = setKeyVersion V4 baseRecipient - v6Recipient = setKeyVersion V6 baseRecipient - v6Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V6 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.empty - , recipientCapabilityPreferredSymmetricAlgorithms = [AES128, AES256] - , recipientCapabilityPreferredAEADAlgorithms = [OCB] - } - v4Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V4 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.empty - , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] - , recipientCapabilityPreferredAEADAlgorithms = [OCB] - } - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = - [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps - , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps - ] - , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape - , recipientEncryptRequestPayload = "legacy recipient capability opt-out payload" - , recipientEncryptRequestSymmetricOverride = Nothing - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv2Overrides - { recipientEncryptRequestAEADOverride = Just OCB - , recipientEncryptRequestChunkSizeOverride = Just 6 - , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x25)) - } - } - result <- encryptForRecipientsLegacy request - case result of - Left err -> - assertFailure ("Expected legacy encryptForRecipients opt-out to succeed, got " ++ show err) - Right RecipientEncryptResult { recipientEncryptSessionMaterial = material } -> - assertEqual - "encryptForRecipientsLegacy should preserve policy-default symmetric selection" - AES256 - (pkeskSessionAlgorithm material) - -testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm :: Assertion -testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let v4Recipient = setKeyVersion V4 baseRecipient - v6Recipient = setKeyVersion V6 baseRecipient - v6Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V6 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.empty - , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] - , recipientCapabilityPreferredAEADAlgorithms = [OCB] - } - v4Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V4 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.empty - , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] - , recipientCapabilityPreferredAEADAlgorithms = [OCB] - } - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = - [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps - , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps - ] - , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape - , recipientEncryptRequestPayload = "recipient capability mismatch payload" - , recipientEncryptRequestSymmetricOverride = Nothing - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv2Overrides - { recipientEncryptRequestAEADOverride = Just OCB - , recipientEncryptRequestChunkSizeOverride = Just 6 - , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x23)) - } - } - result <- encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn request - case result of - Left (RecipientCapabilitySelectionFailure (RecipientCapabilityNoCommonSymmetricAlgorithms _)) -> pure () - Left other -> - assertFailure ("Expected RecipientCapabilityNoCommonSymmetricAlgorithms, got " ++ show other) - Right _ -> - assertFailure "Expected recipient capability negotiation to fail without common symmetric algorithm" - -testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms :: Assertion -testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms = do - (recipient, _privateKey) <- loadUnencryptedRsaSigner - let caps = - recipientCapabilitiesFromSubpacketPayloads - recipient - [OtherSigSub 39 (BL.pack [9, 2, 7, 3, 9, 2])] - assertEqual - "preferred AEAD ciphersuites subpacket should extract unique AEAD preferences in declaration order" - [OCB, GCM] - (recipientCapabilityPreferredAEADAlgorithms caps) - -testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled :: Assertion -testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let v4Recipient = setKeyVersion V4 baseRecipient - v6Recipient = setKeyVersion V6 baseRecipient - v6Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V6 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] - , recipientCapabilityPreferredSymmetricAlgorithms = [AES128, AES256] - , recipientCapabilityPreferredAEADAlgorithms = [GCM, OCB] - } - v4Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V4 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] - , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] - , recipientCapabilityPreferredAEADAlgorithms = [GCM] - } - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = - [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps - , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps - ] - , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape - , recipientEncryptRequestPayload = "recipient AEAD capability negotiation payload" - , recipientEncryptRequestSymmetricOverride = Nothing - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv2Overrides - { recipientEncryptRequestAEADOverride = Nothing - , recipientEncryptRequestChunkSizeOverride = Just 6 - , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x26)) - } - } - result <- encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn request - case result of - Left err -> - assertFailure ("Expected AEAD capability negotiation to succeed, got " ++ show err) - Right RecipientEncryptResult { recipientEncryptPackets = packets - , recipientEncryptSessionMaterial = material - } -> do - assertEqual - "AEAD capability negotiation should preserve symmetric negotiation" - AES128 - (pkeskSessionAlgorithm material) - case [aa | SymEncIntegrityProtectedDataPkt (SEIPD2 _ aa _ _ _) <- packets] of - [selectedAEAD] -> - assertEqual - "AEAD capability negotiation should pick common preferred AEAD algorithm" - GCM - selectedAEAD - other -> - assertFailure ("Expected one SEIPDv2 packet, got " ++ show other) - -testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm :: Assertion -testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let v4Recipient = setKeyVersion V4 baseRecipient - v6Recipient = setKeyVersion V6 baseRecipient - v6Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V6 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] - , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] - , recipientCapabilityPreferredAEADAlgorithms = [OCB] - } - v4Caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V4 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] - , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] - , recipientCapabilityPreferredAEADAlgorithms = [GCM] - } - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = - [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps - , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps - ] - , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape - , recipientEncryptRequestPayload = "recipient AEAD mismatch payload" - , recipientEncryptRequestSymmetricOverride = Just AES256 - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv2Overrides - { recipientEncryptRequestAEADOverride = Nothing - , recipientEncryptRequestChunkSizeOverride = Just 6 - , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x27)) - } - } - result <- encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn request - case result of - Left (RecipientCapabilitySelectionFailure (RecipientCapabilityNoCommonAEADAlgorithms _)) -> pure () - Left other -> - assertFailure ("Expected RecipientCapabilityNoCommonAEADAlgorithms, got " ++ show other) - Right _ -> - assertFailure "Expected recipient capability negotiation to fail without common AEAD algorithm" - -testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 :: Assertion -testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let v4Recipient = setKeyVersion V4 baseRecipient - v6Recipient = setKeyVersion V6 baseRecipient - sharedCaps keyVersion recipient = - RecipientCapabilities - { recipientCapabilityKeyVersion = keyVersion - , recipientCapabilityPublicKeyAlgorithm = _pkalgo recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.singleton FeatureSEIPDv1 - , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] - , recipientCapabilityPreferredAEADAlgorithms = [OCB] - } - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = - [ recipientEncryptionTargetWithCapabilities v6Recipient (sharedCaps V6 v6Recipient) - , recipientEncryptionTargetWithCapabilities v4Recipient (sharedCaps V4 v4Recipient) - ] - , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape - , recipientEncryptRequestPayload = "recipient seipd fallback payload" - , recipientEncryptRequestSymmetricOverride = Just AES256 - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv2Overrides - { recipientEncryptRequestAEADOverride = Nothing - , recipientEncryptRequestChunkSizeOverride = Just 6 - , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x28)) - } - } - result <- encryptForRecipients request - case result of - Left err -> - assertFailure ("Expected fallback to SEIPDv1 when recipients do not advertise SEIPDv2, got " ++ show err) - Right RecipientEncryptResult { recipientEncryptPackets = packets } -> do - let seipdPkts = [p | SymEncIntegrityProtectedDataPkt p <- packets] - case seipdPkts of - [SEIPD1 1 _] -> pure () - [SEIPD2 {}] -> assertFailure "Expected SEIPDv1 fallback when recipients do not advertise SEIPDv2 support" - other -> assertFailure ("Unexpected SEIPD packets: " ++ show other) - -testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC :: Assertion -testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let v4Recipient = setKeyVersion V4 baseRecipient - caps = - RecipientCapabilities - { recipientCapabilityKeyVersion = V4 - , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient - , recipientCapabilityKeyFlags = Set.empty - , recipientCapabilityFeatures = Set.singleton FeatureSEIPDv2 - , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] - , recipientCapabilityPreferredAEADAlgorithms = [OCB] - } - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = - [recipientEncryptionTargetWithCapabilities v4Recipient caps] - , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape - , recipientEncryptRequestPayload = "recipient seipd v1 capability failure payload" - , recipientEncryptRequestSymmetricOverride = Just AES256 - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv1Overrides - { recipientEncryptRequestIVOverride = Nothing - } - } - result <- encryptForRecipients request - case result of - Left (RecipientCapabilitySelectionFailure (RecipientCapabilityMissingSEIPDv1Support _)) -> pure () - Left other -> - assertFailure ("Expected RecipientCapabilityMissingSEIPDv1Support, got " ++ show other) - Right _ -> - assertFailure "Expected SEIPDv1 encryption to fail when recipients do not advertise MDC support" - -testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys :: Assertion -testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys = do - (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer - (baseEncryptingSubkey, _privateKey) <- loadUnencryptedRsaSigner - let tkUnknown = - TKUnknown - { _tkuKey = (signingPrimary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = - [ ( PublicSubkeyPkt (setKeyTimestamp (_timestamp signingPrimary) baseEncryptingSubkey) - , [] - ) - ] - } - tk = - case fromUnknownToTK tkUnknown of - Right (SomePublicTK publicTk) -> publicTk - Right (SomeSecretTK _) -> error "expected public TK for recipient target test" - Left err -> error err - encryptingSubkey = setKeyTimestamp (_timestamp signingPrimary) baseEncryptingSubkey - targets = recipientEncryptionTargetsFromTK tk - assertEqual "TKUnknown-derived targets should include only encryption-capable keys" 1 (length targets) - case targets of - [target] -> - assertEqual - "TKUnknown-derived target should preserve selected encryption key" - (fingerprint encryptingSubkey) - (fingerprint (recipientEncryptionTargetKey target)) - _ -> - assertFailure "Expected exactly one encryption-capable target" - -testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary :: Assertion -testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let primary = setKeyVersion V4 baseRecipient - subkey = setKeyVersion V6 baseRecipient - tkUnknown = - TKUnknown - { _tkuKey = (primary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [(PublicSubkeyPkt subkey, [])] - } - tk = - case fromUnknownToTK tkUnknown of - Right (SomePublicTK publicTk) -> publicTk - Right (SomeSecretTK _) -> error "expected public TK for recipient target selection test" - Left err -> error err - case recipientEncryptionTargetFromTK tk of - Right target -> - assertEqual - "TKUnknown-derived single target should prioritize encryption subkeys" - (fingerprint subkey) - (fingerprint (recipientEncryptionTargetKey target)) - Left err -> - assertFailure ("Expected TKUnknown-derived target selection to succeed, got " ++ show err) - -testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys :: Assertion -testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys = do - (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer - let tkUnknown = - TKUnknown - { _tkuKey = (signingPrimary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [] - } - tk = - case fromUnknownToTK tkUnknown of - Right (SomePublicTK publicTk) -> publicTk - Right (SomeSecretTK _) -> error "expected public TK for recipient rejection test" - Left err -> error err - case recipientEncryptionTargetFromTK tk of - Left RecipientCapabilityNoEncryptableKeyMaterialInTK -> pure () - Left other -> - assertFailure ("Expected RecipientCapabilityNoEncryptableKeyMaterialInTK, got " ++ show other) - Right _ -> - assertFailure "Expected TKUnknown-derived target selection to reject non-encryptable TKs" - -testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections :: Assertion -testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections = do - (baseKey, signingKey) <- loadUnencryptedRsaSigner - let signatureTime = ThirtyTwoBitTimeStamp 1700000000 - primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey - subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey - subkeyBindingSig <- - signSubkeyBindingWithRSAExtrasAt - primary - subkey - signingKey - signatureTime - [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] - let tk = - TKUnknown - { _tkuKey = (primary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] - } - report = recipientEncryptionTargetsReportFromTKAtTimestamp signatureTime tk - acceptedFps = - map (fingerprint . recipientEncryptionTargetKey) (recipientEncryptionTargetsAccepted report) - rejectedReasons = - map recipientEncryptionTargetRejectedReason (recipientEncryptionTargetsRejected report) - assertBool - "report should keep encryption-eligible primary key as accepted" - (fingerprint primary `elem` acceptedFps) - assertEqual - "report should explain sign-only subkey rejection" - [RecipientTargetMissingEncryptionFlags subkey (Set.fromList [SignDataKey])] - rejectedReasons - -testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms :: Assertion -testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms = do - (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer - let tk = - TKUnknown - { _tkuKey = (signingPrimary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [] - } - report = - recipientEncryptionTargetsReportFromTKAtTimestamp - (_timestamp signingPrimary) - tk - assertEqual - "unsupported key algorithms should be surfaced in report rejections" - [RecipientTargetUnsupportedAlgorithm (_pkalgo signingPrimary)] - (map recipientEncryptionTargetRejectedReason (recipientEncryptionTargetsRejected report)) - -testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey :: Assertion -testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey = do - (baseKey, signingKey) <- loadUnencryptedRsaSigner - let signatureTime = ThirtyTwoBitTimeStamp 1700000000 - targetTime = ThirtyTwoBitTimeStamp 1700000020 - primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey - subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey - subkeyBindingSig <- - signSubkeyBindingWithRSAExtrasAt - primary - subkey - signingKey - signatureTime - [ SigSubPacket False (KeyFlags (Set.fromList [EncryptCommunicationsKey])) - , SigSubPacket False (KeyExpirationTime (ThirtyTwoBitDuration 5)) - ] - let tk = - TKUnknown - { _tkuKey = (primary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] - } - report = recipientEncryptionTargetsReportFromTKAtTimestamp targetTime tk - rejectedReasons = map recipientEncryptionTargetRejectedReason (recipientEncryptionTargetsRejected report) - assertBool - "expired subkey should be rejected from recipient targets" - (RecipientTargetNotValidAtTimestamp subkey targetTime `elem` rejectedReasons) - -testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey :: Assertion -testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey = do - (baseKey, signingKey) <- loadUnencryptedRsaSigner - let bindingTime = ThirtyTwoBitTimeStamp 1700000000 - revocationTime = ThirtyTwoBitTimeStamp 1700000005 - targetTime = ThirtyTwoBitTimeStamp 1700000010 - primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey - subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey - subkeyBindingSig <- - signSubkeyBindingWithRSAExtrasAt - primary - subkey - signingKey - bindingTime - [SigSubPacket False (KeyFlags (Set.fromList [EncryptCommunicationsKey]))] - subkeyRevocationSig <- - signSubkeyRevocationWithRSAAt - primary - subkey - signingKey - revocationTime - let tk = - TKUnknown - { _tkuKey = (primary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig, subkeyRevocationSig])] - } - report = recipientEncryptionTargetsReportFromTKAtTimestamp targetTime tk - rejectedReasons = map recipientEncryptionTargetRejectedReason (recipientEncryptionTargetsRejected report) - assertBool - "revoked subkey should be rejected from recipient targets" - (RecipientTargetRevoked subkey `elem` rejectedReasons) - -testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities :: Assertion -testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities = do - (primary, signingKey) <- loadUnencryptedRsaSigner - (subkey, _privateKey) <- loadUnencryptedRsaSigner - let signatureTime = ThirtyTwoBitTimeStamp 1700000000 - directKeySig <- - signDirectKeyWithRSAExtrasAt - primary - signingKey - signatureTime - [ SigSubPacket False (PreferredSymmetricAlgorithms [AES128]) - , SigSubPacket False (OtherSigSub 39 (BL.pack [9, 2, 7, 3])) - ] - subkeyBindingSig <- - signSubkeyBindingWithRSAExtrasAt - primary - subkey - signingKey - signatureTime - [SigSubPacket False (KeyFlags (Set.fromList [EncryptCommunicationsKey]))] - let tk = - TKUnknown - { _tkuKey = (primary, Nothing) - , _tkuRevs = [directKeySig] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] - } - targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk - case targets of - (target:_) -> - case recipientEncryptionTargetCapabilities target of - Nothing -> - assertFailure "Expected TKUnknown-derived target to include extracted capabilities" - Just caps -> do - assertEqual - "self-signature capability extraction should include primary-key symmetric preferences" - [AES128] - (recipientCapabilityPreferredSymmetricAlgorithms caps) - assertEqual - "self-signature capability extraction should include primary-key preferred AEAD algorithms" - [OCB, GCM] - (recipientCapabilityPreferredAEADAlgorithms caps) - assertEqual - "self-signature capability extraction should include subkey key flags" - (Set.fromList [EncryptCommunicationsKey]) - (recipientCapabilityKeyFlags caps) - [] -> - assertFailure "Expected at least one TKUnknown-derived target" - -testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering :: Assertion -testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering = do - (primary, signingKey) <- loadUnencryptedRsaSigner - (subkey, _privateKey) <- loadUnencryptedRsaSigner - let signatureTime = ThirtyTwoBitTimeStamp 1700000100 - beforeSignature = ThirtyTwoBitTimeStamp 1699999999 - subkeyBindingSig <- - signSubkeyBindingWithRSAExtrasAt - primary - subkey - signingKey - signatureTime - [SigSubPacket False (KeyFlags (Set.fromList [EncryptCommunicationsKey]))] - let tk = - TKUnknown - { _tkuKey = (primary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] - } - case recipientEncryptionTargetFromTKAtTimestamp beforeSignature tk of - Left err -> - assertFailure ("Expected timestamp-scoped TKUnknown target selection to succeed, got " ++ show err) - Right target -> - case recipientEncryptionTargetCapabilities target of - Nothing -> - assertFailure "Expected TKUnknown-derived target to include capabilities when timestamp-scoped" - Just caps -> - assertEqual - "subkey binding created after target timestamp should not contribute key flags" - Set.empty - (recipientCapabilityKeyFlags caps) - -testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary :: Assertion -testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary = do - (baseKey, signingKey) <- loadUnencryptedRsaSigner - let signatureTime = ThirtyTwoBitTimeStamp 1700000000 - primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey - subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey - subkeyBindingSig <- - signSubkeyBindingWithRSAExtrasAt - primary - subkey - signingKey - signatureTime - [SigSubPacket False (KeyFlags (Set.fromList [EncryptCommunicationsKey]))] - let tk = - TKUnknown - { _tkuKey = (primary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] - } - case recipientEncryptionTargetFromTKAtTimestampWithPolicy RecipientTargetSelectionPreferPrimary signatureTime tk of - Left err -> - assertFailure ("Expected policy-based recipient selection to succeed, got " ++ show err) - Right target -> - assertEqual - "prefer-primary policy should select primary key when both primary and subkey are valid" - (fingerprint primary) - (fingerprint (recipientEncryptionTargetKey target)) - -testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest :: Assertion -testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest = do - (baseKey, signingKey) <- loadUnencryptedRsaSigner - let signatureTime = ThirtyTwoBitTimeStamp 1700000000 - primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey - subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000002) baseKey - subkeyBindingSig <- - signSubkeyBindingWithRSAExtrasAt - primary - subkey - signingKey - signatureTime - [SigSubPacket False (KeyFlags (Set.fromList [EncryptCommunicationsKey]))] - let tk = - TKUnknown - { _tkuKey = (primary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] - } - case recipientEncryptionTargetFromTKAtTimestampWithPolicy RecipientTargetSelectionPreferNewestCreationTime signatureTime tk of - Left err -> - assertFailure ("Expected policy-based recipient selection to succeed, got " ++ show err) - Right target -> - assertEqual - "prefer-newest policy should select newest valid key" - (fingerprint subkey) - (fingerprint (recipientEncryptionTargetKey target)) - -testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags :: Assertion -testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags = do - (baseKey, signingKey) <- loadUnencryptedRsaSigner - let signatureTime = ThirtyTwoBitTimeStamp 1700000000 - primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey - subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey - subkeyBindingSig <- - signSubkeyBindingWithRSAExtrasAt - primary - subkey - signingKey - signatureTime - [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] - let tk = - TKUnknown - { _tkuKey = (primary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] - } - targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk - let subkeyFp = fingerprint subkey - primaryFp = fingerprint primary - targetFps = map (fingerprint . recipientEncryptionTargetKey) targets - assertBool - "subkey with sign-only key flags should be excluded from encryption targets" - (subkeyFp `notElem` targetFps) - assertBool - "primary key (no explicit flags) should still be included as encryption target" - (primaryFp `elem` targetFps) - -testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags :: Assertion -testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags = do - (baseKey, signingKey) <- loadUnencryptedRsaSigner - let signatureTime = ThirtyTwoBitTimeStamp 1700000000 - primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey - subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey - subkeyBindingSig <- - signSubkeyBindingWithRSAExtrasAt - primary - subkey - signingKey - signatureTime - [] - let tk = - TKUnknown - { _tkuKey = (primary, Nothing) - , _tkuRevs = [] - , _tkuUIDs = [] - , _tkuUAts = [] - , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] - } - targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk - let subkeyFp = fingerprint subkey - targetFps = map (fingerprint . recipientEncryptionTargetKey) targets - assertBool - "subkey with no key flags should be included as encryption target (legacy-compatible)" - (subkeyFp `elem` targetFps) - -testEncryptRecipientsWithRequestEmitsOnePassSignatures :: Assertion -testEncryptRecipientsWithRequestEmitsOnePassSignatures = do - (baseRecipient, privateKey) <- loadUnencryptedRsaSigner - let recipient = setKeyVersion V6 baseRecipient - signature = - SigV4 - BinarySig - RSA - SHA256 - [] - [SigSubPacket False (Issuer (EightOctetKeyId (BL.pack [0x01 .. 0x08])))] - 0 - (MPI 1 :| []) - payload = "recipient one-pass signature payload" - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = [recipientEncryptionTarget recipient] - , recipientEncryptRequestPayloadShape = - defaultRecipientPayloadShape - { recipientPayloadUseOnePassSignatures = True - , recipientPayloadSignatures = [signature] - } - , recipientEncryptRequestPayload = payload - , recipientEncryptRequestSymmetricOverride = Just AES256 - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv2Overrides - { recipientEncryptRequestAEADOverride = Just OCB - , recipientEncryptRequestChunkSizeOverride = Just 6 - , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x55)) - } - } - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipient - , pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey) - })) - passphraseCallback _ = pure BL.empty - result <- encryptForRecipients request - packets <- - case result of - Left err -> - assertFailure ("Expected one-pass encryption request to succeed, got " ++ show err) >> - fail "encryptForRecipients failed" - Right RecipientEncryptResult { recipientEncryptPackets = encryptedPackets } -> pure encryptedPackets - decrypted <- - DC.runConduitRes $ - CL.sourceList packets DC..| - conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 3 BinarySig SHA256 RSA _ False)), LiteralDataPkt _ _ _ gotPayload, SignaturePkt _] -> - assertEqual "decrypted payload matches original plaintext" (BL.fromStrict payload) gotPayload - other -> - assertFailure ("Expected decrypted [OPS3, LiteralData, Signature], got " ++ show other) - -testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing :: Assertion -testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing = do - (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner - let recipient = setKeyVersion V6 baseRecipient - signature = SigV4 BinarySig RSA SHA256 [] [] 0 (MPI 1 :| []) - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = [recipientEncryptionTarget recipient] - , recipientEncryptRequestPayloadShape = - defaultRecipientPayloadShape - { recipientPayloadUseOnePassSignatures = True - , recipientPayloadSignatures = [signature] - } - , recipientEncryptRequestPayload = "recipient one-pass missing issuer metadata payload" - , recipientEncryptRequestSymmetricOverride = Just AES256 - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv2Overrides - { recipientEncryptRequestAEADOverride = Just OCB - , recipientEncryptRequestChunkSizeOverride = Just 6 - , recipientEncryptRequestSaltOverride = Just (Salt (B.replicate 32 0x56)) - } - } - result <- encryptForRecipients request - case result of - Left (PayloadBuildFailure err) -> - assertBool - "missing issuer metadata should surface as payload build failure" - ("without issuer metadata" `isInfixOf` err) - Left err -> - assertFailure ("Expected PayloadBuildFailure for missing OPS issuer metadata, got " ++ show err) - Right _ -> - assertFailure "Expected one-pass request without issuer metadata to fail" - -testEncryptInteropLegacyProducesSEIPDv1 :: Assertion -testEncryptInteropLegacyProducesSEIPDv1 = do - (recipient, privateKey) <- loadUnencryptedRsaSigner - let iv = IV (B.replicate 16 0xAB) - payload = "legacy interop payload" - request = - RecipientEncryptRequest - { recipientEncryptRequestTargets = [recipientEncryptionTarget recipient] - , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape - , recipientEncryptRequestPayload = payload - , recipientEncryptRequestSymmetricOverride = Just AES256 - , recipientEncryptRequestOverrides = - RecipientEncryptRequestSEIPDv1Overrides - { recipientEncryptRequestIVOverride = Just iv - } - } - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipient - , pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey) - })) - passphraseCallback _ = pure BL.empty - result <- encryptForRecipients request - packets <- - case result of - Left err -> - assertFailure - ("Expected EncryptInteropLegacy request to succeed, got " ++ show err) >> - fail "encryptForRecipients failed" - Right RecipientEncryptResult { recipientEncryptPackets = ps } -> pure ps - let seipdPkts = [p | SymEncIntegrityProtectedDataPkt p <- packets] - case seipdPkts of - [SEIPD1 1 _] -> pure () - [SEIPD2 {}] -> assertFailure "Expected SEIPDv1 but got SEIPDv2" - other -> assertFailure ("Unexpected SEIPD packets: " ++ show other) - let pkeskPkts = [p | PKESKPkt p <- packets] - assertBool "EncryptInteropLegacy should emit PKESKv3 packets" $ - all (\p -> case p of { PKESKPayloadV3Packet {} -> True; _ -> False }) pkeskPkts - decrypted <- - DC.runConduitRes $ - CL.sourceList packets DC..| - conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual - "decrypted legacy interop payload matches original" - (BL.fromStrict payload) - gotPayload - other -> - assertFailure ("Expected [LiteralData] from legacy decrypt, got " ++ show other) - -testCanonicalizePKESKRecipientIdHelper :: Assertion -testCanonicalizePKESKRecipientIdHelper = do - let rid = BL.pack (0x04 : replicate 20 0x11) - payload = PKESKPayloadV6Packet (PKESKPayloadV6 rid RSA "esk") - case canonicalizePKESKRecipientId payload of - Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _)) - | BL.length normalized == 20 -> pure () - | otherwise -> - assertFailure ("Expected canonicalized recipient id length 20, got " ++ show (BL.length normalized)) - Left err -> - assertFailure ("canonicalizePKESKRecipientId failed unexpectedly: " ++ show err) - Right other -> - assertFailure ("Expected PKESK6 payload after canonicalization, got " ++ show other) - case canonicalizePKESKRecipientId (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.replicate 19 0x22) RSA "esk")) of - Left (InvalidRecipientIdentifier _) -> pure () - other -> - assertFailure ("Expected InvalidRecipientIdentifier for malformed rid, got " ++ show other) - case canonicalizePKESKRecipientId (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.pack (0x06 : replicate 32 0x33)) RSA "esk")) of - Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _)) - | BL.length normalized == 32 -> pure () - | otherwise -> - assertFailure ("Expected canonicalized v6 recipient id length 32, got " ++ show (BL.length normalized)) - other -> - assertFailure ("Expected 0x06-prefixed v6 recipient id to canonicalize, got " ++ show other) - case canonicalizePKESKRecipientId (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.pack (0x04 : replicate 32 0x44)) RSA "esk")) of - Left (InvalidRecipientIdentifier _) -> pure () - other -> - assertFailure - ("Expected InvalidRecipientIdentifier for mismatched v4-prefixed v6-length rid, got " ++ - show other) - -testBuildPKESKPayloadUnsupportedRecipient :: Assertion -testBuildPKESKPayloadUnsupportedRecipient = do - let recipient = - PKPayload - V6 - (ThirtyTwoBitTimeStamp 0) - 0 - EdDSA - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint 1))) - sessionKey = SessionKey (B.replicate 32 0x19) - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - result <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial - case result of - Left (UnsupportedRecipientAlgorithm EdDSA) -> pure () - Left err -> - assertFailure ("Expected UnsupportedRecipientAlgorithm EdDSA, got " ++ show err) - Right payload -> - assertFailure ("Expected UnsupportedRecipientAlgorithm, got payload: " ++ show payload) - -testBuildPKESKPayloadRejectsECDHSHA1 :: Assertion -testBuildPKESKPayloadRejectsECDHSHA1 = do - let (recipientPub, _) = syntheticNISTP256Low - recipient = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - ECDH - (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA1 AES256) - sessionKey = SessionKey (B.replicate 32 0x19) - sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey - result <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial - case result of - Left (RecipientKdfFailure ECDH err) - | "SHA1 is disallowed by policy" `isInfixOf` err -> pure () - | otherwise -> - assertFailure - ("Expected SHA1 policy rejection in RecipientKdfFailure, got: " ++ err) - Left err -> - assertFailure ("Expected RecipientKdfFailure ECDH for SHA1, got " ++ show err) - Right payload -> - assertFailure ("Expected SHA1 policy rejection, got payload: " ++ show payload) - -testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey :: Assertion -testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey = do - armoredMessage <- readFixtureStrict "seipdv2.pgp.aa" - armoredEncryptedSecret <- readFixtureStrict "v6-encrypted-secret.pgp.aa" - armoredPlainSecret <- readFixtureStrict "v6-secret.pgp.aa" - passphrase <- readPKIPassphrase - messageArmors <- - case (AA.decode armoredMessage :: Either String [Armor]) of - Left err -> assertFailure ("failed to decode seipdv2 armor: " ++ err) >> pure [] - Right as -> pure as - encryptedSecretArmors <- - case (AA.decode armoredEncryptedSecret :: Either String [Armor]) of - Left err -> - assertFailure ("failed to decode v6 encrypted secret armor: " ++ err) >> pure [] - Right as -> pure as - plainSecretArmors <- - case (AA.decode armoredPlainSecret :: Either String [Armor]) of - Left err -> - assertFailure ("failed to decode v6 plain secret armor: " ++ err) >> pure [] - Right as -> pure as - messageBody <- - case messageArmors of - (a:_) -> pure (armorPayload a) - [] -> assertFailure "seipdv2 armor file contained no armor blocks" >> pure mempty - encryptedSecretBody <- - case encryptedSecretArmors of - (a:_) -> pure (armorPayload a) - [] -> - assertFailure "v6-encrypted-secret armor file contained no armor blocks" >> - pure mempty - plainSecretBody <- - case plainSecretArmors of - (a:_) -> pure (armorPayload a) - [] -> - assertFailure "v6-secret armor file contained no armor blocks" >> - pure mempty - let messagePackets = parsePkts messageBody - encryptedSecretPackets = parsePkts encryptedSecretBody - plainSecretPackets = parsePkts plainSecretBody - passphraseCallback _ = pure BL.empty - encryptedKeyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase - plainKeyInfos <- collectSecretKeyInfos plainSecretPackets passphrase - let allKeyInfos = encryptedKeyInfos ++ plainKeyInfos - keyContextCallback pkt = pure (selectRecipientKeyInfo pkt allKeyInfos) - recipientKeyInfo = - case [pkt | pkt@(PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ _ _))) <- messagePackets] of - (pkt:_) -> selectRecipientKeyInfo pkt allKeyInfos - [] -> listToMaybe allKeyInfos - case recipientKeyInfo of - Nothing -> - assertFailure - ("no usable secret key material found in v6-encrypted-secret fixture: " ++ - show - ([(_pkalgo pkp, ska) | SecretKeyPkt pkp ska <- encryptedSecretPackets] ++ - [(_pkalgo pkp, ska) | SecretSubkeyPkt pkp ska <- encryptedSecretPackets])) - Just _ -> do - decrypted <- - DC.runConduitRes $ - CL.sourceList messagePackets DC..| - conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| - CL.consume - case [p | LiteralDataPkt _ _ _ p <- decrypted] of - (payload:_) -> - if BL.null payload - then assertFailure "fixture decrypt produced empty literal payload" - else pure () - [] -> - assertFailure - ("expected decrypted literal payload from seipdv2 fixture, got: " ++ - show decrypted) - -testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey :: Assertion -testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey = do - (messagePackets, encryptedSecretPackets, passphrase) <- - loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" - let - passphraseCallback _ = pure BL.empty - keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase - let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) - decrypted <- - DC.runConduitRes $ - CL.sourceList messagePackets DC..| - conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| - CL.consume - case [p | LiteralDataPkt _ _ _ p <- decrypted] of - (payload:_) -> - if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload - then pure () - else - assertFailure - ("unexpected decrypted payload for seipdv2-for-v4-key fixture: " ++ - show payload) - [] -> - assertFailure - ("expected decrypted literal payload from seipdv2-for-v4-key fixture, got: " ++ - show decrypted) - -testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK :: Assertion -testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK = do - (messagePackets, encryptedSecretPackets, passphrase) <- - loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" - let - bogusRid = BL.pack (0x06 : replicate 32 0x99) - bogusPKESK = PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk")) - (eskPrefix, encryptedSuffix) = span isPrecedingESK messagePackets - packetsWithBogusLatestPKESK = eskPrefix ++ [bogusPKESK] ++ encryptedSuffix - passphraseCallback _ = pure BL.empty - keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase - let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) - decrypted <- - DC.runConduitRes $ - CL.sourceList packetsWithBogusLatestPKESK DC..| - conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| - CL.consume - case [p | LiteralDataPkt _ _ _ p <- decrypted] of - (payload:_) -> - if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload - then pure () - else - assertFailure - ("unexpected decrypted payload for seipdv2-for-v4-key fixture with bogus latest PKESK: " ++ - show payload) - [] -> - assertFailure - ("expected decrypted literal payload with bogus latest PKESK, got: " ++ - show decrypted) - - -testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations :: Assertion -testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations = do - (messagePacketsRaw, encryptedSecretPackets, passphrase) <- - loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" - let messagePackets = map forceVersionedRecipientIdentifier messagePacketsRaw - passphraseCallback _ = pure BL.empty - keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase - let keyContextCallback pkt = pure (selectRecipientKeyInfoByRawRecipientId pkt keyInfos) - decrypted <- - DC.runConduitRes $ - CL.sourceList messagePackets DC..| - conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| - CL.consume - case [p | LiteralDataPkt _ _ _ p <- decrypted] of - (payload:_) -> - if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload - then pure () - else - assertFailure - ("unexpected decrypted payload for recipient-id normalization fixture: " ++ - show payload) - [] -> - assertFailure - ("expected decrypted literal payload for recipient-id normalization fixture, got: " ++ - show decrypted) - -testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial :: Assertion -testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial = do - armors <- loadArmor "seipdv2-for-v4-key.pgp.aa" - armor <- - case armors of - (a:_) -> pure a - [] -> - assertFailure "seipdv2-for-v4-key.pgp.aa should contain one armored payload" >> - fail "expected one armored payload" - let packets = parsePkts (armorPayload armor) - keyContextCallback _ = pure Nothing - passphraseCallback prompt = - fail ("unexpected manual PKESK session key prompt: " ++ prompt) - result <- - catch - (Right <$> (DC.runConduitRes $ CL.sourceList packets DC..| conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| CL.consume)) - (\e -> pure (Left (show (e :: SomeException)))) - case result of - Left err -> do - assertBool - "failure should report PKESK candidate exhaustion" - ("no matching key context" `isInfixOf` err) - assertBool - "failure should not request manual PKESK session material" - (not ("unexpected manual PKESK session key prompt" `isInfixOf` err)) - Right decrypted -> - assertFailure - ("expected decryption failure when no PKESK key context is available, got: " ++ - show decrypted) - -testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey :: Assertion -testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey = - testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform - "seipdv2-two-recipients.pgp.aa" - id - -testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey :: Assertion -testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey = - testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform - "seipdv2-three-recipients.pgp.aa" - id - -testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs :: Assertion -testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs = - testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform - "seipdv2-two-recipients.pgp.aa" - (prependUnusableLatestPKESK . reorderPrecedingPKESKs) - -testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs :: Assertion -testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs = - testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform - "seipdv2-three-recipients.pgp.aa" - (prependUnusableLatestPKESK . reorderPrecedingPKESKs) - -testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFile :: FilePath -> Assertion -testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFile fixture = - testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform - fixture - id - -testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform :: - FilePath - -> ([Pkt] -> [Pkt]) - -> Assertion -testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform fixture transformPackets = do - (messagePacketsRaw, encryptedSecretPackets, passphrase) <- loadSEIPDv2FixtureWithV4Secret fixture - let messagePackets = transformPackets messagePacketsRaw - passphraseCallback _ = pure BL.empty - keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase - let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) - decrypted <- - DC.runConduitRes $ - CL.sourceList messagePackets DC..| - conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| - CL.consume - case [p | LiteralDataPkt _ _ _ p <- decrypted] of - (payload:_) -> - if BL.null payload - then assertFailure (fixture ++ " decrypt produced empty literal payload") - else pure () - [] -> - assertFailure - ("expected decrypted literal payload from " ++ fixture ++ ", got: " ++ - show decrypted) - -testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey :: Assertion -testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey = do - let sessionKey = B.replicate 32 0x2a - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "v6 pkesk session key decrypt path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - packets ct = - [ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 "\x01\x02\x03\x04\x05\x06\x07\x08" RSA "\x99\x88\x77")) - , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct)) - ] - callback _ = pure (BL.fromStrict sessionKey) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList (packets ciphertext) DC..| conduitDecrypt callback DC..| CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESKv6 raw session-key decrypt payload" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength :: Assertion -testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength = do - let sessionKey = B.replicate 32 0x2a - badSessionKey = B.replicate 31 0x2a - salt = Salt (B.pack [0x00 .. 0x1f]) - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) "payload"] - packets ct = - [ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 "\x10\x11\x12\x13\x14\x15\x16\x17" RSA "\x01\x02\x03")) - , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct)) - ] - callback _ = pure (BL.fromStrict badSessionKey) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - result <- - catch - (Right <$> - (DC.runConduitRes $ - CL.sourceList (packets ciphertext) DC..| conduitDecrypt callback DC..| CL.consume)) - (\e -> pure (Left (show (e :: SomeException)))) - case result of - Left err -> - if "PKESK raw session key length does not match payload algorithm" `isInfixOf` err - then return () - else - assertFailure - ("Expected PKESKv6 raw session-key length validation failure, got: " ++ err) - Right got -> - assertFailure - ("Expected PKESKv6 raw session-key length failure, got packets: " ++ show got) - -testConduitDecryptSEIPDv2WithPKESKRSAUnwrap :: Assertion -testConduitDecryptSEIPDv2WithPKESKRSAUnwrap = do - (baseRecipient, privateKey) <- loadUnencryptedRsaSigner - publicKey <- - case _pubkey baseRecipient of - RSAPubKey (RSA_PublicKey pub) -> pure pub - other -> - assertFailure - ("unencrypted.seckey did not contain an RSA recipient, got " ++ show other) >> - fail "expected RSA recipient" - let sessionKey = B.replicate 32 0x2b - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk rsa unwrap decrypt path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = do - let msk = Just (RSAPrivateKey (RSA_PrivateKey privateKey)) - pure $ - fmap - (\sk -> - PKESKRecipientKey - { pkeskRecipientPKPayload = Nothing - , pkeskRecipientSKey = sk - }) - msk - encryptedResult <- (P15.encrypt publicKey sessionKey :: IO (Either RSA.Error B.ByteString)) - encryptedSessionMaterial <- - case encryptedResult of - Left err -> assertFailure ("RSA PKESK encryption failed: " ++ show err) >> pure mempty - Right ct -> pure ct - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - let pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\x11\x22\x33\x44\x55\x66\x77\x88") - RSA - (MPI (os2ip encryptedSessionMaterial) :| []))) - decrypted <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESK RSA unwrap decrypt payload" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback :: Assertion -testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback = do - (baseRecipient, privateKey) <- loadUnencryptedRsaSigner - publicKey <- - case _pubkey baseRecipient of - RSAPubKey (RSA_PublicKey pub) -> pure pub - other -> - assertFailure - ("unencrypted.seckey did not contain an RSA recipient, got " ++ show other) >> - fail "expected RSA recipient" - let sessionKey = B.replicate 32 0x2e - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk rsa unwrap decrypt path via wildcard callback fallback" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback pkt = - case pkt of - PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _)) - | BL.length rid == 8 && BL.all (== 0) rid -> - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Nothing - , pkeskRecipientSKey = - RSAPrivateKey (RSA_PrivateKey privateKey) - })) - _ -> pure Nothing - encryptedResult <- (P15.encrypt publicKey sessionKey :: IO (Either RSA.Error B.ByteString)) - encryptedSessionMaterial <- - case encryptedResult of - Left err -> assertFailure ("RSA PKESK encryption failed: " ++ show err) >> pure mempty - Right ct -> pure ct - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - let pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\xaa\xbb\xcc\xdd\xee\xff\x00\x11") - RSA - (MPI (os2ip encryptedSessionMaterial) :| []))) - decrypted <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESK RSA unwrap via wildcard callback fallback payload" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey :: Assertion -testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey = do - passphrase <- readPKIPassphrase - secretPackets <- - DC.runConduitRes $ - CB.sourceFile "tests/data/aes256-sha512.seckey" DC..| conduitGet get DC..| - CL.consume - keyInfos <- collectSecretKeyInfos secretPackets passphrase - keyInfo <- - case keyInfos of - (ki:_) -> pure ki - [] -> - assertFailure - "aes256-sha512.seckey should yield at least one RSA key context" >> - fail "expected key info" - publicKey <- - case pkeskRecipientPKPayload keyInfo of - Nothing -> - assertFailure "key info from file should include a public key payload" >> - fail "expected public key payload" - Just pkp -> - case _pubkey pkp of - RSAPubKey (RSA_PublicKey pub) -> pure pub - other -> - assertFailure - ("expected RSA public key from aes256-sha512.seckey, got " ++ show other) >> - fail "expected RSA public key" - let sessionKey = B.replicate 32 0x42 - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk rsa unwrap via sha1-cfb protected key loaded from file" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) - encryptedResult <- (P15.encrypt publicKey sessionKey :: IO (Either RSA.Error B.ByteString)) - encryptedSessionMaterial <- - case encryptedResult of - Left err -> - assertFailure ("RSA PKESK encryption failed: " ++ show err) >> pure mempty - Right ct -> pure ct - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - let pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\x11\x22\x33\x44\x55\x66\x77\x88") - RSA - (MPI (os2ip encryptedSessionMaterial) :| []))) - decrypted <- - DC.runConduitRes $ - CL.sourceList - [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual - "PKESK RSA unwrap with SHA1-CFB protected key from file" - payload - gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testConduitDecryptSEIPDv2WithPKESKECDHUnwrap :: Assertion -testConduitDecryptSEIPDv2WithPKESKECDHUnwrap = do - let (recipientPub, recipientPriv) = syntheticNISTP256Low - (ephPub, ephPriv) = syntheticNISTP256High - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - ECDH - (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA256 AES128) - recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) - sessionKey = B.replicate 32 0x2c - encodedSession = - B.singleton (fromFVal AES256) <> - sessionKey <> - encodeChecksum16 sessionKey <> - B.replicate 5 0 - sharedSecret = - BA.convert - (ECCDH.getShared - (ECDSA.public_curve recipientPub) - (ECDSA.private_d ephPriv) - (ECDSA.public_q recipientPub)) :: B.ByteString - kdfParam = - buildECDHKDFParamForTest recipientPKP ECDH (ECDSA.public_curve recipientPub) SHA256 AES128 - kek = deriveECDHKekForTest SHA256 AES128 sharedSecret kdfParam - wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek encodedSession - ephPointBytes = - maybe - (error "failed to encode ephemeral point") - id - (point2MBS (ECDSA.public_q ephPub)) - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") - ECDH - (MPI (os2ip ephPointBytes) :| [MPI (os2ip wrappedSession)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk ecdh unwrap decrypt path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = recipientSKey - })) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESK ECDH unwrap decrypt payload" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength :: Assertion -testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength = do - let (recipientPub, recipientPriv) = syntheticNISTP256Low - (ephPub, ephPriv) = syntheticNISTP256High - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - ECDH - (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA256 AES128) - recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) - sessionKey = B.replicate 32 0x2c - encodedSession = - B.singleton (fromFVal AES256) <> - sessionKey <> - encodeChecksum16 sessionKey <> - B.replicate 5 0 - sharedSecret = - BA.convert - (ECCDH.getShared - (ECDSA.public_curve recipientPub) - (ECDSA.private_d ephPriv) - (ECDSA.public_q recipientPub)) :: B.ByteString - kdfParam = - buildECDHKDFParamForTest recipientPKP ECDH (ECDSA.public_curve recipientPub) SHA256 AES128 - kek = deriveECDHKekForTest SHA256 AES128 sharedSecret kdfParam - wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek encodedSession - ephPointBytes = - maybe - (error "failed to encode ephemeral point") - id - (point2MBS (ECDSA.public_q ephPub)) - truncatedEphemeral = B.take (B.length ephPointBytes - 1) ephPointBytes - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") - ECDH - (MPI (os2ip truncatedEphemeral) :| [MPI (os2ip wrappedSession)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk ecdh wrong ephemeral point length" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = recipientSKey - })) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - result <- - catch - (Right <$> - DC.runConduitRes - (CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume)) - (\e -> pure (Left (show (e :: SomeException)))) - case result of - Left err -> - assertBool - "ECDH unwrap should reject wrong uncompressed point length for recipient curve" - ("invalid length for recipient curve" `isInfixOf` err) - Right packets -> - assertFailure ("Expected ECDH point-length validation failure, got: " ++ show packets) - -testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap :: Assertion -testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap = do - let recipientSecretRaw = B.pack [0x21 .. 0x40] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - recipientSKey = X25519PrivateKey recipientSecretRaw - ephSecretRaw = B.pack [0x41 .. 0x60] - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) - Right sk -> sk - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPub = - case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of - Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) - Right pk -> pk - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret - sessionKey = SessionKey (B.replicate 32 0x6a) - wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) - eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef") - X25519 - (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk x25519 v3 unwrap decrypt path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = recipientSKey - })) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESK X25519 v3 unwrap decrypt payload" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - - -testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder :: Assertion -testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder = do - let recipientSecretRaw = B.pack [0x21 .. 0x40] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - recipientSKey = X25519PrivateKey recipientSecretRaw - wrongRecipientSecretRaw = B.pack [0x61 .. 0x80] - wrongRecipientSecret = - case CE.eitherCryptoError (C25519.secretKey wrongRecipientSecretRaw) of - Left err -> error ("failed to initialize wrong X25519 recipient secret key: " ++ show err) - Right sk -> sk - wrongRecipientPublicRaw = BA.convert (C25519.toPublic wrongRecipientSecret) :: B.ByteString - wrongRecipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip wrongRecipientPublicRaw)))) - wrongRecipientSKey = X25519PrivateKey wrongRecipientSecretRaw - ephSecretRaw = B.pack [0x41 .. 0x60] - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) - Right sk -> sk - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPub = - case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of - Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) - Right pk -> pk - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret - sessionKey = SessionKey (B.replicate 32 0x6b) - wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) - eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId (BL.replicate 8 0)) - X25519 - (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk x25519 v3 wildcard key-id retry path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - wrongKeyInfo = - PKESKRecipientKey - { pkeskRecipientPKPayload = Just wrongRecipientPKP - , pkeskRecipientSKey = wrongRecipientSKey - } - correctKeyInfo = - PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = recipientSKey - } - keyContextCallback _rid _pka = pure [wrongKeyInfo, correctKeyInfo] - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithCandidatesCallbackAndPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESKv3 wildcard-keyid retries across recipient key order" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - - -testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder :: Assertion -testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder = do - let recipientSecretRaw = B.pack [0x21 .. 0x40] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - ephSecretRaw = B.pack [0x41 .. 0x60] - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) - Right sk -> sk - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPub = - case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of - Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) - Right pk -> pk - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret - sessionKey = SessionKey (B.replicate 32 0x6c) - wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) - eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId (BL.replicate 8 0)) - X25519 - (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk x25519 v3 wildcard key-id long retry path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - mkSecretBytes offset = - B.pack [fromIntegral ((offset + i) `mod` 256) | i <- [0 .. 31 :: Int]] - mkX25519RecipientKeyInfo label secretRaw = - let sk = - case CE.eitherCryptoError (C25519.secretKey secretRaw) of - Left err -> error ("failed to initialize " ++ label ++ " X25519 secret key: " ++ show err) - Right secretKey -> secretKey - publicRaw = BA.convert (C25519.toPublic sk) :: B.ByteString - in PKESKRecipientKey - { pkeskRecipientPKPayload = - Just - (PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip publicRaw))))) - , pkeskRecipientSKey = X25519PrivateKey secretRaw - } - wrongKeyInfos = - [ mkX25519RecipientKeyInfo ("wrong-" ++ show n) (mkSecretBytes (96 + n * 7)) - | n <- [1 .. 20 :: Int] - ] - correctKeyInfo = mkX25519RecipientKeyInfo "correct" recipientSecretRaw - keyContextCallback _rid _pka = pure (wrongKeyInfos ++ [correctKeyInfo]) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithCandidatesCallbackAndPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESKv3 wildcard-keyid retries long recipient key order" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - - -testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder :: Assertion -testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder = do - let recipientSecretRaw = B.pack [0x21 .. 0x40] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - ephSecretRaw = B.pack [0x41 .. 0x60] - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) - Right sk -> sk - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPub = - case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of - Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) - Right pk -> pk - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret - sessionKey = SessionKey (B.replicate 32 0x6d) - wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) - eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId (BL.replicate 8 0)) - X25519 - (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) - payload = "pkesk x25519 v3 wildcard key-id long retry legacy seipd1 path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - cleartext = BL.toStrict (runPut (put literalBlock)) - iv = IV (B.pack [0x33 .. 0x42]) - cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext - passphraseCallback _ = pure BL.empty - mkSecretBytes offset = - B.pack [fromIntegral ((offset + i) `mod` 256) | i <- [0 .. 31 :: Int]] - mkX25519RecipientKeyInfo label secretRaw = - let sk = - case CE.eitherCryptoError (C25519.secretKey secretRaw) of - Left err -> error ("failed to initialize " ++ label ++ " X25519 secret key: " ++ show err) - Right secretKey -> secretKey - publicRaw = BA.convert (C25519.toPublic sk) :: B.ByteString - in PKESKRecipientKey - { pkeskRecipientPKPayload = - Just - (PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip publicRaw))))) - , pkeskRecipientSKey = X25519PrivateKey secretRaw - } - wrongKeyInfos = - [ mkX25519RecipientKeyInfo ("wrong-" ++ show n) (mkSecretBytes (96 + n * 7)) - | n <- [1 .. 20 :: Int] - ] - correctKeyInfo = mkX25519RecipientKeyInfo "correct" recipientSecretRaw - keyContextCallback _rid _pka = pure (wrongKeyInfos ++ [correctKeyInfo]) - ciphertext <- - either - (\e -> assertFailure ("encryptOpenPGPCfbRaw failed: " ++ show e) >> pure mempty) - pure - (encryptOpenPGPCfbRaw OpenPGPCFBNoResyncW AES256 iv cleartextWithMDC (unSessionKey sessionKey)) - decrypted <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD1 1 (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithCandidatesCallbackAndPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESKv3 wildcard-keyid retries long recipient key order for SEIPDv1" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - - -testMkCandidateResolverDecryptsWildcardPKESKv3 :: Assertion -testMkCandidateResolverDecryptsWildcardPKESKv3 = do - let recipientSecretRaw = B.pack [0x21 .. 0x40] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - recipientSKey = X25519PrivateKey recipientSecretRaw - wrongSecretRaw = B.pack [0x61 .. 0x80] - wrongSecret = - case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of - Left err -> error ("failed to initialize wrong X25519 secret key: " ++ show err) - Right sk -> sk - wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString - wrongPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip wrongPublicRaw)))) - wrongSKey = X25519PrivateKey wrongSecretRaw - ephSecretRaw = B.pack [0x41 .. 0x60] - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) - Right sk -> sk - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPub = - case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of - Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) - Right pk -> pk - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret - sessionKey = SessionKey (B.replicate 32 0x6d) - wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) - eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId (BL.replicate 8 0)) - X25519 - (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "unwrap callback wildcard path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - wrongKeyInfo = - PKESKRecipientKey {pkeskRecipientPKPayload = Just wrongPKP, pkeskRecipientSKey = wrongSKey} - correctKeyInfo = - PKESKRecipientKey {pkeskRecipientPKPayload = Just recipientPKP, pkeskRecipientSKey = recipientSKey} - let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo] - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - (void $ - DCD.conduitDecrypt - DCD.DecryptOptions - { DCD.decryptOptionsKeyResolution = DCD.DecryptWithUnwrapCandidatesCallback resolver - , DCD.decryptOptionsPolicy = lenientDecryptPolicy - , DCD.decryptOptionsPassphraseCallback = passphraseCallback - }) DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "unwrap callback should decrypt wildcard PKESK via candidate list" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - - -testConduitDecryptWildcardResolverProvidesTypedPreviousFailures :: Assertion -testConduitDecryptWildcardResolverProvidesTypedPreviousFailures = do - let recipientSecretRaw = B.pack [0x21 .. 0x40] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - recipientSKey = X25519PrivateKey recipientSecretRaw - wrongSecretRaw = B.pack [0x61 .. 0x80] - wrongSecret = - case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of - Left err -> error ("failed to initialize wrong X25519 secret key: " ++ show err) - Right sk -> sk - wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString - wrongPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip wrongPublicRaw)))) - wrongSKey = X25519PrivateKey wrongSecretRaw - ephSecretRaw = B.pack [0x41 .. 0x60] - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) - Right sk -> sk - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPub = - case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of - Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) - Right pk -> pk - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret - sessionKey = SessionKey (B.replicate 32 0x6e) - wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) - eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId (BL.replicate 8 0)) - X25519 - (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "typed previous failures for wildcard retries" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - wrongKeyInfo = - PKESKRecipientKey {pkeskRecipientPKPayload = Just wrongPKP, pkeskRecipientSKey = wrongSKey} - correctKeyInfo = - PKESKRecipientKey {pkeskRecipientPKPayload = Just recipientPKP, pkeskRecipientSKey = recipientSKey} - let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo] - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - (void $ - DCD.conduitDecrypt - DCD.DecryptOptions - { DCD.decryptOptionsKeyResolution = DCD.DecryptWithUnwrapCandidatesCallback resolver - , DCD.decryptOptionsPolicy = lenientDecryptPolicy - , DCD.decryptOptionsPassphraseCallback = passphraseCallback - }) DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "wildcard retries with typed previous failures should still decrypt" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - pure () - - -testConduitDecryptWithReportCapturesWildcardResolverDiagnostics :: Assertion -testConduitDecryptWithReportCapturesWildcardResolverDiagnostics = do - let recipientSecretRaw = B.pack [0x21 .. 0x40] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - recipientSKey = X25519PrivateKey recipientSecretRaw - wrongSecretRaw = B.pack [0x61 .. 0x80] - wrongSecret = - case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of - Left err -> error ("failed to initialize wrong X25519 secret key: " ++ show err) - Right sk -> sk - wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString - wrongPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip wrongPublicRaw)))) - wrongSKey = X25519PrivateKey wrongSecretRaw - ephSecretRaw = B.pack [0x41 .. 0x60] - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) - Right sk -> sk - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPub = - case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of - Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) - Right pk -> pk - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret - sessionKey = SessionKey (B.replicate 32 0x6f) - wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) - eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId (BL.replicate 8 0)) - X25519 - (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "conduitDecryptWithReport wildcard diagnostics" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - wrongKeyInfo = - PKESKRecipientKey {pkeskRecipientPKPayload = Just wrongPKP, pkeskRecipientSKey = wrongSKey} - correctKeyInfo = - PKESKRecipientKey {pkeskRecipientPKPayload = Just recipientPKP, pkeskRecipientSKey = recipientSKey} - let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo] - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - (report, decrypted) <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - DC.fuseBoth - (DCD.conduitDecryptWithReport - DCD.DecryptOptions - { DCD.decryptOptionsKeyResolution = DCD.DecryptWithUnwrapCandidatesCallback resolver - , DCD.decryptOptionsPolicy = lenientDecryptPolicy - , DCD.decryptOptionsPassphraseCallback = passphraseCallback - }) - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "wildcard retries with report diagnostics should decrypt" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - assertEqual "decrypt report should preserve outcome" DCD.DecryptClean (DCD.decryptReportOutcome report) - case DCD.decryptReportSessionKeyResolutions report of - [resolution] -> do - assertEqual "resolution path should be PKESK for wildcard key retries" DCD.DecryptResolvedViaPKESK (DCD.decryptSessionResolutionPath resolution) - let attempts = DCD.decryptSessionResolutionResolverAttempts resolution - assertBool - "report should contain wildcard resolver attempts" - (length attempts >= 2) - assertBool - "report should record typed previous failures in resolver attempt context" - (any - (\attempt -> - any - (\failure -> - DCD.pkeskAttemptFailureKind failure == DCD.PKESKAttemptUnwrapFailed && - DCD.pkeskAttemptFailureKeyContext failure == Just (V4, X25519)) - (DCD.pkeskResolverAttemptPreviousFailures attempt)) - attempts) - assertBool - "report should capture ResolveWith key context for X25519" - (any - (\attempt -> - DCD.pkeskResolverAttemptAction attempt == - DCD.ResolverAttemptResolveWith (Just (V4, X25519))) - attempts) - other -> - assertFailure - ("Expected exactly one session-key resolution report, got " ++ show (length other)) - -testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength :: Assertion -testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength = do - let recipientSecretRaw = B.pack [0x21 .. 0x40] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - recipientSKey = X25519PrivateKey recipientSecretRaw - ephSecretRaw = B.pack [0x41 .. 0x60] - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) - Right sk -> sk - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPub = - case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of - Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) - Right pk -> pk - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret - sessionKey = SessionKey (B.replicate 32 0x6a) - wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) - eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession - overlongEphemeral = ephPublicRaw <> "\x00\x01" - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef") - X25519 - (MPI (os2ip overlongEphemeral) :| [MPI (os2ip eskWithAlgo)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk x25519 v3 wrong ephemeral length" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = recipientSKey - })) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - result <- - catch - (Right <$> - DC.runConduitRes - (CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume)) - (\e -> pure (Left (show (e :: SomeException)))) - case result of - Left err -> - assertBool - "PKESKv3 X25519 unwrap should reject non-32-byte ephemeral values" - ("invalid X25519 ephemeral public key length/prefix" `isInfixOf` err) - Right packets -> - assertFailure - ("Expected X25519 ephemeral-length validation failure, got: " ++ show packets) - -testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519 :: Assertion -testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519 = do - let recipientSecretRaw = B.pack [0x21 .. 0x40] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X25519 recipient secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - recipientSKey = X25519PrivateKey recipientSecretRaw - ephSecretRaw = B.pack [0x41 .. 0x60] - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize X25519 ephemeral secret key: " ++ show err) - Right sk -> sk - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPub = - case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of - Left err -> error ("failed to initialize X25519 recipient public key: " ++ show err) - Right pk -> pk - sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString - kek = deriveX25519KekForTest ephPublicRaw recipientPublicRaw sharedSecret - sessionKeyBytes = B.replicate 32 0x6a - sessionKey = SessionKey sessionKeyBytes - wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek sessionKeyBytes - eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef") - X25519 - (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]))) - skeskS2K = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 - skeskPassphrase = "correct horse battery staple" - wrongPassphrase = "wrong passphrase" - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "skesk->pkesk fallback decrypt path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = recipientSKey - })) - passphraseCallback _ = pure wrongPassphrase - keyLen <- - case keySize AES256 of - Left err -> assertFailure ("keySize failed for AES256: " ++ show err) >> fail "keySize failed" - Right n -> pure n - skeskKek <- - case string2Key skeskS2K keyLen skeskPassphrase of - Left err -> assertFailure ("string2Key failed for Argon2 SKESK: " ++ renderS2KError err) >> fail "string2Key failed" - Right x -> pure x - skeskEncryptedEsk <- - case withSymmetricCipher AES256 skeskKek $ \cipher -> - paddedCfbEncrypt - cipher - (B.replicate (blockSize cipher) 0) - (B.singleton (fromFVal AES256) <> sessionKeyBytes) of - Left err -> assertFailure ("encrypting Argon2 SKESK ESK failed: " ++ show err) >> fail "encrypting SKESK ESK failed" - Right x -> pure x - let skesk = - SKESKPkt - (SKESKPayloadV4Packet - (SKESKPayloadV4 AES256 skeskS2K (Just (BL.fromStrict skeskEncryptedEsk)))) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList - [ skesk - , pkesk - , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) - ] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual - "conduitDecrypt should fall back from failing Argon2 SKESK to PKESKv3 X25519" - payload - gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK :: Assertion -testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK = do - let skeskS2K = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 - passphrase = "password" - sessionKeyBytes = B.replicate 32 0x7b - sessionKey = SessionKey sessionKeyBytes - badLatestEsk = BL.fromStrict (B.pack [0x00]) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "earlier argon2 skesk fallback decrypt path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure passphrase - keyLen <- - case keySize AES256 of - Left err -> assertFailure ("keySize failed for AES256: " ++ show err) >> fail "keySize failed" - Right n -> pure n - skeskKek <- - case string2Key skeskS2K keyLen passphrase of - Left err -> assertFailure ("string2Key failed for Argon2 SKESK: " ++ renderS2KError err) >> fail "string2Key failed" - Right x -> pure x - validEsk <- - case withSymmetricCipher AES256 skeskKek $ \cipher -> - paddedCfbEncrypt - cipher - (B.replicate (blockSize cipher) 0) - (B.singleton (fromFVal AES256) <> sessionKeyBytes) of - Left err -> assertFailure ("encrypting Argon2 SKESK ESK failed: " ++ show err) >> fail "encrypting SKESK ESK failed" - Right x -> pure x - let earlierValidSKESK = - SKESKPkt - (SKESKPayloadV4Packet - (SKESKPayloadV4 AES256 skeskS2K (Just (BL.fromStrict validEsk)))) - latestUnusableSKESK = - SKESKPkt - (SKESKPayloadV4Packet - (SKESKPayloadV4 AES256 skeskS2K (Just badLatestEsk))) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList - [ earlierValidSKESK - , latestUnusableSKESK - , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) - ] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual - "conduitDecrypt should retry earlier Argon2 SKESK when latest SKESK is unusable" - payload - gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testConduitDecryptSEIPDv2RejectsECDHNonTable30Params :: Assertion -testConduitDecryptSEIPDv2RejectsECDHNonTable30Params = do - let (recipientPub, recipientPriv) = syntheticNISTP256Low - (ephPub, ephPriv) = syntheticNISTP256High - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - ECDH - (ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey recipientPub)) SHA256 AES256) - recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) - sessionKey = B.replicate 32 0x2c - encodedSession = - B.singleton (fromFVal AES256) <> - sessionKey <> - encodeChecksum16 sessionKey <> - B.replicate 5 0 - sharedSecret = - BA.convert - (ECCDH.getShared - (ECDSA.public_curve recipientPub) - (ECDSA.private_d ephPriv) - (ECDSA.public_q recipientPub)) :: B.ByteString - kdfParam = - buildECDHKDFParamForTest recipientPKP ECDH (ECDSA.public_curve recipientPub) SHA256 AES256 - kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam - wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession - ephPointBytes = - maybe - (error "failed to encode ephemeral point") - id - (point2MBS (ECDSA.public_q ephPub)) - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") - ECDH - (MPI (os2ip ephPointBytes) :| [MPI (os2ip wrappedSession)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk ecdh unwrap policy failure path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = recipientSKey - })) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - result <- - catch - (Right <$> - DC.runConduitRes - (CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume)) - (\e -> pure (Left (show (e :: SomeException)))) - case result of - Left err -> - assertBool - "ECDH unwrap should reject non-Table-30 parameters" - ("Table 30 policy violation" `isInfixOf` err) - Right packets -> - assertFailure - ("Expected Table 30 policy failure, got decrypted packets: " ++ show packets) - -testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams :: Assertion -testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams = do - let recipientSecretRaw = B.pack [1 .. 32] - ephSecretRaw = B.pack [101 .. 132] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize Curve25519Legacy recipient secret key: " ++ show err) - Right sk -> sk - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize Curve25519Legacy ephemeral secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - ECDH - (ECDHPubKey - (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 recipientPublicRaw))))) - SHA256 - AES256) - recipientSKey = - ECDHPrivateKey - (ECDSA_PrivateKey - (ECDSA.PrivateKey (ECCT.getCurveByName ECCT.SEC_p256r1) (os2ip recipientSecretRaw))) - sessionKey = B.replicate 32 0x3d - encodedSession = - B.singleton (fromFVal AES256) <> - sessionKey <> - encodeChecksum16 sessionKey <> - B.replicate 5 0 - sharedSecret = BA.convert (C25519.dh (C25519.toPublic ephSecret) recipientSecret) :: B.ByteString - kdfParam = buildCurve25519LegacyKdfParamForTest recipientPKP ECDH SHA256 AES256 - kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam - wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") - ECDH - (MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk ecdh v4 curve25519legacy accepted-combo path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = recipientSKey - })) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual - "v4 Curve25519Legacy ECDH should allow RFC6637-accepted parameters" - payload - gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI :: Assertion -testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI = do - let recipientSecretRaw = B.pack [1 .. 32] - ephSecretRaw = B.pack [101 .. 132] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize Curve25519Legacy recipient secret key: " ++ show err) - Right sk -> sk - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize Curve25519Legacy ephemeral secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPKP = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - ECDH - (ECDHPubKey - (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 recipientPublicRaw))))) - SHA256 - AES256) - recipientSKey = - ECDHPrivateKey - (ECDSA_PrivateKey - (ECDSA.PrivateKey (ECCT.getCurveByName ECCT.SEC_p256r1) (os2ip recipientSecretRaw))) - sharedSecret = BA.convert (C25519.dh (C25519.toPublic ephSecret) recipientSecret) :: B.ByteString - kdfParam = buildCurve25519LegacyKdfParamForTest recipientPKP ECDH SHA256 AES256 - kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam - candidate = - find - (\(_, wrappedSession) -> not (B.null wrappedSession) && B.head wrappedSession == 0x00) - [ let sessionKeyBytes = - B.pack - [ fromIntegral ((seed + offset) `mod` 256) - | offset <- [0 .. 31] - ] - encodedSession = - B.singleton (fromFVal AES256) <> - sessionKeyBytes <> - encodeChecksum16 sessionKeyBytes <> - B.replicate 5 0 - wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession - in (SessionKey sessionKeyBytes, wrappedSession) - | seed <- [0 .. 4095 :: Int] - ] - case candidate of - Nothing -> - assertFailure - "failed to find deterministic Curve25519Legacy wrapped session key with leading zero" - Just (sessionKey, wrappedSession) -> do - let pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") - ECDH - (MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk ecdh v4 curve25519legacy truncated wrapped-mpi path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = recipientSKey - })) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt sessionKey (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList - [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual - "v4 Curve25519Legacy ECDH should unwrap after wrapped-MPI leading-zero truncation" - payload - gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params :: Assertion -testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params = do - let recipientSecretRaw = B.pack [1 .. 32] - ephSecretRaw = B.pack [101 .. 132] - recipientSecret = - case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize Curve25519Legacy recipient secret key: " ++ show err) - Right sk -> sk - ephSecret = - case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize Curve25519Legacy ephemeral secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString - ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString - recipientPKP = - PKPayload - V6 - (ThirtyTwoBitTimeStamp 0) - 0 - ECDH - (ECDHPubKey - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - SHA512 - AES256) - recipientSKey = - ECDHPrivateKey - (ECDSA_PrivateKey - (ECDSA.PrivateKey (ECCT.getCurveByName ECCT.SEC_p256r1) (os2ip recipientSecretRaw))) - sessionKey = B.replicate 32 0x3d - encodedSession = - B.singleton (fromFVal AES256) <> - sessionKey <> - encodeChecksum16 sessionKey <> - B.replicate 5 0 - sharedSecret = BA.convert (C25519.dh (C25519.toPublic ephSecret) recipientSecret) :: B.ByteString - kdfParam = buildCurve25519LegacyKdfParamForTest recipientPKP ECDH SHA512 AES256 - kek = deriveECDHKekForTest SHA512 AES256 sharedSecret kdfParam - wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession - pkesk = - PKESKPkt - (PKESKPayloadV3Packet - (PKESKPayloadV3 - 3 - (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") - ECDH - (MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)]))) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk ecdh v6 curve25519legacy strict path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = recipientSKey - })) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - result <- - catch - (Right <$> - DC.runConduitRes - (CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback DC..| - CL.consume)) - (\e -> pure (Left (show (e :: SomeException)))) - case result of - Left err -> - assertBool - "v6 Curve25519Legacy ECDH should remain strict" - ("Table 30 policy violation" `isInfixOf` err) - Right packets -> - assertFailure - ("Expected Table 30 policy failure, got decrypted packets: " ++ show packets) - -testConduitDecryptSEIPDv2WithPKESKX448Unwrap :: Assertion -testConduitDecryptSEIPDv2WithPKESKX448Unwrap = do - let recipientSecretRaw = B.pack [1 .. 56] - ephSecretRaw = B.pack [57 .. 112] - sessionKey = B.replicate 32 0x4d - encodedSession = - B.singleton (fromFVal AES256) <> - sessionKey <> - encodeChecksum16 sessionKey <> - B.replicate 5 0 - recipientSecret = - case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X448 recipient secret key: " ++ show err) - Right sk -> sk - ephSecret = - case CE.eitherCryptoError (C448.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize X448 ephemeral secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString - ephPublicRaw = BA.convert (C448.toPublic ephSecret) :: B.ByteString - sharedSecret = BA.convert (C448.dh (C448.toPublic recipientSecret) ephSecret) :: B.ByteString - kek = deriveX448KekForTest ephPublicRaw recipientPublicRaw sharedSecret - wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession - esk = - ephPublicRaw <> - B.singleton (fromIntegral (B.length wrappedSession)) <> - wrappedSession - recipientPKP = - PKPayload - V6 - (ThirtyTwoBitTimeStamp 0) - 0 - X448 - (EdDSAPubKey Ed448 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - recipientRid = unFingerprint (fingerprint recipientPKP) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk x448 unwrap decrypt path" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = X448PrivateKey recipientSecretRaw - })) - pkesk = - PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientRid X448 (BL.fromStrict esk))) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - decrypted <- - DC.runConduitRes $ - CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| - CL.consume - case decrypted of - [LiteralDataPkt _ _ _ gotPayload] -> - assertEqual "PKESK X448 unwrap decrypt payload" payload gotPayload - other -> - assertFailure ("Expected one decrypted literal packet, got " ++ show other) - -testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength :: Assertion -testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength = do - let recipientSecretRaw = B.pack [1 .. 56] - ephSecretRaw = B.pack [57 .. 112] - sessionKey = B.replicate 32 0x4d - encodedSession = - B.singleton (fromFVal AES256) <> - sessionKey <> - encodeChecksum16 sessionKey <> - B.replicate 5 0 - recipientSecret = - case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of - Left err -> error ("failed to initialize X448 recipient secret key: " ++ show err) - Right sk -> sk - ephSecret = - case CE.eitherCryptoError (C448.secretKey ephSecretRaw) of - Left err -> error ("failed to initialize X448 ephemeral secret key: " ++ show err) - Right sk -> sk - recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString - ephPublicRaw = BA.convert (C448.toPublic ephSecret) :: B.ByteString - shortEphemeral = B.tail ephPublicRaw - sharedSecret = BA.convert (C448.dh (C448.toPublic recipientSecret) ephSecret) :: B.ByteString - kek = deriveX448KekForTest ephPublicRaw recipientPublicRaw sharedSecret - wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession - esk = - shortEphemeral <> - B.singleton (fromIntegral (B.length wrappedSession)) <> - wrappedSession - recipientPKP = - PKPayload - V6 - (ThirtyTwoBitTimeStamp 0) - 0 - X448 - (EdDSAPubKey Ed448 (NativeEPoint (EPoint (os2ip recipientPublicRaw)))) - recipientRid = unFingerprint (fingerprint recipientPKP) - salt = Salt (B.pack [0x00 .. 0x1f]) - payload = "pkesk x448 wrong ephemeral length" - literalBlock = - Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) payload] - passphraseCallback _ = pure BL.empty - keyContextCallback _ = - pure - (Just - (PKESKRecipientKey - { pkeskRecipientPKPayload = Just recipientPKP - , pkeskRecipientSKey = X448PrivateKey recipientSecretRaw - })) - pkesk = - PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientRid X448 (BL.fromStrict esk))) - ciphertext <- - case encryptSEIPDv2Payload AES256 OCB 6 salt (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of - Left err -> assertFailure ("encryptSEIPDv2Payload failed: " ++ err) >> pure mempty - Right ct -> pure ct - result <- - catch - (Right <$> - DC.runConduitRes - (CL.sourceList [pkesk, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))] DC..| - conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| - CL.consume)) - (\e -> pure (Left (show (e :: SomeException)))) - case result of - Left err -> - assertBool - "PKESKv6 X448 unwrap should reject non-56-byte ephemeral values" - ("expected 56-octet ephemeral value" `isInfixOf` err) - Right packets -> - assertFailure - ("Expected X448 ephemeral-length validation failure, got: " ++ show packets) - -testDecodeOpenPGPEncodedSessionKeyRejectsTooShort :: Assertion -testDecodeOpenPGPEncodedSessionKeyRejectsTooShort = - assertEqual - "encoded session key should reject too-short payloads" - (Left EncodedSessionKeyTooShort) - (decodeOpenPGPEncodedSessionKey (B.pack [0x09, 0x01])) - -testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch :: Assertion -testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch = - assertEqual - "encoded session key should reject algorithm/key-length mismatches" - (Left (EncodedSessionKeyLengthMismatch AES128 16 3)) - (decodeOpenPGPEncodedSessionKey (B.pack [fromFVal AES128, 0x01, 0x02, 0x03])) - -testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch :: Assertion -testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch = - assertEqual - "encoded session key should reject checksum mismatches" - (Left EncodedSessionKeyChecksumMismatch) - (decodeOpenPGPEncodedSessionKey (B.pack ([fromFVal AES128] <> replicate 16 0x00 <> [0x00, 0x01]))) - -testSKESKRejectsUnknownVersion :: Assertion -testSKESKRejectsUnknownVersion = do - let s2k = Simple SHA256 - pkt = SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 AES128 s2k Nothing)) - encoded = BL.toStrict (runPut (put pkt)) - malformed = BL.fromStrict (B.take 2 encoded <> B.singleton 5 <> B.drop 3 encoded) - case runGet (get :: Get Pkt) malformed of - Right (BrokenPacketPkt errReason 3 _) -> - assertBool - ("expected unsupported SKESK version error, got: " ++ errReason) - ("unsupported SKESK packet version" `isInfixOf` errReason) - Right other -> - assertFailure ("unknown SKESK version should not parse successfully: " ++ show other) - Left err -> - assertFailure ("unknown SKESK version should be reported as a broken packet: " ++ err) - -testSKESK4EncryptedSessionKeyRejectsSimpleS2K :: Assertion -testSKESK4EncryptedSessionKeyRejectsSimpleS2K = do - let pkt = - SKESKPkt - (SKESKPayloadV4Packet - (SKESKPayloadV4 AES128 (Simple SHA256) (Just (BL.pack [0x01, 0x02, 0x03])))) - encoded = runPut (put pkt) - case runGet (get :: Get Pkt) encoded of - Right (BrokenPacketPkt errReason 3 _) -> - assertBool - ("expected Simple S2K rejection, got: " ++ errReason) - ("must not use Simple S2K" `isInfixOf` errReason) - Right other -> - assertFailure - ("Simple-S2K v4 SKESK with encrypted session key should not parse successfully: " ++ - show other) - Left err -> - assertFailure - ("Simple-S2K v4 SKESK with encrypted session key should be reported as a broken packet: " ++ - err) - -testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES :: Assertion -testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES = - mapM_ assertRoundTrip [AES128, AES192, AES256] - where - passphrase = "password" - s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 - assertRoundTrip sa = do - keyLen <- - case keySize sa of - Left err -> assertFailure ("keySize failed for " ++ show sa ++ ": " ++ show err) >> fail "keySize failed" - Right n -> pure n - kek <- - case string2Key s2k keyLen passphrase of - Left err -> - assertFailure ("string2Key failed for " ++ show sa ++ ": " ++ renderS2KError err) >> - fail "string2Key failed" - Right x -> pure x - let sessionKey = B.pack (take keyLen (cycle [0x11, 0x22, 0x33, 0x44])) - encodedSessionKey = B.singleton (fromFVal sa) <> sessionKey - encryptedEsk <- - case withSymmetricCipher sa kek $ \cipher -> - paddedCfbEncrypt - cipher - (B.replicate (blockSize cipher) 0) - encodedSessionKey of - Left err -> - assertFailure ("encrypting SKESK v4 ESK failed for " ++ show sa ++ ": " ++ show err) >> - fail "encrypting SKESK v4 ESK failed" - Right x -> pure x - let skesk = SKESK4Packet sa s2k (Just (BL.fromStrict encryptedEsk)) - case skesk2SessionKey skesk passphrase of - Right (decodedAlgo, decodedSessionKey) -> do - assertEqual ("decoded SKESK v4 encrypted ESK algorithm for " ++ show sa) sa decodedAlgo - assertEqual ("decoded SKESK v4 encrypted ESK session key for " ++ show sa) sessionKey decodedSessionKey - Left err -> - assertFailure - ("decoding SKESK v4 encrypted ESK failed for " ++ - show sa ++ ": " ++ renderS2KError err) - -testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum :: Assertion -testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum = do - let sa = AES128 - passphrase = "password" - s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 - sessionKey = B.pack (take 16 (cycle [0xaa, 0xbb, 0xcc, 0xdd])) - keyLen <- - case keySize sa of - Left err -> assertFailure ("keySize failed: " ++ show err) >> fail "keySize failed" - Right n -> pure n - kek <- - case string2Key s2k keyLen passphrase of - Left err -> assertFailure ("string2Key failed: " ++ renderS2KError err) >> fail "string2Key failed" - Right x -> pure x - let encodedWithChecksum = - B.singleton (fromFVal sa) <> sessionKey <> encodeChecksum16 sessionKey - encryptedEsk <- - case withSymmetricCipher sa kek $ \cipher -> - paddedCfbEncrypt - cipher - (B.replicate (blockSize cipher) 0) - encodedWithChecksum of - Left err -> - assertFailure ("encrypting malformed SKESK v4 ESK failed: " ++ show err) >> - fail "encrypting malformed SKESK v4 ESK failed" - Right x -> pure x - let skesk = SKESK4Packet sa s2k (Just (BL.fromStrict encryptedEsk)) - case skesk2SessionKey skesk passphrase of - Left (S2KEncryptedSessionKeyDecodeError (EncodedSessionKeyLengthMismatch AES128 16 18)) -> pure () - Left err -> - assertFailure - ("expected SKESK v4 trailing-checksum rejection, got: " ++ - renderS2KError err) - Right _ -> - assertFailure "expected SKESK v4 trailing-checksum rejection, but decode succeeded" - -testEncryptPassphraseWithPolicyForceV4Interop :: Assertion -testEncryptPassphraseWithPolicyForceV4Interop = do - let request = - PassphraseEncryptRequest - { passphraseEncryptVersionPolicy = PassphraseSKESKForceV4Interop - , passphraseEncryptSymmetricAlgorithm = AES128 - , passphraseEncryptS2K = Simple SHA256 - , passphraseEncryptPassphrase = "password" - , passphraseEncryptPayload = "hello" - , passphraseEncryptSEIPDv1IVOverride = Just (IV (B.replicate 16 0x22)) - , passphraseEncryptSEIPDv2AEADOverride = Nothing - , passphraseEncryptSEIPDv2ChunkSizeOverride = Nothing - , passphraseEncryptSEIPDv2SaltOverride = Nothing - } - result <- encryptPassphraseWithPolicy request - case result of - Left err -> - assertFailure ("Expected passphrase SKESK force-v4 encryption to succeed, got: " ++ err) - Right (SKESKPkt (SKESKPayloadV4Packet _):SymEncIntegrityProtectedDataPkt (SEIPD1 _ _):_) -> - pure () - Right packets -> - assertFailure - ("Expected SKESKv4 + SEIPDv1 packet sequence, got: " ++ show packets) - -testEncryptPassphraseWithPolicyPreferV6 :: Assertion -testEncryptPassphraseWithPolicyPreferV6 = do - let request = - PassphraseEncryptRequest - { passphraseEncryptVersionPolicy = PassphraseSKESKPreferV6 - , passphraseEncryptSymmetricAlgorithm = AES128 - , passphraseEncryptS2K = Simple SHA256 - , passphraseEncryptPassphrase = "password" - , passphraseEncryptPayload = "hello" - , passphraseEncryptSEIPDv1IVOverride = Nothing - , passphraseEncryptSEIPDv2AEADOverride = Just OCB - , passphraseEncryptSEIPDv2ChunkSizeOverride = Just 6 - , passphraseEncryptSEIPDv2SaltOverride = Just (Salt (B.replicate 32 0x44)) - } - result <- encryptPassphraseWithPolicy request - case result of - Left err -> - assertFailure ("Expected passphrase SKESK prefer-v6 encryption to succeed, got: " ++ err) - Right (SKESKPkt (SKESKPayloadV6Packet _):SymEncIntegrityProtectedDataPkt (SEIPD2 _ _ _ _ _):_) -> - pure () - Right packets -> - assertFailure - ("Expected SKESKv6 + SEIPDv2 packet sequence, got: " ++ show packets) - -testArgon2S2KVector :: Assertion -testArgon2S2KVector = do - let s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 - pass = BLC8.pack "password" - derivedKeyResult = string2Key s2k 16 pass - derivedKey <- - case derivedKeyResult of - Left err -> - assertFailure ("Argon2 S2K key derivation failed: " ++ renderS2KError err) >> - fail "Argon2 key derivation failed" - Right x -> pure x - let - hex = map toUpper . BLC8.unpack . B16L.encode . BL.fromStrict $ derivedKey - assertEqual - "Argon2 S2K key derivation vector" - "A3BDFE3814D790F1F366ABA6954EB386" - hex - -testArgon2S2KOrdTotal :: Assertion -testArgon2S2KOrdTotal = do - let argon2A = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 - argon2B = Argon2 (Salt16 (B.pack [0x01 .. 0x10])) 1 4 15 - assertEqual - "Argon2 S2K compares after simple S2K" - GT - (compare argon2A (Simple SHA256)) - assertEqual - "Argon2 S2K compares before unknown S2K types" - LT - (compare argon2A (OtherS2K 101 BL.empty)) - assertEqual - "Argon2 S2K constructor compares lexicographically by fields" - LT - (compare argon2A argon2B) +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Encryption (encryptionAndCompressionTests) where + +import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA +import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor (..)) +import Control.Exception.Base (SomeException, catch, try) +import Control.Monad (void) +import Control.Monad.Trans.Resource (ResourceT) +import qualified Crypto.Error as CE +import Crypto.Number.ModArithmetic (inverse) +import Crypto.Number.Serialize (i2osp, os2ip) +import qualified Crypto.PubKey.Curve25519 as C25519 +import qualified Crypto.PubKey.Curve448 as C448 +import qualified Crypto.PubKey.ECC.DH as ECCDH +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import Crypto.PubKey.ECC.Prim (pointBaseMul) +import qualified Crypto.PubKey.ECC.Types as ECCT +import qualified Crypto.PubKey.RSA as RSA +import qualified Crypto.PubKey.RSA.PKCS15 as P15 +import Data.Binary (get, put) +import Data.Binary.Get + ( Get + ) +import Data.Binary.Put (putWord16be, runPut) +import qualified Data.ByteArray as BA +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16.Lazy as B16L +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC8 +import Data.Char (toUpper) +import Data.Conduit (fuseBoth) +import qualified Data.Conduit as DC +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.List (find, isInfixOf) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (listToMaybe) +import qualified Data.Set as Set +import Data.Word (Word16) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + ( Assertion + , assertBool + , assertEqual + , assertFailure + , testCase + ) + +import Codec.Encryption.OpenPGP.BlockCipher + ( keySize + , withSymmetricCipher + ) +import Codec.Encryption.OpenPGP.CFB +import Codec.Encryption.OpenPGP.Compression + ( CompressionError (..) + , compressPkts + , decompressPkt + ) +import Codec.Encryption.OpenPGP.Encrypt + ( EncryptCompatibilityProfile (..) + , PKESKEncryptError + ( InvalidRecipientIdentifier + , InvalidRecipientKeyMaterial + , PayloadBuildFailure + , RecipientCapabilitySelectionFailure + , RecipientKdfFailure + , UnsupportedRecipientAlgorithm + ) + , PKESKVersionPolicy (..) + , PassphraseEncryptRequest (..) + , PassphraseSKESKVersionPolicy (..) + , RecipientCapabilities (..) + , RecipientCapabilityError + ( RecipientCapabilityMissingSEIPDv1Support + , RecipientCapabilityNoCommonAEADAlgorithms + , RecipientCapabilityNoCommonSymmetricAlgorithms + , RecipientCapabilityNoEncryptableKeyMaterialInTK + ) + , RecipientCapabilityNegotiationMode (..) + , RecipientEncryptRequest (..) + , RecipientEncryptRequestOverrides (..) + , RecipientEncryptResult (..) + , RecipientEncryptionTarget (..) + , RecipientEncryptionTargetRejected (..) + , RecipientEncryptionTargetsReport (..) + , RecipientPKESKVersionStrategy (..) + , RecipientPayloadShape (..) + , RecipientTargetRejectionReason (..) + , RecipientTargetSelectionPolicy (..) + , buildPKESKPayloadForRecipient + , buildPKESKv3PayloadForRecipient + , canonicalizePKESKRecipientId + , defaultRecipientPayloadShape + , encryptForRecipients + , encryptForRecipientsLegacy + , encryptForRecipientsWithCapabilityNegotiation + , encryptPassphraseWithPolicy + , encryptSEIPDv2Payload + , pkeskSessionAlgorithm + , pkeskV3SessionMaterial + , recipientCapabilitiesFromSubpacketPayloads + , recipientEncryptionTarget + , recipientEncryptionTargetFromTK + , recipientEncryptionTargetFromTKAtTimestamp + , recipientEncryptionTargetFromTKAtTimestampWithPolicy + , recipientEncryptionTargetWithCapabilities + , recipientEncryptionTargetWithStrategy + , recipientEncryptionTargetsFromTK + , recipientEncryptionTargetsFromTKAtTimestamp + , recipientEncryptionTargetsReportFromTKAtTimestamp + , recipientVersionStrategyForProfile + ) +import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) +import Codec.Encryption.OpenPGP.Internal (point2MBS) +import Codec.Encryption.OpenPGP.Internal.HOBlockCipher + ( HOBlockCipher (..) + ) +import Codec.Encryption.OpenPGP.Message + ( SessionMaterialExposure (..) + , encryptedPayloadBytes + , mkClearPayload + , mkPassphrase + ) +import Codec.Encryption.OpenPGP.Policy + ( OpenPGPPolicy (..) + , OpenPGPRFC (..) + , defaultDecryptPolicy + , defaultPolicy + , lenientDecryptPolicy + , policyForRFC + ) +import Codec.Encryption.OpenPGP.S2K + ( EncodedSessionKeyError (..) + , S2KError (..) + , decodeOpenPGPEncodedSessionKey + , renderS2KError + , skesk2SessionKey + , string2Key + ) +import Codec.Encryption.OpenPGP.SecretKey + ( decryptPrivateKey + , encryptPrivateKeyWithPolicyAndSaltAndIV + ) +import Codec.Encryption.OpenPGP.Serialize (parsePkts) +import Codec.Encryption.OpenPGP.Types +import Data.Conduit.OpenPGP.Compression (conduitCompress) +import Data.Conduit.OpenPGP.Decrypt + ( DecryptKeyResolution (..) + , DecryptOptions (..) + , DecryptOutcome (..) + , PKESKRecipientKey (..) + ) +import qualified Data.Conduit.OpenPGP.Decrypt as DCD +import Data.Conduit.OpenPGP.Keyring + ( conduitToSomeTKsDroppingEither + , conduitToSomeTKsEither + , conduitToTKsDroppingEither + , conduitToTKsEither + ) +import Tests.Common + ( aesKeyWrapRFC3394ForTest + , armorPayload + , assertX25519EskShape + , assertX448EskShape + , buildCurve25519LegacyKdfParamForTest + , buildECDHKDFParamForTest + , cgp + , collectSecretKeyInfos + , conduitDecrypt + , conduitDecryptChecked + , conduitDecryptCheckedWithDecryptPolicy + , conduitDecryptWithCandidatesCallbackAndPolicy + , conduitDecryptWithDecryptPolicy + , conduitDecryptWithPKESKContext + , deriveECDHKekForTest + , deriveX25519KekForTest + , deriveX448KekForTest + , doPkeyAndSkeyMatch + , encodeChecksum16 + , encryptMessageDefault + , fixturePath + , forceVersionedRecipientIdentifier + , isPrecedingESK + , loadArmor + , loadDeterministicEd25519Signer + , loadSEIPDv2FixtureWithV4Secret + , loadUnencryptedRsaSigner + , mkPKESKSessionMaterialOrFail + , prependUnusableLatestPKESK + , readFixtureLazy + , readFixturePackets + , readFixtureStrict + , readPKIPassphrase + , reorderPrecedingPKESKs + , runGet + , selectRecipientKeyInfo + , selectRecipientKeyInfoByRawRecipientId + , setKeyTimestamp + , setKeyVersion + , signDirectKeyWithRSAExtrasAt + , signSubkeyBindingWithRSAExtrasAt + , signSubkeyRevocationWithRSAAt + , testEncodeOpenPGPSessionMaterial + , testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized + , testSEIPDv2ForV4KeyArmor + , testSEIPDv2ThreeRecipientsArmor + , testSEIPDv2TwoRecipientsArmor + ) + +mkLegacySymmetricCase + :: (String, Bool, FilePath, FilePath, BL.ByteString) -> TestTree +mkLegacySymmetricCase (label, expectSEIPDv1, encFile, passFile, cleartext) = + testCase + label + ( testLegacySymmetricEncryption + expectSEIPDv1 + encFile + passFile + cleartext + ) + +legacySymmetricCases + :: [(String, Bool, FilePath, FilePath, BL.ByteString)] +legacySymmetricCases = + [ + ( "Symmetric Encryption simple S2K SHA1 3DES, no MDC" + , False + , "encryption-sym-3des-s2k0.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted S2K SHA1 3DES, no MDC" + , False + , "encryption-sym-3des.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption simple S2K SHA1 3DES" + , True + , "encryption-sym-3des-mdc-s2k0.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted S2K SHA1 3DES" + , True + , "encryption-sym-3des-mdc.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption simple S2K SHA1 CAST5, no MDC" + , False + , "encryption-sym-cast5-s2k0.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted S2K SHA1 CAST5, no MDC" + , False + , "encryption-sym-cast5.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption simple S2K SHA1 CAST5" + , True + , "encryption-sym-cast5-mdc-s2k0.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted S2K SHA1 CAST5" + , True + , "encryption-sym-cast5-mdc.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption simple S2K SHA1 Blowfish, no MDC" + , False + , "encryption-sym-blowfish-s2k0.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted S2K SHA1 Blowfish, no MDC" + , False + , "encryption-sym-blowfish.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption simple S2K SHA1 Blowfish" + , True + , "encryption-sym-blowfish-mdc-s2k0.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted S2K SHA1 Blowfish" + , True + , "encryption-sym-blowfish-mdc.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption simple S2K SHA1 AES128" + , True + , "encryption-sym-aes128-s2k0.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted S2K SHA1 AES128" + , True + , "encryption-sym-aes128.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption simple S2K SHA1 AES192" + , True + , "encryption-sym-aes192-s2k0.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted S2K SHA1 AES192" + , True + , "encryption-sym-aes192.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption simple S2K SHA1 AES256" + , True + , "encryption-sym-aes256-s2k0.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted S2K SHA1 AES256" + , True + , "encryption-sym-aes256.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted S2K SHA256 AES256" + , True + , "encryption-sym-aes256-sha256.pgp" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption simple S2K SHA1 Twofish" + , True + , "encryption-sym-twofish-s2k0.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted S2K SHA1 Twofish" + , True + , "encryption-sym-twofish.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption simple Camellia128" + , True + , "encryption-sym-camellia128-s2k0.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted Camellia128" + , True + , "encryption-sym-camellia128.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted Camellia192" + , True + , "encryption-sym-camellia192.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption iterated-salted Camellia256" + , True + , "encryption-sym-camellia256.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "Symmetric Encryption pgcrypto" + , True + , "encryption-sym-pgcrypto.pgp" + , "pgcrypto-passphrase.txt" + , "{\"t\":\"plus\"}" + ) + ] + +mkStrictSymmetricCase + :: (String, FilePath, FilePath, BL.ByteString) -> TestTree +mkStrictSymmetricCase (label, encFile, passFile, cleartext) = + testCase + label + (testSymmetricEncryption encFile passFile cleartext) + +strictSymmetricCases + :: [(String, FilePath, FilePath, BL.ByteString)] +strictSymmetricCases = + [ + ( "strict policy AES128 iterated-salted S2K SEIPDv1" + , "encryption-sym-aes128.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "strict policy AES192 iterated-salted S2K SEIPDv1" + , "encryption-sym-aes192.gpg" + , "symmetric-password.txt" + , "test\n" + ) + , + ( "strict policy AES256 iterated-salted S2K SEIPDv1" + , "encryption-sym-aes256.gpg" + , "symmetric-password.txt" + , "test\n" + ) + ] + +mkSyntheticNISTP256 + :: B.ByteString -> (ECDSA.PublicKey, ECDSA.PrivateKey) +mkSyntheticNISTP256 bs = + let curve = ECCT.getCurveByName ECCT.SEC_p256r1 + d = os2ip bs + q = pointBaseMul curve d + pub = ECDSA.PublicKey curve q + priv = ECDSA.PrivateKey curve d + in (pub, priv) + +syntheticNISTP256Low + , syntheticNISTP256High + :: (ECDSA.PublicKey, ECDSA.PrivateKey) +syntheticNISTP256Low = mkSyntheticNISTP256 $ B.pack [1 .. 32] +syntheticNISTP256High = mkSyntheticNISTP256 $ B.pack [101 .. 132] + +encryptionAndCompressionTests :: TestTree +encryptionAndCompressionTests = + testGroup + "Encryption and compression" + [ testGroup + "Compression group" + [ testCase + "compressedsig.gpg" + (testCompression "compressedsig.gpg") + , testCase + "compressedsig-zlib.gpg" + (testCompression "compressedsig-zlib.gpg") + , testCase + "compressedsig-bzip2.gpg" + (testCompression "compressedsig-bzip2.gpg") + , testCase + "decompressPkt classifies empty ZIP payload" + ( assertEqual + "empty ZIP" + (Left (EmptyCompressedPayload ZIP)) + (decompressPkt (CompressedDataPkt ZIP "")) + ) + , testCase + "decompressPkt classifies empty Uncompressed payload" + ( assertEqual + "empty Uncompressed" + (Left (EmptyCompressedPayload Uncompressed)) + (decompressPkt (CompressedDataPkt Uncompressed "")) + ) + , testCase + "decompressPkt classifies marker-only ZIP payload" + ( let markerPkt = MarkerPkt "\x50\x47\x50" + compressed = compressPkts ZIP [markerPkt] + in assertEqual + "marker-only" + (Left (MarkerOnlyPayload ZIP)) + (decompressPkt compressed) + ) + , testCase + "decompressPkt passes through non-compressed packets" + ( let pkt = OtherPacketPkt 255 "" + in assertEqual + "passthrough" + (Right [pkt]) + (decompressPkt pkt) + ) + ] + , testGroup + "Conduit length group" + [ testCase + "conduitCompress (ZIP)" + ( testConduitOutputLength + "pubring.gpg" + (cgp DC..| conduitCompress ZIP) + 1 + ) + , testCase + "conduitCompress (Zlib)" + ( testConduitOutputLength + "pubring.gpg" + (cgp DC..| conduitCompress ZLIB) + 1 + ) + , testCase + "conduitCompress (BZip2)" + ( testConduitOutputLength + "pubring.gpg" + (cgp DC..| conduitCompress BZip2) + 1 + ) + , testCase + "conduitToTKsDroppingEither" + ( testConduitOutputLength + "pubring.gpg" + (cgp DC..| conduitToTKsDroppingEither) + 4 + ) + , testCase + "conduitToSomeTKsDroppingEither" + ( testConduitOutputLength + "pubring.gpg" + (cgp DC..| conduitToSomeTKsDroppingEither) + 4 + ) + , testCase + "conduitToTKsEither reports parse failures" + testConduitToTKsEitherReportsParseFailure + , testCase + "conduitToSomeTKsEither reports parse failures" + testConduitToSomeTKsEitherReportsParseFailure + , testCase + "conduitToTKsDroppingEither reports parse failures" + testConduitToTKsDroppingEitherReportsParseFailure + , testCase + "conduitToSomeTKsDroppingEither reports parse failures" + testConduitToSomeTKsDroppingEitherReportsParseFailure + ] + , testGroup + "Encrypted data" + ( [ testCase + "Legacy symmetric encryption fixture shape" + testLegacyEncryptionFixtureShape + , testCase + "SEIPDv1 resync nonce/MDC roundtrip" + testSEIPDv1ResyncNonceMdcRoundTrip + ] + ++ map mkLegacySymmetricCase legacySymmetricCases + ++ map mkStrictSymmetricCase strictSymmetricCases + ++ [ testCase + "strict policy rejects SED (no MDC)" + ( testStrictPolicyRejectsEncryption + "encryption-sym-cast5.gpg" + "symmetric-password.txt" + "unauthenticated SED" + ) + , testCase + "strict policy rejects Simple S2K" + ( testStrictPolicyRejectsEncryption + "encryption-sym-aes128-s2k0.gpg" + "symmetric-password.txt" + "Simple S2K specifier" + ) + , testCase + "strict policy rejects non-encrypted packet after ESK prelude" + testRejectsNonEncryptedAfterESKPrelude + , testCase + "strict policy rejects SEIPDv2 with only misaligned ESK versions" + testRejectsMisalignedESKVersionForSEIPDv2 + , testCase + "strict policy discards misaligned ESK when aligned ESK is present" + testDiscardsMisalignedESKWhenAlignedCandidateExists + , testCase + "strict policy rejects trailing data after SEIPD v2" + testTrailingDataRejectedStrictSEIPDv2 + , testCase + "lenient policy reports DecryptTrailingData for trailing packet after SEIPD v2" + testTrailingDataReportedLenientSEIPDv2 + , testCase + "conduitDecryptChecked reports DecryptClean for well-formed SEIPD v2" + testDecryptCleanSEIPDv2 + , testCase + "conduitDecrypt matches conduitDecryptChecked (default)" + testOptionsMatchesCheckedDefaultSEIPDv2 + , testCase + "conduitDecrypt matches legacy conduitDecrypt output (default)" + testOptionsMatchesLegacyDefaultOutputSEIPDv2 + , testCase + "conduitDecrypt matches checked lenient trailing behavior" + testOptionsMatchesCheckedLenientTrailingSEIPDv2 + ] + ) + , testGroup + "Encrypted secret keys" + [ testCase + "SUSSHA1 CAST5 IteratedSalted SHA1 RSA" + (testSecretKeyDecryption "simple.seckey" "pki-password.txt") + , testCase + "SUS16bit CAST5 IteratedSalted SHA1 RSA" + (testSecretKeyDecryption "16bitcksum.seckey" "pki-password.txt") + , testCase + "SUSSHA1 AES256 IteratedSalted SHA512 RSA" + (testSecretKeyDecryption "aes256-sha512.seckey" "pki-password.txt") + , testCase + "SUSSHA1 AES128 IteratedSalted SHA256 ECDSA" + ( testSecretKeyDecryption + "nist_p-256_secretkey.gpg" + "pki-password.txt" + ) + ] + , testGroup + "Encrypting secret keys" + [ testCase + "legacy secret key encryption rejects implicit SHA-1 protection" + ( testLegacySecretKeyEncryptionRejected + "unencrypted.seckey" + "pki-password.txt" + ) + , testCase + "SUSym secret key roundtrips" + testSUSymSecretKeyRoundTrip + , testCase + "v6 secret key encryption roundtrips with SUSAEAD" + testV6SecretKeyEncryptionRoundTrip + , testCase + "v4 AEAD OCB secret key compatibility roundtrip" + testV4SecretKeyAEADOCBRoundTripCompat + ] + , testGroup + "decrypt conduit stuff" + [ testCase + "conduitDecrypt supports PKESKv6 with raw session-key callback" + testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey + , testCase + "conduitDecrypt rejects invalid PKESKv6 raw session-key length" + testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength + , testCase + "conduitDecrypt unwraps PKESK RSA session keys in-library" + testConduitDecryptSEIPDv2WithPKESKRSAUnwrap + , testCase + "conduitDecrypt probes wildcard callback fallback for PKESKv3 RSA key-id packets" + testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback + , testCase + "conduitDecrypt unwraps PKESKv3 RSA session keys via SHA1-CFB protected key loaded from file" + testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey + , testCase + "parsed RSA secret key decrypts PKCS#1 v1.5 payload" + testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized + , testCase + "conduitDecrypt unwraps PKESK ECDH session keys in-library" + testConduitDecryptSEIPDv2WithPKESKECDHUnwrap + , testCase + "conduitDecrypt rejects ECDH ephemeral points with wrong curve length" + testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength + , testCase + "conduitDecrypt unwraps PKESKv3 X25519 session keys in-library" + testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap + , testCase + "conduitDecrypt retries wildcard PKESKv3 keys across callback order" + testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder + , testCase + "conduitDecrypt retries wildcard PKESKv3 keys across long callback order" + testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder + , testCase + "conduitDecrypt retries wildcard PKESKv3 keys across long callback order for SEIPDv1" + testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder + , testCase + "unwrap callback decrypts wildcard PKESKv3 via candidates list" + testMkCandidateResolverDecryptsWildcardPKESKv3 + , testCase + "conduitDecrypt wildcard resolver receives typed previous-failure diagnostics" + testConduitDecryptWildcardResolverProvidesTypedPreviousFailures + , testCase + "conduitDecryptWithReport surfaces wildcard resolver diagnostics" + testConduitDecryptWithReportCapturesWildcardResolverDiagnostics + , testCase + "conduitDecrypt rejects PKESKv3 X25519 ephemeral values with wrong length" + testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength + , testCase + "conduitDecrypt falls back from Argon2 SKESK to PKESKv3 X25519" + testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519 + , testCase + "conduitDecrypt retries earlier Argon2 SKESKs when latest is unusable" + testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK + , testCase + "conduitDecrypt rejects ECDH KDF/KEK params outside RFC9580 Table 30" + testConduitDecryptSEIPDv2RejectsECDHNonTable30Params + , testCase + "conduitDecrypt allows v4 Curve25519Legacy RFC6637 accepted parameters" + testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams + , testCase + "conduitDecrypt allows v4 Curve25519Legacy with truncated wrapped MPI" + testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI + , testCase + "conduitDecrypt keeps v6 Curve25519Legacy ECDH strict" + testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params + , testCase + "conduitDecrypt unwraps PKESK X448 session keys in-library" + testConduitDecryptSEIPDv2WithPKESKX448Unwrap + , testCase + "conduitDecrypt rejects PKESKv6 X448 ephemeral values with wrong length" + testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength + , testCase + "encrypt-side session material encoding uses OpenPGP format" + testEncodeOpenPGPSessionMaterial + , testCase + "encrypt-side PKESK builder wraps RSA recipient session key" + testBuildPKESKPayloadForRecipientRSA + , testCase + "encrypt-side PKESKv3 builder supports RSA v4 interop" + testBuildPKESKv3PayloadForRecipientRSAInterop + , testCase + "encrypt-side PKESKv3 builder supports v6 recipients" + testBuildPKESKv3PayloadForRecipientSupportsV6Key + , testCase + "encrypt-side PKESKv3 builder supports RFC6637 ECDH recipients" + testBuildPKESKv3PayloadForRecipientECDHInterop + , testCase + "PKESKv3 ECDH serializer uses RFC 6637 wire format" + testPKESKv3ECDHWireFormat + , testCase + "encrypt-side PKESKv3 builder supports RFC6637 Curve25519Legacy recipients" + testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop + , testCase + "encrypt-side PKESKv3 builder rejects non-RFC6637 Curve448Legacy recipients" + testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy + , testCase + "RFC 9580 v6 X25519 PKESK uses raw-key semantics, not v3-encoded material" + testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics + , testCase + "RFC 9580 v6 X448 PKESK uses raw-key semantics, not v3-encoded material" + testBuildPKESKv6PayloadForRecipientX448RawKeySemantics + , testCase + "encrypt-side policy builder emits PKESK3 for ForceV3Interop" + testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop + , testCase + "encrypt-side profile helper honors recipient capability hints" + testRecipientVersionStrategyForProfileHonorsHints + , testCase + "encryptForRecipients auto-detects mixed recipient PKESK strategies" + testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies + , testCase + "encryptForRecipients negotiates symmetric algorithm from recipient capabilities when enabled" + testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled + , testCase + "encryptForRecipients negotiates recipient capabilities by default" + testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault + , testCase + "encryptForRecipientsLegacy preserves capability negotiation opt-out" + testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut + , testCase + "encryptForRecipients capability negotiation fails when recipients share no symmetric algorithm" + testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm + , testCase + "recipientCapabilitiesFromSubpacketPayloads extracts preferred AEAD algorithms" + testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms + , testCase + "encryptForRecipients negotiates AEAD algorithm from recipient capabilities when enabled" + testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled + , testCase + "encryptForRecipients capability negotiation fails when recipients share no AEAD algorithm" + testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm + , testCase + "encryptForRecipients falls back to SEIPDv1 when recipients do not advertise SEIPDv2 support" + testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 + , testCase + "encryptForRecipients rejects SEIPDv1 when recipients do not advertise MDC support" + testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC + , testCase + "recipientEncryptionTargetsFromTK returns only encryption-capable candidates" + testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys + , testCase + "recipientEncryptionTargetFromTK prefers encryption-capable subkeys" + testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary + , testCase + "recipientEncryptionTargetFromTK rejects TKs without encryptable key material" + testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys + , testCase + "recipientEncryptionTargetsReportFromTKAtTimestamp reports sign-only subkey rejection reasons" + testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections + , testCase + "recipientEncryptionTargetsReportFromTKAtTimestamp reports unsupported algorithm rejections" + testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms + , testCase + "recipientEncryptionTargetsReportFromTKAtTimestamp rejects expired subkeys" + testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey + , testCase + "recipientEncryptionTargetsReportFromTKAtTimestamp rejects revoked subkeys" + testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey + , testCase + "recipientEncryptionTargetsFromTKAtTimestamp extracts effective self-signature capabilities" + testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities + , testCase + "recipientEncryptionTargetFromTKAtTimestamp filters subkey self-signatures by timestamp" + testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering + , testCase + "recipientEncryptionTargetFromTKAtTimestampWithPolicy can prefer primary key" + testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary + , testCase + "recipientEncryptionTargetFromTKAtTimestampWithPolicy can prefer newest key" + testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest + , testCase + "recipientEncryptionTargetsFromTK excludes subkeys with non-encrypt key flags" + testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags + , testCase + "recipientEncryptionTargetsFromTK includes subkeys with no key flags advertised" + testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags + , testCase + "encryptForRecipients optionally emits one-pass signature packets" + testEncryptRecipientsWithRequestEmitsOnePassSignatures + , testCase + "encryptForRecipients one-pass mode requires issuer metadata" + testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing + , testCase + "encryptForRecipients with EncryptInteropLegacy produces SEIPDv1 and PKESKv3" + testEncryptInteropLegacyProducesSEIPDv1 + , testCase + "encrypt-side PKESK builder reports unsupported recipient algorithms" + testBuildPKESKPayloadUnsupportedRecipient + , testCase + "encrypt-side ECDH PKESK builder rejects SHA1 KDF policy" + testBuildPKESKPayloadRejectsECDHSHA1 + , testCase + "encrypt-side canonicalize PKESK recipient id helper" + testCanonicalizePKESKRecipientIdHelper + , testCase + "conduitDecrypt decrypts seipdv2 fixture with matching v6 secret key" + testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey + , testCase + "seipdv2-for-v4-key fixture parses as PKESKv6+SEIPDv2" + testSEIPDv2ForV4KeyArmor + , testCase + "conduitDecrypt decrypts seipdv2-for-v4-key fixture with matching v4 secret key" + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey + , testCase + "conduitDecrypt tries earlier PKESKs when latest is unusable" + testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK + , testCase + "conduitDecrypt matches valid recipient-id forms without caller retries" + testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations + , testCase + "conduitDecrypt fails PKESK exhaustion without manual session-key prompt" + testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial + , testCase + "seipdv2-two-recipients fixture parses as PKESKv6*2+SEIPDv2" + testSEIPDv2TwoRecipientsArmor + , testCase + "seipdv2-three-recipients fixture parses as PKESKv6*3+SEIPDv2" + testSEIPDv2ThreeRecipientsArmor + , testCase + "conduitDecrypt decrypts seipdv2-two-recipients fixture with matching v4 secret key" + testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey + , testCase + "conduitDecrypt decrypts reordered+bogus seipdv2-two-recipients PKESKs" + testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs + , testCase + "conduitDecrypt decrypts seipdv2-three-recipients fixture with matching v4 secret key" + testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey + , testCase + "conduitDecrypt decrypts reordered+bogus seipdv2-three-recipients PKESKs" + testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs + ] + , testGroup + "ESK/SKESK/ArgonS2K" + [ testCase + "encoded session key rejects too-short payloads" + testDecodeOpenPGPEncodedSessionKeyRejectsTooShort + , testCase + "encoded session key rejects algorithm/key-length mismatches" + testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch + , testCase + "encoded session key rejects checksum mismatches" + testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch + , testCase + "unknown SKESK version is rejected" + testSKESKRejectsUnknownVersion + , testCase + "v4 SKESK encrypted session keys reject Simple S2K" + testSKESK4EncryptedSessionKeyRejectsSimpleS2K + , testCase + "v4 SKESK Argon2 encrypted ESK roundtrip across AES-128/192/256" + testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES + , testCase + "v4 SKESK Argon2 encrypted ESK rejects legacy checksum trailer" + testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum + , testCase + "passphrase SKESK policy ForceV4Interop emits SKESKv4 + SEIPDv1" + testEncryptPassphraseWithPolicyForceV4Interop + , testCase + "passphrase SKESK policy PreferV6 emits SKESKv6 + SEIPDv2" + testEncryptPassphraseWithPolicyPreferV6 + , testCase "Argon2 S2K derivation vector" testArgon2S2KVector + , testCase "Argon2 S2K Ord instance is total" testArgon2S2KOrdTotal + ] + ] + +testCompression :: FilePath -> Assertion +testCompression fpr = do + bs <- BL.readFile $ "tests/data/" ++ fpr + let firstpass = + fmap (concatMap (either (const []) id . decompressPkt) . unBlock) + . runGet get + $ bs + case firstpass of + Left _ -> assertFailure $ "First pass failed on " ++ fpr + Right [] -> + assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." + Right packs -> do + let roundtrip = runPut $ put . Block $ [compressPkts ZIP packs] + let secondpass = + fmap (concatMap (either (const []) id . decompressPkt) . unBlock) + . runGet get + $ roundtrip + if secondpass == Right [] + then + assertFailure $ + "Second pass of " ++ fpr ++ " decoded to nothing." + else assertEqual ("for " ++ fpr) firstpass secondpass + +counter :: (Monad m) => DC.ConduitT a DC.Void m Int +counter = CL.fold (const . (1 +)) 0 + +testConduitOutputLength + :: FilePath + -> DC.ConduitT B.ByteString b (ResourceT IO) () + -> Int + -> Assertion +testConduitOutputLength fpr c target = do + len <- + DC.runConduitRes $ + CB.sourceFile ("tests/data/" ++ fpr) DC..| c DC..| counter + assertEqual ("expected length " ++ show target) target len + +testConduitToTKsEitherReportsParseFailure :: Assertion +testConduitToTKsEitherReportsParseFailure = do + results <- + DC.runConduitRes $ + CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" + DC..| conduitGet get + DC..| conduitToTKsEither + DC..| CL.consume + assertBool + "conduitToTKsEither should report parse failures for non-key packet streams" + (any (either (const True) (const False)) results) + +testConduitToTKsDroppingEitherReportsParseFailure :: Assertion +testConduitToTKsDroppingEitherReportsParseFailure = do + results <- + DC.runConduitRes $ + CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" + DC..| conduitGet get + DC..| conduitToTKsDroppingEither + DC..| CL.consume + assertBool + "conduitToTKsDroppingEither should report parse failures for non-key packet streams" + (any (either (const True) (const False)) results) + +testConduitToSomeTKsEitherReportsParseFailure :: Assertion +testConduitToSomeTKsEitherReportsParseFailure = do + results <- + DC.runConduitRes $ + CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" + DC..| conduitGet get + DC..| conduitToSomeTKsEither + DC..| CL.consume + assertBool + "conduitToSomeTKsEither should report parse failures for non-key packet streams" + (any (either (const True) (const False)) results) + +testConduitToSomeTKsDroppingEitherReportsParseFailure + :: Assertion +testConduitToSomeTKsDroppingEitherReportsParseFailure = do + results <- + DC.runConduitRes $ + CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg" + DC..| conduitGet get + DC..| conduitToSomeTKsDroppingEither + DC..| CL.consume + assertBool + "conduitToSomeTKsDroppingEither should report parse failures for non-key packet streams" + (any (either (const True) (const False)) results) + +-- This needs a lot of work + +{- | Decrypt a symmetric-encrypted fixture using 'defaultDecryptPolicy' and +assert the packet structure is SKESK + SEIPDv1 and the cleartext matches. +Only suitable for AES-128/192/256 fixtures with iterated-salted S2K. +-} +testSymmetricEncryption + :: FilePath -> FilePath -> BL.ByteString -> Assertion +testSymmetricEncryption encfile passfile cleartext = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + assertEqual "wrong number of packets" 2 (length pt) + skesk <- + case pt of + [] -> + assertFailure + ( "expected SKESK packet in " + ++ encfile + ++ " but packet list was empty" + ) + >> fail "empty fixture packet list" + (firstPkt : _) -> + case (fromPktEither firstPkt :: Either String (SKESK 'SKESKV4)) of + Left err -> + assertFailure ("failed to coerce first packet to SKESK: " ++ err) + >> fail err + Right x -> pure x + assertEqual + "first packet should be SKESK" + SKESKType + (packetType skesk) + case last pt of + SymEncIntegrityProtectedDataPkt (SEIPD1 1 _) -> pure () + other -> + assertFailure + ( "second packet should be SEIPDv1 (tag 18, version 1), got: " + ++ show other + ) + decrypted <- + catch + ( DC.runConduitRes $ + CL.sourceList pt + DC..| conduitDecrypt (fakeCallback passphrase) + DC..| CL.consume + ) + ( \e -> do + let err = show (e :: SomeException) + assertFailure ("decryption threw exception: " ++ err) + ) + payload <- + case decrypted of + [] -> + assertFailure ("decryption produced no packets for " ++ encfile) + >> fail "expected decrypted literal packet" + (firstDecrypted : _) -> + case (fromPktEither firstDecrypted :: Either String LiteralData) of + Left err -> + assertFailure + ("failed to coerce decrypted packet to literal data: " ++ err) + >> fail err + Right x -> pure (_literalDataPayload x) + assertEqual ("cleartext for " ++ encfile) cleartext payload + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +testSEIPDv1ResyncNonceMdcRoundTrip :: Assertion +testSEIPDv1ResyncNonceMdcRoundTrip = do + let sa = AES256 + keyBytes = B.pack [0 .. 31] + iv = IV (B.pack [32 .. 47]) + cleartext = B.pack [1 .. 80] + cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext + ciphertext <- + either + ( \e -> + assertFailure ("encryptOpenPGPCfbRaw failed: " ++ show e) + >> pure mempty + ) + pure + ( encryptOpenPGPCfbRaw + OpenPGPCFBResyncW + sa + iv + cleartextWithMDC + keyBytes + ) + (nonce, decrypted) <- + either + ( \e -> + assertFailure ("decryptOpenPGPCfbWithNonce failed: " ++ show e) + >> pure (mempty, mempty) + ) + pure + (decryptOpenPGPCfbWithNonce sa ciphertext keyBytes) + assertEqual + "SEIPDv1 nonce should match IV||IV[-2:]" + (seipdv1NonceFromIV iv) + nonce + assertEqual + "decrypted bytes should include payload+MDC" + cleartextWithMDC + decrypted + payloadOut <- + either + ( \err -> + assertFailure ("validateSEIPD1MDC failed: " ++ err) + >> pure mempty + ) + pure + (validateSEIPD1MDC nonce decrypted) + assertEqual + "MDC-verified payload should round-trip" + cleartext + payloadOut + +{- | Like 'testSymmetricEncryption' but uses 'lenientDecryptPolicy' to permit +legacy RFC4880/RFC2440 message formats (SED, deprecated S2K, old ciphers). +The 'Bool' indicates whether the fixture uses SEIPDv1 (True) or SED (False). +-} +testLegacySymmetricEncryption + :: Bool -> FilePath -> FilePath -> BL.ByteString -> Assertion +testLegacySymmetricEncryption expectSEIPDv1 encfile passfile cleartext = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + assertEqual "wrong number of packets" 2 (length pt) + skesk <- + case pt of + [] -> + assertFailure + ( "expected SKESK packet in " + ++ encfile + ++ " but packet list was empty" + ) + >> fail "empty fixture packet list" + (firstPkt : _) -> + case (fromPktEither firstPkt :: Either String (SKESK 'SKESKV4)) of + Left err -> + assertFailure ("failed to coerce first packet to SKESK: " ++ err) + >> fail err + Right x -> pure x + assertEqual + "first packet should be SKESK" + SKESKType + (packetType skesk) + case last pt of + SymEncDataPkt {} + | not expectSEIPDv1 -> pure () + | otherwise -> + assertFailure + "expected SEIPDv1 packet (tag 18) but got SED (tag 9)" + SymEncIntegrityProtectedDataPkt (SEIPD1 1 _) + | expectSEIPDv1 -> pure () + | otherwise -> + assertFailure + "expected SED packet (tag 9) but got SEIPDv1 (tag 18)" + other -> assertFailure ("unexpected second packet: " ++ show other) + decrypted <- + catch + ( DC.runConduitRes $ + CL.sourceList pt + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + (\_ -> pure Nothing) + (fakeCallback passphrase) + DC..| CL.consume + ) + ( \e -> do + let err = show (e :: SomeException) + assertFailure ("decryption threw exception: " ++ err) + ) + payload <- + case decrypted of + [] -> + assertFailure ("decryption produced no packets for " ++ encfile) + >> fail "expected decrypted literal packet" + (firstDecrypted : _) -> + case (fromPktEither firstDecrypted :: Either String LiteralData) of + Left err -> + assertFailure + ("failed to coerce decrypted packet to literal data: " ++ err) + >> fail err + Right x -> pure (_literalDataPayload x) + assertEqual ("cleartext for " ++ encfile) cleartext payload + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +{- | Assert that decrypting with the strict 'defaultDecryptPolicy' throws an +exception whose message contains the given substring. +-} +testStrictPolicyRejectsEncryption + :: FilePath -> FilePath -> String -> Assertion +testStrictPolicyRejectsEncryption encfile passfile expectedFragment = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + result <- + try + ( DC.runConduitRes $ + CL.sourceList pt + DC..| conduitDecrypt (fakeCallback passphrase) + DC..| CL.consume + ) + :: IO (Either SomeException [Pkt]) + case result of + Right _ -> + assertFailure $ + "Expected strict policy to reject '" + ++ encfile + ++ "' with error containing '" + ++ expectedFragment + ++ "', but decryption succeeded" + Left err -> + assertBool + ( "Expected error containing '" + ++ expectedFragment + ++ "', got: " + ++ show err + ) + (expectedFragment `isInfixOf` show err) + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +-- | Decrypt a file and check the 'DecryptOutcome'. +testDecryptOutcome + :: FilePath -> FilePath -> DecryptOutcome -> Assertion +testDecryptOutcome encfile passfile expectedOutcome = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + (outcome, _pkts) <- + catch + ( DC.runConduitRes $ + CL.sourceList pt + DC..| fuseBoth + (conduitDecryptChecked (fakeCallback passphrase)) + CL.consume + ) + ( \e -> do + let err = show (e :: SomeException) + assertFailure ("decryption threw unexpected exception: " ++ err) + fail "unreachable" + ) + assertEqual + ("DecryptOutcome for " ++ encfile) + expectedOutcome + outcome + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +{- | Build a synthetic packet list with an appended trailing packet, decrypt +with lenient policy, and verify 'DecryptTrailingData' is reported. +-} +testTrailingDataReportedLenient + :: FilePath -> FilePath -> Assertion +testTrailingDataReportedLenient encfile passfile = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + let trailingPkt = OtherPacketPkt 0xFE "" + ptWithTrailing = pt ++ [trailingPkt] + (outcome, _pkts) <- + catch + ( DC.runConduitRes $ + CL.sourceList ptWithTrailing + DC..| fuseBoth + ( conduitDecryptCheckedWithDecryptPolicy + lenientDecryptPolicy + (\_ -> pure Nothing) + (fakeCallback passphrase) + ) + CL.consume + ) + ( \e -> do + let err = show (e :: SomeException) + assertFailure + ("lenient decrypt threw unexpected exception: " ++ err) + fail "unreachable" + ) + assertEqual + ("DecryptTrailingData for " ++ encfile) + DecryptTrailingData + outcome + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +{- | Same as above but with strict policy: should throw "after message +integrity boundary". +-} +testTrailingDataRejectedStrict + :: FilePath -> FilePath -> Assertion +testTrailingDataRejectedStrict encfile passfile = do + passphrase <- readFixtureLazy passfile + pt <- readFixturePackets encfile + let trailingPkt = OtherPacketPkt 0xFE "" + ptWithTrailing = pt ++ [trailingPkt] + result <- + try + ( DC.runConduitRes $ + CL.sourceList ptWithTrailing + DC..| fuseBoth + (conduitDecryptChecked (fakeCallback passphrase)) + CL.consume + ) + :: IO (Either SomeException (DecryptOutcome, [Pkt])) + case result of + Left err -> + assertFailure + ( "Expected DecryptMalformedStructure but got exception: " + ++ show err + ) + Right (DecryptMalformedStructure malformedReason, _) -> + assertBool + ( "Expected 'after message integrity boundary', got: " + ++ malformedReason + ) + ("after message integrity boundary" `isInfixOf` malformedReason) + Right (other, _) -> + assertFailure + ("Expected DecryptMalformedStructure but got: " ++ show other) + where + fakeCallback :: BL.ByteString -> String -> IO BL.ByteString + fakeCallback = const . return + +encryptedSEIPDv2Packets :: IO [Pkt] +encryptedSEIPDv2Packets = do + let passphrase = + mkPassphrase + (BL.pack (map (fromIntegral . fromEnum) ("test" :: String))) + payload = + mkClearPayload + (BL.pack (map (fromIntegral . fromEnum) ("hello" :: String))) + let result = + encryptMessageDefault + DoNotExposeSessionMaterial + passphrase + payload + case result of + Left err -> + fail + ( "encryptedSEIPDv2Packets: encryptMessageDefault failed: " + ++ show err + ) + Right (encPayload, _) -> + DC.runConduitRes $ + CB.sourceLbs (encryptedPayloadBytes encPayload) + DC..| conduitGet get + DC..| CL.consume + +defaultOptionsForPassphrase :: BL.ByteString -> DecryptOptions +defaultOptionsForPassphrase passphrase = + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithoutPKESK + , decryptOptionsPolicy = defaultDecryptPolicy + , decryptOptionsPassphraseCallback = const (pure passphrase) + } + +testDecryptCleanSEIPDv2 :: Assertion +testDecryptCleanSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + (outcome, _) <- + catch + ( DC.runConduitRes $ + CL.sourceList pt + DC..| fuseBoth (conduitDecryptChecked cb) CL.consume + ) + ( \e -> + assertFailure + ("unexpected exception: " ++ show (e :: SomeException)) + >> fail "unreachable" + ) + assertEqual + "clean SEIPD v2 should yield DecryptClean" + DecryptClean + outcome + +testOptionsMatchesCheckedDefaultSEIPDv2 :: Assertion +testOptionsMatchesCheckedDefaultSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + opts = defaultOptionsForPassphrase passphrase + checkedResult <- + DC.runConduitRes $ + CL.sourceList pt + DC..| fuseBoth (conduitDecryptChecked cb) CL.consume + optionsResult <- + DC.runConduitRes $ + CL.sourceList pt + DC..| fuseBoth (DCD.conduitDecrypt opts) CL.consume + assertEqual + "options conduit should match checked conduit on clean decrypt" + checkedResult + optionsResult + +testOptionsMatchesLegacyDefaultOutputSEIPDv2 :: Assertion +testOptionsMatchesLegacyDefaultOutputSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + opts = defaultOptionsForPassphrase passphrase + legacyOutput <- + DC.runConduitRes $ + CL.sourceList pt DC..| conduitDecrypt cb DC..| CL.consume + (optionsOutcome, optionsOutput) <- + DC.runConduitRes $ + CL.sourceList pt + DC..| fuseBoth (DCD.conduitDecrypt opts) CL.consume + assertEqual + "options conduit should report DecryptClean for clean stream" + DecryptClean + optionsOutcome + assertEqual + "legacy conduit output should match options conduit output" + legacyOutput + optionsOutput + +testTrailingDataRejectedStrictSEIPDv2 :: Assertion +testTrailingDataRejectedStrictSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""] + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + result <- + try + ( DC.runConduitRes $ + CL.sourceList ptWithTrailing + DC..| fuseBoth (conduitDecryptChecked cb) CL.consume + ) + :: IO (Either SomeException (DecryptOutcome, [Pkt])) + case result of + Left err -> + assertFailure + ( "Expected DecryptMalformedStructure but got exception: " + ++ show err + ) + Right (DecryptMalformedStructure reason, _) -> + assertBool + ("Expected 'after message integrity boundary', got: " ++ reason) + ("after message integrity boundary" `isInfixOf` reason) + Right (other, _) -> + assertFailure + ( "Expected strict policy to reject trailing data but got: " + ++ show other + ) + +testTrailingDataReportedLenientSEIPDv2 :: Assertion +testTrailingDataReportedLenientSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""] + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + (outcome, _) <- + catch + ( DC.runConduitRes $ + CL.sourceList ptWithTrailing + DC..| fuseBoth + ( conduitDecryptCheckedWithDecryptPolicy + lenientDecryptPolicy + (\_ -> pure Nothing) + cb + ) + CL.consume + ) + ( \e -> + assertFailure + ("unexpected exception: " ++ show (e :: SomeException)) + >> fail "unreachable" + ) + assertEqual + "trailing packet should yield DecryptTrailingData" + DecryptTrailingData + outcome + +testOptionsMatchesCheckedLenientTrailingSEIPDv2 :: Assertion +testOptionsMatchesCheckedLenientTrailingSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""] + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + opts = + DecryptOptions + { decryptOptionsKeyResolution = DecryptWithoutPKESK + , decryptOptionsPolicy = lenientDecryptPolicy + , decryptOptionsPassphraseCallback = cb + } + checkedResult <- + DC.runConduitRes $ + CL.sourceList ptWithTrailing + DC..| fuseBoth + ( conduitDecryptCheckedWithDecryptPolicy + lenientDecryptPolicy + (\_ -> pure Nothing) + cb + ) + CL.consume + optionsResult <- + DC.runConduitRes $ + CL.sourceList ptWithTrailing + DC..| fuseBoth (DCD.conduitDecrypt opts) CL.consume + assertEqual + "options conduit should match checked lenient conduit with trailing data" + checkedResult + optionsResult + +testRejectsNonEncryptedAfterESKPrelude :: Assertion +testRejectsNonEncryptedAfterESKPrelude = do + pt <- encryptedSEIPDv2Packets + let malformed = + case pt of + [] -> [] + esk : _ -> + [ esk + , LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + "not-encrypted" + ] + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + result <- + try + ( DC.runConduitRes $ + CL.sourceList malformed + DC..| fuseBoth (conduitDecryptChecked cb) CL.consume + ) + :: IO (Either SomeException (DecryptOutcome, [Pkt])) + case result of + Left err -> + assertFailure + ( "Expected DecryptMalformedStructure but got exception: " + ++ show err + ) + Right (DecryptMalformedStructure reason, _) -> + assertBool + ("Expected ESK prelude shape failure, got: " ++ reason) + ( "ESK packets must immediately precede encrypted data" + `isInfixOf` reason + ) + Right (other, _) -> + assertFailure + ("Expected DecryptMalformedStructure but got: " ++ show other) + +testRejectsMisalignedESKVersionForSEIPDv2 :: Assertion +testRejectsMisalignedESKVersionForSEIPDv2 = do + pt <- encryptedSEIPDv2Packets + let malformed = + case pt of + ( SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa _ s2k _ _ _)) + : rest + ) -> + SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) + : rest + _ -> pt + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + result <- + try + ( DC.runConduitRes $ + CL.sourceList malformed + DC..| fuseBoth (conduitDecryptChecked cb) CL.consume + ) + :: IO (Either SomeException (DecryptOutcome, [Pkt])) + case result of + Left err -> + assertFailure + ( "Expected DecryptMalformedStructure but got exception: " + ++ show err + ) + Right (DecryptMalformedStructure reason, _) -> + assertBool + ("Expected payload/ESK alignment failure, got: " ++ reason) + ("version-aligned" `isInfixOf` reason) + Right (other, _) -> + assertFailure + ("Expected DecryptMalformedStructure but got: " ++ show other) + +testDiscardsMisalignedESKWhenAlignedCandidateExists :: Assertion +testDiscardsMisalignedESKWhenAlignedCandidateExists = do + pt <- encryptedSEIPDv2Packets + let withMixedPrelude = + case pt of + ( SKESKPkt + (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) + : rest + ) -> + SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) + : SKESKPkt + (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) + : rest + _ -> pt + passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String)) + cb = const (pure passphrase) + (outcome, _) <- + catch + ( DC.runConduitRes $ + CL.sourceList withMixedPrelude + DC..| fuseBoth (conduitDecryptChecked cb) CL.consume + ) + ( \e -> + assertFailure + ("unexpected exception: " ++ show (e :: SomeException)) + >> fail "unreachable" + ) + assertEqual + "misaligned ESKs should be discarded when an aligned ESK is present" + DecryptClean + outcome + +testSecretKeyDecryption :: FilePath -> FilePath -> Assertion +testSecretKeyDecryption keyfile passfile = do + passphrase <- readFixtureLazy passfile + kr <- + DC.runConduitRes $ + CB.sourceFile (fixturePath keyfile) + DC..| conduitGet get + DC..| CL.consume + SecretKey pkp ska <- + case kr of + [] -> + assertFailure + ("no packets found in secret key fixture " ++ keyfile) + >> fail "empty secret key fixture" + (firstPkt : _) -> + case (fromPktEither firstPkt :: Either String SecretKey) of + Left err -> + assertFailure + ("failed to coerce key packet to SecretKey: " ++ err) + >> fail err + Right x -> pure x + decrypted <- + case decryptPrivateKey (pkp, ska) passphrase of + Left err -> + assertFailure ("secret key decryption failed: " ++ err) + >> fail "secret key decryption failed" + Right x -> pure x + case decrypted of + SUUnencrypted skey _ -> doPkeyAndSkeyMatch (_pubkey pkp) skey + other -> + assertFailure + ( "secret key decryption should produce an unencrypted secret key, got: " + ++ show other + ) + +testLegacySecretKeyEncryptionRejected + :: FilePath -> FilePath -> Assertion +testLegacySecretKeyEncryptionRejected keyfile passfile = do + passphrase <- readFixtureLazy passfile + kr <- + DC.runConduitRes $ + CB.sourceFile (fixturePath keyfile) + DC..| conduitGet get + DC..| CL.consume + SecretKey pkp ska <- + case kr of + [] -> + assertFailure + ("no packets found in secret key fixture " ++ keyfile) + >> fail "empty secret key fixture" + (firstPkt : _) -> + case (fromPktEither firstPkt :: Either String SecretKey) of + Left err -> + assertFailure + ("failed to coerce key packet to SecretKey: " ++ err) + >> fail err + Right x -> pure x + case encryptPrivateKeyWithPolicyAndSaltAndIV + defaultPolicy + pkp + (Salt "\226~\197\a\202#\"G") + (IV "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t") + ska + passphrase of + Left err | "explicit legacy override required" `isInfixOf` err -> pure () + Left err -> + assertFailure + ( "legacy secret key encryption should be rejected with a policy error, got: " + ++ err + ) + Right _ -> + assertFailure + "legacy secret key encryption should reject implicit SHA-1 protection" + +testV6SecretKeyEncryptionRoundTrip :: Assertion +testV6SecretKeyEncryptionRoundTrip = do + passphrase <- readPKIPassphrase + armors <- loadArmor "v6-secret.pgp.aa" + armor <- + case armors of + (a : _) -> pure a + [] -> + assertFailure + "v6-secret.pgp.aa should contain one armored payload" + >> fail "expected one armored payload" + let packets = parsePkts (armorPayload armor) + SecretKey pkp ska <- + case [ sk + | pkt <- packets + , Right sk <- [fromPktEither pkt :: Either String SecretKey] + ] of + (sk : _) -> pure sk + [] -> + assertFailure + "v6-secret.pgp.aa should contain a secret key packet" + >> fail "expected secret key packet" + originalSKey <- + case ska of + SUUnencrypted skey _ -> pure skey + _ -> + assertFailure + "v6-secret.pgp.aa should contain unencrypted secret key material" + >> fail "expected unencrypted secret key" + changed <- + case encryptPrivateKeyWithPolicyAndSaltAndIV + defaultPolicy + pkp + (Salt "1234567890ABCDEF") + (IV "1234567890ABCDE") + ska + passphrase of + Left err -> + assertFailure ("v6 secret key encryption failed: " ++ err) + >> fail "v6 secret key encryption failed" + Right x -> pure x + case changed of + SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do + assertEqual + "v6 secret key encryption should use expected Argon2 t parameter" + 1 + t + assertEqual + "v6 secret key encryption should use expected Argon2 p parameter" + 4 + p + assertEqual + "v6 secret key encryption should use expected Argon2 encoded memory parameter" + 15 + em + assertBool + "v6 secret key encryption should emit encrypted payload" + (not (BL.null encryptedPayload)) + _ -> + assertFailure + "v6 secret key encryption should emit SUSAEAD/AES256/OCB with Argon2 S2K" + let serialized = runPut (put (toPkt (SecretKey pkp changed))) + reparsed = parsePkts serialized + (parsedPKP, parsedSKA) <- + case reparsed of + (SecretKeyPkt pkpayload skaddendum : _) -> pure (pkpayload, skaddendum) + _ -> + assertFailure + "re-serialized v6 secret key should parse back as a secret key packet" + >> fail "expected serialized secret key packet" + decrypted <- + case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of + Left err -> + assertFailure + ("v6 secret key roundtrip decryption failed: " ++ err) + >> fail "v6 secret key roundtrip decryption failed" + Right x -> pure x + case decrypted of + SUUnencrypted skey _ -> + assertEqual + "v6 secret key roundtrip should preserve secret key material" + originalSKey + skey + _ -> + assertFailure + "v6 secret key roundtrip should decrypt to unencrypted secret material" + +testV4SecretKeyAEADOCBRoundTripCompat :: Assertion +testV4SecretKeyAEADOCBRoundTripCompat = do + (pkp, privateKey) <- loadUnencryptedRsaSigner + let skey = RSAPrivateKey (RSA_PrivateKey privateKey) + passphrase = "legacy-aead-passphrase" + compatPolicy = + (policyForRFC RFC4880) + { policySecretKeyProtection = + policySecretKeyProtection defaultPolicy + } + salt = Salt (B.pack [0x00 .. 0x0f]) + iv = IV (B.pack [0x10 .. 0x1e]) + encrypted <- + case encryptPrivateKeyWithPolicyAndSaltAndIV + compatPolicy + pkp + salt + iv + (SUUnencrypted skey 0) + passphrase of + Left err -> + assertFailure ("v4 AEAD secret key encryption failed: " ++ err) + >> fail "v4 AEAD secret key encryption failed" + Right x -> pure x + case encrypted of + SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do + assertEqual + "v4 AEAD secret key encryption should use expected Argon2 t" + 1 + t + assertEqual + "v4 AEAD secret key encryption should use expected Argon2 p" + 4 + p + assertEqual + "v4 AEAD secret key encryption should use expected Argon2 encoded-memory" + 15 + em + assertBool + "v4 AEAD secret key encryption should emit encrypted payload" + (not (BL.null encryptedPayload)) + _ -> + assertFailure + "v4 secret key encryption should emit SUSAEAD/AES256/OCB with Argon2 S2K" + let serialized = runPut (put (toPkt (SecretKey pkp encrypted))) + reparsed = parsePkts serialized + (parsedPKP, parsedSKA) <- + case reparsed of + (SecretKeyPkt pkpayload skaddendum : _) -> pure (pkpayload, skaddendum) + _ -> + assertFailure + "re-serialized v4 AEAD secret key should parse back as a secret key packet" + >> fail "expected serialized secret key packet" + decrypted <- + case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of + Left err -> + assertFailure + ("v4 AEAD secret key roundtrip decryption failed: " ++ err) + >> fail "v4 AEAD secret key roundtrip decryption failed" + Right x -> pure x + case decrypted of + SUUnencrypted skey' _ -> + assertEqual + "v4 AEAD secret key roundtrip should preserve secret key material" + skey + skey' + _ -> + assertFailure + "v4 AEAD secret key roundtrip should decrypt to unencrypted secret material" + +testSUSymSecretKeyRoundTrip :: Assertion +testSUSymSecretKeyRoundTrip = do + passphrase <- readPKIPassphrase + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" + DC..| conduitGet get + DC..| CL.consume + (pkp, skey) <- + case packets of + (SecretKeyPkt pkpayload (SUUnencrypted sk _) : _) -> pure (pkpayload, sk) + _ -> + assertFailure + "unencrypted.seckey did not begin with an unencrypted secret key packet" + >> fail "expected unencrypted secret key packet" + let cleartext = legacyRsaSecretKeyBytes skey + cleartextLBS = BL.fromStrict cleartext + clearWithChecksum = + cleartextLBS <> runPut (putWord16be (legacyChecksum16 cleartext)) + iv = IV (B.pack [0 .. 15]) + sa = AES128 + keyMaterial <- + case string2Key (Simple DeprecatedMD5) 16 passphrase of + Left err -> + assertFailure + ("failed to derive SUSym key material: " ++ renderS2KError err) + >> fail "failed to derive SUSym key material" + Right km -> pure km + encrypted <- + case encryptNoNonce + sa + (Simple DeprecatedMD5) + iv + (BL.toStrict clearWithChecksum) + keyMaterial of + Left err -> + assertFailure + ("failed to encrypt legacy SUSym secret key: " ++ show err) + >> fail "failed to encrypt legacy SUSym secret key" + Right bs -> pure bs + let legacySka = SUSym sa iv (BL.fromStrict encrypted) + serialized = runPut (put (toPkt (SecretKey pkp legacySka))) + reparsed = parsePkts serialized + (parsedPKP, parsedSKA) <- + case reparsed of + (SecretKeyPkt pkpayload skaddendum : _) -> pure (pkpayload, skaddendum) + _ -> + assertFailure + "serialized SUSym secret key should parse back as a secret key packet" + >> fail "expected serialized secret key packet" + decrypted <- + case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of + Left err -> + assertFailure ("SUSym secret key decryption failed: " ++ err) + >> fail "SUSym secret key decryption failed" + Right x -> pure x + case decrypted of + SUUnencrypted parsedSKey _ -> + assertEqual + "SUSym secret key roundtrip should preserve secret key material" + skey + parsedSKey + _ -> + assertFailure + "SUSym secret key roundtrip should decrypt to unencrypted secret material" + +legacyRsaSecretKeyBytes :: SKey -> B.ByteString +legacyRsaSecretKeyBytes (RSAPrivateKey (RSA_PrivateKey (RSA.PrivateKey _ d p q _ _ _))) = + BL.toStrict $ + runPut $ + case inverse q p of + Just u -> do + put (MPI d) + put (MPI p) + put (MPI q) + put (MPI u) + Nothing -> error "invalid RSA key in legacy secret key test" +legacyRsaSecretKeyBytes _ = error "legacyRsaSecretKeyBytes requires an RSA secret key" + +legacyChecksum16 :: B.ByteString -> Word16 +legacyChecksum16 = + fromIntegral + . B.foldl' + (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) + 0 + +testLegacyEncryptionFixtureShape :: Assertion +testLegacyEncryptionFixtureShape = do + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/encryption.gpg" + DC..| conduitGet get + DC..| CL.consume + let hasKeyEncapsulation = any isKeyEncapsulation packets + hasEncryptedData = any isEncryptedData packets + assertBool + "encryption.gpg should contain PKESK or SKESK key-encapsulation" + hasKeyEncapsulation + assertBool + "encryption.gpg should contain encrypted data" + hasEncryptedData + where + isKeyEncapsulation (SKESKPkt _) = True + isKeyEncapsulation (PKESKPkt _) = True + isKeyEncapsulation _ = False + isEncryptedData SymEncDataPkt {} = True + isEncryptedData SymEncIntegrityProtectedDataPkt {} = True + isEncryptedData _ = False + +testBuildPKESKPayloadForRecipientRSA :: Assertion +testBuildPKESKPayloadForRecipientRSA = do + (baseRecipient, privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V6 baseRecipient + sessionKey = SessionKey (B.replicate 32 0x2e) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk builder rsa payload" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + PKESKRecipientKey + { pkeskRecipientPKPayload = Nothing + , pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey) + } + ) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- + buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial + pkeskPayload <- + case pkeskPayloadResult of + Left err -> + assertFailure + ("buildPKESKPayloadForRecipient failed: " ++ show err) + >> fail "buildPKESKPayloadForRecipient failed" + Right p -> pure p + case pkeskPayload of + PKESKPayloadV6Packet (PKESKPayloadV6 _ RSA eskBytesLazy) -> do + let eskBytes = BL.toStrict eskBytesLazy + assertBool + "PKESKv6 RSA ESK should include MPI framing" + (B.length eskBytes >= 2) + let mpiBits = + fromIntegral (B.index eskBytes 0) * 256 + + fromIntegral (B.index eskBytes 1) + mpiLen = (mpiBits + 7) `div` 8 + assertEqual + "PKESKv6 RSA ESK should be exactly one RFC9580 MPI" + (2 + mpiLen) + (B.length eskBytes) + other -> + assertFailure + ("Expected PKESKv6 RSA payload, got " ++ show other) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ PKESKPkt pkeskPayload + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESK builder RSA decrypt payload" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testBuildPKESKv3PayloadForRecipientRSAInterop :: Assertion +testBuildPKESKv3PayloadForRecipientRSAInterop = do + (baseRecipient, privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V4 baseRecipient + sessionKey = SessionKey (B.replicate 32 0x2d) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk builder rsa v3 interop payload" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyCallback _ = pure (Just (RSAPrivateKey (RSA_PrivateKey privateKey))) + keyContextCallback pkt = do + msk <- keyCallback pkt + pure $ + fmap + ( \sk -> + PKESKRecipientKey + { pkeskRecipientPKPayload = Nothing + , pkeskRecipientSKey = sk + } + ) + msk + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- + buildPKESKv3PayloadForRecipient + recipient + (pkeskV3SessionMaterial sessionMaterial) + pkeskPayload <- + case pkeskPayloadResult of + Left err -> + assertFailure + ("buildPKESKv3PayloadForRecipient failed: " ++ show err) + >> fail "buildPKESKv3PayloadForRecipient failed" + Right p@(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ RSA _)) -> pure p + Right other -> + assertFailure ("Expected PKESK3 RSA payload, got " ++ show other) + >> fail "Unexpected PKESK payload variant" + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ PKESKPkt pkeskPayload + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESKv3 RSA interop decrypt payload" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testBuildPKESKv3PayloadForRecipientSupportsV6Key :: Assertion +testBuildPKESKv3PayloadForRecipientSupportsV6Key = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V6 baseRecipient + sessionKey = SessionKey (B.replicate 32 0x11) + let expectedKeyId = + EightOctetKeyId + (BL.take 8 (unFingerprint (fingerprint recipient))) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + result <- + buildPKESKv3PayloadForRecipient + recipient + (pkeskV3SessionMaterial sessionMaterial) + case result of + Right (PKESKPayloadV3Packet (PKESKPayloadV3 _ keyId RSA _)) -> + assertEqual + "PKESKv3 builder should derive v6 key ID from the high-order 64 bits of the fingerprint" + expectedKeyId + keyId + Right payload -> + assertFailure + ( "Expected PKESK3 RSA payload for v6 recipient, got " + ++ show payload + ) + Left err -> + assertFailure + ( "Expected PKESK3 RSA payload for v6 recipient, got error " + ++ show err + ) + +testBuildPKESKv3PayloadForRecipientECDHInterop :: Assertion +testBuildPKESKv3PayloadForRecipientECDHInterop = do + let (recipientPub, recipientPriv) = syntheticNISTP256Low + recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + ( ECDHPubKey + (ECDSAPubKey (ECDSA_PublicKey recipientPub)) + SHA256 + AES128 + ) + sessionKey = SessionKey (B.replicate 32 0x21) + salt = Salt (B.pack [0x20 .. 0x3f]) + payload = "pkesk builder ecdh v3 interop payload" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipient + , pkeskRecipientSKey = recipientSKey + } + ) + ) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- + buildPKESKv3PayloadForRecipient + recipient + (pkeskV3SessionMaterial sessionMaterial) + pkeskPayload <- + case pkeskPayloadResult of + Left err -> + assertFailure + ("buildPKESKv3PayloadForRecipient failed: " ++ show err) + >> fail "buildPKESKv3PayloadForRecipient failed" + Right p@(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ ECDH _)) -> pure p + Right other -> + assertFailure + ("Expected PKESK3 ECDH payload, got " ++ show other) + >> fail "Unexpected PKESK payload variant" + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ PKESKPkt pkeskPayload + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESKv3 ECDH interop decrypt payload" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testPKESKv3ECDHWireFormat :: Assertion +testPKESKv3ECDHWireFormat = do + let (recipientPub, _) = syntheticNISTP256Low + recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + ( ECDHPubKey + (ECDSAPubKey (ECDSA_PublicKey recipientPub)) + SHA256 + AES256 + ) + -- Use a session key whose first byte is 0x00 so leading-zero stripping + -- is observable if i2osp truncates the wrapped key. + sessionKey = SessionKey (B.cons 0x00 (B.replicate 31 0xAB)) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskResult <- + buildPKESKv3PayloadForRecipient + recipient + (pkeskV3SessionMaterial sessionMaterial) + case pkeskResult of + Left err -> + assertFailure + ("buildPKESKv3PayloadForRecipient failed: " ++ show err) + Right p -> do + -- Serialise the packet to wire bytes then parse the PKESK body manually. + let wire = BL.toStrict (runPut (put (PKESKPkt p))) + -- Skip new-format tag byte (0xC1), then parse the packet length. + -- For the test we just round-trip through parsePkts and check the body layout. + case parsePkts (BL.fromStrict wire) of + [ PKESKPkt + ( PKESKPayloadV3Packet + (PKESKPayloadV3 _ _ ECDH (ephMPI NE.:| [wrappedMPI])) + ) + ] -> do + -- The ephemeral MPI should be non-trivially large (EC point). + assertBool "ephemeral MPI should be non-empty" (unMPI ephMPI > 0) + -- The wrapped MPI stores the raw i2osp bytes; for AES-256 the RFC 3394 + -- ciphertext is 48 bytes. i2osp strips leading zeros so the stored + -- integer may represent fewer bytes, but candidateWrappedRFC3394Ciphertexts + -- handles that. What we're checking here is the WIRE format: + -- after the ephemeral MPI there must be exactly 1-byte-len + C bytes, + -- not a second MPI header. + -- + -- Re-serialise and inspect the bytes after the ephemeral MPI manually. + let ephBytes = BL.toStrict (runPut (put ephMPI)) + pktBody = + -- wire: 0xC1 | varlen | version(1) | keyid(8) | pka(1) | body + -- skip tag(1) + len(variable) + version(1) + keyid(8) + pka(1) + -- We just serialise the body directly via putPKESKv3SessionKeyMaterial equivalent: + BL.toStrict + ( runPut + ( put + ( PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + ECDH + (ephMPI NE.:| [wrappedMPI]) + ) + ) + ) + ) + ) + -- Find the position of the body after tag+len+version+keyid+pka. + -- Tag: 1 byte; new-format len: 1 or 2 bytes; version: 1; keyid: 8; pka: 1 = 12 or 13 bytes + -- Instead of parsing the header, just verify the body doesn't start with + -- the two-byte MPI bit-count of the wrapped key. + -- After ephBytes in the body, the next byte should be the 1-byte count (24-48), + -- not the high byte of an MPI bit-count (which would be 0x01 for 383-bit keys). + -- We search for ephBytes in pktBody and check what follows. + let stripped = dropPKESKv3Header pktBody + afterEph = B.drop (B.length ephBytes) stripped + assertBool + "PKESKv3 ECDH wire body: after ephemeral MPI there must be at least 1 byte for wrapped-key length" + (not (B.null afterEph)) + let wrappedLenByte = fromIntegral (B.head afterEph) :: Int + assertBool + ( "PKESKv3 ECDH wire: wrapped-key length byte " + ++ show wrappedLenByte + ++ " should be a valid RFC 3394 wrapped-key length (24, 32, 40, or 48)" + ) + (wrappedLenByte `elem` [24, 32, 40, 48]) + assertEqual + "PKESKv3 ECDH wire: bytes after length field must equal length" + wrappedLenByte + (B.length (B.tail afterEph)) + other -> + assertFailure + ( "Expected single PKESKv3 ECDH packet after round-trip, got " + ++ show other + ) + where + -- Drop the new-format packet header (tag byte + variable-length field + + -- version byte + 8-byte key-id + pka byte) to reach the session-key material. + dropPKESKv3Header bs + | B.length bs < 3 = bs + | otherwise = + let lenByte = B.index bs 1 + headerLen + | lenByte < 192 = 2 -- 1-byte length + | lenByte < 224 = 3 -- 2-byte length + | otherwise = 6 -- 5-byte length (rare) + in B.drop (headerLen + 1 + 8 + 1) bs + +testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop + :: Assertion +testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop = do + let recipientSecretRaw = B.pack [1 .. 32] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ( "failed to initialize Curve25519Legacy recipient secret key: " + ++ show err + ) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + ( ECDHPubKey + ( EdDSAPubKey + EdSigningCurve25519 + ( PrefixedNativeEPoint + (EPoint (os2ip (B.cons 0x40 recipientPublicRaw))) + ) + ) + SHA256 + AES256 + ) + recipientSKey = + ECDHPrivateKey + ( ECDSA_PrivateKey + ( ECDSA.PrivateKey + (ECCT.getCurveByName ECCT.SEC_p256r1) + (os2ip recipientSecretRaw) + ) + ) + sessionKey = SessionKey (B.replicate 32 0x22) + salt = Salt (B.pack [0x40 .. 0x5f]) + payload = "pkesk builder curve25519legacy v3 interop payload" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipient + , pkeskRecipientSKey = recipientSKey + } + ) + ) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- + buildPKESKv3PayloadForRecipient + recipient + (pkeskV3SessionMaterial sessionMaterial) + pkeskPayload <- + case pkeskPayloadResult of + Left err -> + assertFailure + ("buildPKESKv3PayloadForRecipient failed: " ++ show err) + >> fail "buildPKESKv3PayloadForRecipient failed" + Right + p@( PKESKPayloadV3Packet + (PKESKPayloadV3 _ _ ECDH (ephemeralMPI NE.:| _)) + ) -> do + let ephemeralBytes = i2osp (unMPI ephemeralMPI) + assertEqual + "PKESKv3 Curve25519Legacy ephemeral point should be 0x40-prefixed 33-octet value" + 33 + (B.length ephemeralBytes) + assertEqual + "PKESKv3 Curve25519Legacy ephemeral point should use RFC6637 0x40 prefix" + 0x40 + (B.head ephemeralBytes) + pure p + Right other -> + assertFailure + ("Expected PKESK3 ECDH payload, got " ++ show other) + >> fail "Unexpected PKESK payload variant" + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ PKESKPkt pkeskPayload + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESKv3 Curve25519Legacy interop decrypt payload" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy + :: Assertion +testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy = do + let recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + ( ECDHPubKey + (EdDSAPubKey EdSigningCurve448 (PrefixedNativeEPoint (EPoint 1))) + SHA512 + AES256 + ) + sessionKey = SessionKey (B.replicate 32 0x23) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + result <- + buildPKESKv3PayloadForRecipient + recipient + (pkeskV3SessionMaterial sessionMaterial) + case result of + Left (InvalidRecipientKeyMaterial ECDH err) + | "RFC6637-compatible" `isInfixOf` err -> pure () + | otherwise -> + assertFailure + ("Expected RFC6637 compatibility rejection, got: " ++ err) + Left err -> + assertFailure + ("Expected InvalidRecipientKeyMaterial ECDH, got " ++ show err) + Right payload -> + assertFailure + ( "Expected RFC6637 compatibility rejection, got payload: " + ++ show payload + ) + +testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics + :: Assertion +testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics = do + let recipientSecretRaw = B.pack [1 .. 32] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + v4Recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + recipient = setKeyVersion V6 v4Recipient + sessionKey = SessionKey (B.replicate 32 0x24) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- + buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial + case pkeskPayloadResult of + Left err -> + assertFailure + ( "buildPKESKPayloadForRecipient failed for v6 X25519: " + ++ show err + ) + Right + (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 eskBytesLazy)) -> do + let eskBytes = BL.toStrict eskBytesLazy + assertX25519EskShape "v6 X25519 raw-key conformance" eskBytes + let wrappedLen = fromIntegral (B.index eskBytes 32) :: Int + assertEqual + "v6 X25519 wrapped session key (AES-KW RFC3394 of raw 32 bytes) must be 40 bytes" + 40 + wrappedLen + Right other -> + assertFailure + ("Expected PKESKPayloadV6 with X25519, got " ++ show other) + +{- | Conformance test: v6 X448 PKESK uses raw session key, not v3-encoded material. +RFC 9580 specifies that v6 X448 wraps the raw session key directly (no algorithm byte or checksum). +When the raw 32-byte key is AES-KW wrapped with RFC3394: 32 bytes + 8-byte integrity = 40 bytes. +If v3-encoded (1 byte algo + 32 bytes key + 2 bytes checksum + ~5 bytes padding = 40 bytes unwrapped), +the wrapped result would be ~48 bytes, so we verify wrapped size is 40. +-} +testBuildPKESKv6PayloadForRecipientX448RawKeySemantics + :: Assertion +testBuildPKESKv6PayloadForRecipientX448RawKeySemantics = do + let recipientSecretRaw = B.pack [1 .. 56] + recipientSecret = + case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X448 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString + v4Recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X448 + ( EdDSAPubKey + EdSigningCurve448 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + recipient = setKeyVersion V6 v4Recipient + sessionKey = SessionKey (B.replicate 32 0x25) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + pkeskPayloadResult <- + buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial + case pkeskPayloadResult of + Left err -> + assertFailure + ("buildPKESKPayloadForRecipient failed for v6 X448: " ++ show err) + Right (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 eskBytesLazy)) -> do + let eskBytes = BL.toStrict eskBytesLazy + assertX448EskShape "v6 X448 raw-key conformance" eskBytes + let wrappedLen = fromIntegral (B.index eskBytes 56) :: Int + assertEqual + "v6 X448 wrapped session key (AES-KW RFC3394 of raw 32 bytes) must be 40 bytes" + 40 + wrappedLen + Right other -> + assertFailure + ("Expected PKESKPayloadV6 with X448, got " ++ show other) + +testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop + :: Assertion +testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V4 baseRecipient + sessionKey = SessionKey (B.replicate 32 0x16) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + result <- + buildPKESKPayloadForRecipient + ForceV3Interop + recipient + sessionMaterial + case result of + Right (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ RSA _)) -> pure () + Right payload -> + assertFailure + ("Expected PKESK3 RSA for ForceV3Interop, got " ++ show payload) + Left err -> + assertFailure + ("Expected PKESK3 RSA for ForceV3Interop, got error " ++ show err) + +testRecipientVersionStrategyForProfileHonorsHints :: Assertion +testRecipientVersionStrategyForProfileHonorsHints = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V6 baseRecipient + case recipientVersionStrategyForProfile + EncryptStrictDefault + ( recipientEncryptionTargetWithStrategy + recipient + RecipientForceV3Interop + ) of + Right RecipientForceV3Interop -> pure () + other -> + assertFailure + ("Expected explicit recipient hint to win, got " ++ show other) + case recipientVersionStrategyForProfile + EncryptInteropLegacy + (recipientEncryptionTarget recipient) of + Right RecipientForceV3Interop -> pure () + other -> + assertFailure + ( "Expected legacy profile fallback to force v3, got " + ++ show other + ) + let v4Recipient = setKeyVersion V4 recipient + case recipientVersionStrategyForProfile + EncryptStrictDefault + (recipientEncryptionTarget recipient) of + Right RecipientPreferV6 -> pure () + other -> + assertFailure + ( "Expected strict profile auto-detect to prefer v6 for v6 recipients, got " + ++ show other + ) + case recipientVersionStrategyForProfile + EncryptStrictDefault + (recipientEncryptionTarget v4Recipient) of + Right RecipientForceV3Interop -> pure () + other -> + assertFailure + ( "Expected strict profile auto-detect to force v3 for legacy recipients, got " + ++ show other + ) + +testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies + :: Assertion +testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTarget v6Recipient + , recipientEncryptionTarget v4Recipient + ] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + , recipientEncryptRequestPayload = "recipient autodetect" + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = + Just (Salt (B.replicate 32 0x77)) + } + } + result <- encryptForRecipients request + case result of + Left err -> + assertFailure + ( "Expected mixed-recipient request to encrypt successfully, got " + ++ show err + ) + Right RecipientEncryptResult {recipientEncryptPackets = packets} -> do + let pkesks = [p | PKESKPkt p <- packets] + assertBool + "strict profile auto-detect should emit PKESKv6 for v6 recipients" + (any isPKESK6 pkesks) + assertBool + "strict profile auto-detect should emit PKESKv3 for v4 recipients" + (any isPKESK3 pkesks) + where + isPKESK6 PKESKPayloadV6Packet {} = True + isPKESK6 _ = False + isPKESK3 PKESKPayloadV3Packet {} = True + isPKESK3 _ = False + +testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled + :: Assertion +testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = + [AES128, AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + , recipientEncryptRequestPayload = + "recipient capability negotiation payload" + , recipientEncryptRequestSymmetricOverride = Nothing + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = + Just (Salt (B.replicate 32 0x22)) + } + } + result <- + encryptForRecipientsWithCapabilityNegotiation + RecipientCapabilityNegotiationOn + request + case result of + Left err -> + assertFailure + ( "Expected recipient capability negotiation to succeed, got " + ++ show err + ) + Right + RecipientEncryptResult + { recipientEncryptSessionMaterial = material + } -> + assertEqual + "capability negotiation should pick common preferred symmetric algorithm" + AES128 + (pkeskSessionAlgorithm material) + +testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault + :: Assertion +testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = + [AES128, AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + , recipientEncryptRequestPayload = + "default recipient capability negotiation payload" + , recipientEncryptRequestSymmetricOverride = Nothing + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = + Just (Salt (B.replicate 32 0x24)) + } + } + result <- encryptForRecipients request + case result of + Left err -> + assertFailure + ( "Expected default encryptForRecipients negotiation to succeed, got " + ++ show err + ) + Right + RecipientEncryptResult + { recipientEncryptSessionMaterial = material + } -> + assertEqual + "encryptForRecipients should negotiate recipient capabilities by default" + AES128 + (pkeskSessionAlgorithm material) + +testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut + :: Assertion +testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = + [AES128, AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + , recipientEncryptRequestPayload = + "legacy recipient capability opt-out payload" + , recipientEncryptRequestSymmetricOverride = Nothing + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = + Just (Salt (B.replicate 32 0x25)) + } + } + result <- encryptForRecipientsLegacy request + case result of + Left err -> + assertFailure + ( "Expected legacy encryptForRecipients opt-out to succeed, got " + ++ show err + ) + Right + RecipientEncryptResult + { recipientEncryptSessionMaterial = material + } -> + assertEqual + "encryptForRecipientsLegacy should preserve policy-default symmetric selection" + AES256 + (pkeskSessionAlgorithm material) + +testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm + :: Assertion +testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.empty + , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + , recipientEncryptRequestPayload = + "recipient capability mismatch payload" + , recipientEncryptRequestSymmetricOverride = Nothing + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = + Just (Salt (B.replicate 32 0x23)) + } + } + result <- + encryptForRecipientsWithCapabilityNegotiation + RecipientCapabilityNegotiationOn + request + case result of + Left + ( RecipientCapabilitySelectionFailure + (RecipientCapabilityNoCommonSymmetricAlgorithms _) + ) -> pure () + Left other -> + assertFailure + ( "Expected RecipientCapabilityNoCommonSymmetricAlgorithms, got " + ++ show other + ) + Right _ -> + assertFailure + "Expected recipient capability negotiation to fail without common symmetric algorithm" + +testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms + :: Assertion +testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms = do + (recipient, _privateKey) <- loadUnencryptedRsaSigner + let caps = + recipientCapabilitiesFromSubpacketPayloads + recipient + [OtherSigSub 39 (BL.pack [9, 2, 7, 3, 9, 2])] + assertEqual + "preferred AEAD ciphersuites subpacket should extract unique AEAD preferences in declaration order" + [OCB, GCM] + (recipientCapabilityPreferredAEADAlgorithms caps) + +testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled + :: Assertion +testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = + Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] + , recipientCapabilityPreferredSymmetricAlgorithms = + [AES128, AES256] + , recipientCapabilityPreferredAEADAlgorithms = [GCM, OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = + Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] + , recipientCapabilityPreferredSymmetricAlgorithms = [AES128] + , recipientCapabilityPreferredAEADAlgorithms = [GCM] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + , recipientEncryptRequestPayload = + "recipient AEAD capability negotiation payload" + , recipientEncryptRequestSymmetricOverride = Nothing + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Nothing + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = + Just (Salt (B.replicate 32 0x26)) + } + } + result <- + encryptForRecipientsWithCapabilityNegotiation + RecipientCapabilityNegotiationOn + request + case result of + Left err -> + assertFailure + ( "Expected AEAD capability negotiation to succeed, got " + ++ show err + ) + Right + RecipientEncryptResult + { recipientEncryptPackets = packets + , recipientEncryptSessionMaterial = material + } -> do + assertEqual + "AEAD capability negotiation should preserve symmetric negotiation" + AES128 + (pkeskSessionAlgorithm material) + case [ aa + | SymEncIntegrityProtectedDataPkt (SEIPD2 _ aa _ _ _) <- packets + ] of + [selectedAEAD] -> + assertEqual + "AEAD capability negotiation should pick common preferred AEAD algorithm" + GCM + selectedAEAD + other -> + assertFailure ("Expected one SEIPDv2 packet, got " ++ show other) + +testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm + :: Assertion +testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + v6Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V6 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = + Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] + , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + v4Caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = + Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2] + , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] + , recipientCapabilityPreferredAEADAlgorithms = [GCM] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps + , recipientEncryptionTargetWithCapabilities v4Recipient v4Caps + ] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + , recipientEncryptRequestPayload = + "recipient AEAD mismatch payload" + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Nothing + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = + Just (Salt (B.replicate 32 0x27)) + } + } + result <- + encryptForRecipientsWithCapabilityNegotiation + RecipientCapabilityNegotiationOn + request + case result of + Left + ( RecipientCapabilitySelectionFailure + (RecipientCapabilityNoCommonAEADAlgorithms _) + ) -> pure () + Left other -> + assertFailure + ( "Expected RecipientCapabilityNoCommonAEADAlgorithms, got " + ++ show other + ) + Right _ -> + assertFailure + "Expected recipient capability negotiation to fail without common AEAD algorithm" + +testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 + :: Assertion +testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + v6Recipient = setKeyVersion V6 baseRecipient + sharedCaps keyVersion recipient = + RecipientCapabilities + { recipientCapabilityKeyVersion = keyVersion + , recipientCapabilityPublicKeyAlgorithm = _pkalgo recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.singleton FeatureSEIPDv1 + , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [ recipientEncryptionTargetWithCapabilities + v6Recipient + (sharedCaps V6 v6Recipient) + , recipientEncryptionTargetWithCapabilities + v4Recipient + (sharedCaps V4 v4Recipient) + ] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + , recipientEncryptRequestPayload = + "recipient seipd fallback payload" + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Nothing + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = + Just (Salt (B.replicate 32 0x28)) + } + } + result <- encryptForRecipients request + case result of + Left err -> + assertFailure + ( "Expected fallback to SEIPDv1 when recipients do not advertise SEIPDv2, got " + ++ show err + ) + Right RecipientEncryptResult {recipientEncryptPackets = packets} -> do + let seipdPkts = [p | SymEncIntegrityProtectedDataPkt p <- packets] + case seipdPkts of + [SEIPD1 1 _] -> pure () + [SEIPD2 {}] -> + assertFailure + "Expected SEIPDv1 fallback when recipients do not advertise SEIPDv2 support" + other -> assertFailure ("Unexpected SEIPD packets: " ++ show other) + +testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC + :: Assertion +testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let v4Recipient = setKeyVersion V4 baseRecipient + caps = + RecipientCapabilities + { recipientCapabilityKeyVersion = V4 + , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient + , recipientCapabilityKeyFlags = Set.empty + , recipientCapabilityFeatures = Set.singleton FeatureSEIPDv2 + , recipientCapabilityPreferredSymmetricAlgorithms = [AES256] + , recipientCapabilityPreferredAEADAlgorithms = [OCB] + } + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [recipientEncryptionTargetWithCapabilities v4Recipient caps] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + , recipientEncryptRequestPayload = + "recipient seipd v1 capability failure payload" + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv1Overrides + { recipientEncryptRequestIVOverride = Nothing + } + } + result <- encryptForRecipients request + case result of + Left + ( RecipientCapabilitySelectionFailure + (RecipientCapabilityMissingSEIPDv1Support _) + ) -> pure () + Left other -> + assertFailure + ( "Expected RecipientCapabilityMissingSEIPDv1Support, got " + ++ show other + ) + Right _ -> + assertFailure + "Expected SEIPDv1 encryption to fail when recipients do not advertise MDC support" + +testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys + :: Assertion +testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys = do + (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer + (baseEncryptingSubkey, _privateKey) <- loadUnencryptedRsaSigner + let tkUnknown = + TKUnknown + { _tkuKey = (signingPrimary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = + [ + ( PublicSubkeyPkt + (setKeyTimestamp (_timestamp signingPrimary) baseEncryptingSubkey) + , [] + ) + ] + } + tk = + case fromUnknownToTK tkUnknown of + Right (SomePublicTK publicTk) -> publicTk + Right (SomeSecretTK _) -> error "expected public TK for recipient target test" + Left err -> error err + encryptingSubkey = + setKeyTimestamp (_timestamp signingPrimary) baseEncryptingSubkey + targets = recipientEncryptionTargetsFromTK tk + assertEqual + "TKUnknown-derived targets should include only encryption-capable keys" + 1 + (length targets) + case targets of + [target] -> + assertEqual + "TKUnknown-derived target should preserve selected encryption key" + (fingerprint encryptingSubkey) + (fingerprint (recipientEncryptionTargetKey target)) + _ -> + assertFailure "Expected exactly one encryption-capable target" + +testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary + :: Assertion +testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let primary = setKeyVersion V4 baseRecipient + subkey = setKeyVersion V6 baseRecipient + tkUnknown = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [])] + } + tk = + case fromUnknownToTK tkUnknown of + Right (SomePublicTK publicTk) -> publicTk + Right (SomeSecretTK _) -> + error "expected public TK for recipient target selection test" + Left err -> error err + case recipientEncryptionTargetFromTK tk of + Right target -> + assertEqual + "TKUnknown-derived single target should prioritize encryption subkeys" + (fingerprint subkey) + (fingerprint (recipientEncryptionTargetKey target)) + Left err -> + assertFailure + ( "Expected TKUnknown-derived target selection to succeed, got " + ++ show err + ) + +testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys + :: Assertion +testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys = do + (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer + let tkUnknown = + TKUnknown + { _tkuKey = (signingPrimary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [] + } + tk = + case fromUnknownToTK tkUnknown of + Right (SomePublicTK publicTk) -> publicTk + Right (SomeSecretTK _) -> error "expected public TK for recipient rejection test" + Left err -> error err + case recipientEncryptionTargetFromTK tk of + Left RecipientCapabilityNoEncryptableKeyMaterialInTK -> pure () + Left other -> + assertFailure + ( "Expected RecipientCapabilityNoEncryptableKeyMaterialInTK, got " + ++ show other + ) + Right _ -> + assertFailure + "Expected TKUnknown-derived target selection to reject non-encryptable TKs" + +testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections + :: Assertion +testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + report = + recipientEncryptionTargetsReportFromTKAtTimestamp + signatureTime + tk + acceptedFps = + map + (fingerprint . recipientEncryptionTargetKey) + (recipientEncryptionTargetsAccepted report) + rejectedReasons = + map + recipientEncryptionTargetRejectedReason + (recipientEncryptionTargetsRejected report) + assertBool + "report should keep encryption-eligible primary key as accepted" + (fingerprint primary `elem` acceptedFps) + assertEqual + "report should explain sign-only subkey rejection" + [ RecipientTargetMissingEncryptionFlags + subkey + (Set.fromList [SignDataKey]) + ] + rejectedReasons + +testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms + :: Assertion +testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms = do + (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer + let tk = + TKUnknown + { _tkuKey = (signingPrimary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [] + } + report = + recipientEncryptionTargetsReportFromTKAtTimestamp + (_timestamp signingPrimary) + tk + assertEqual + "unsupported key algorithms should be surfaced in report rejections" + [RecipientTargetUnsupportedAlgorithm (_pkalgo signingPrimary)] + ( map + recipientEncryptionTargetRejectedReason + (recipientEncryptionTargetsRejected report) + ) + +testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey + :: Assertion +testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + targetTime = ThirtyTwoBitTimeStamp 1700000020 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [ SigSubPacket + False + (KeyFlags (Set.fromList [EncryptCommunicationsKey])) + , SigSubPacket False (KeyExpirationTime (ThirtyTwoBitDuration 5)) + ] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + report = + recipientEncryptionTargetsReportFromTKAtTimestamp targetTime tk + rejectedReasons = + map + recipientEncryptionTargetRejectedReason + (recipientEncryptionTargetsRejected report) + assertBool + "expired subkey should be rejected from recipient targets" + ( RecipientTargetNotValidAtTimestamp subkey targetTime + `elem` rejectedReasons + ) + +testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey + :: Assertion +testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let bindingTime = ThirtyTwoBitTimeStamp 1700000000 + revocationTime = ThirtyTwoBitTimeStamp 1700000005 + targetTime = ThirtyTwoBitTimeStamp 1700000010 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + bindingTime + [ SigSubPacket + False + (KeyFlags (Set.fromList [EncryptCommunicationsKey])) + ] + subkeyRevocationSig <- + signSubkeyRevocationWithRSAAt + primary + subkey + signingKey + revocationTime + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = + [ (PublicSubkeyPkt subkey, [subkeyBindingSig, subkeyRevocationSig]) + ] + } + report = + recipientEncryptionTargetsReportFromTKAtTimestamp targetTime tk + rejectedReasons = + map + recipientEncryptionTargetRejectedReason + (recipientEncryptionTargetsRejected report) + assertBool + "revoked subkey should be rejected from recipient targets" + (RecipientTargetRevoked subkey `elem` rejectedReasons) + +testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities + :: Assertion +testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities = do + (primary, signingKey) <- loadUnencryptedRsaSigner + (subkey, _privateKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + directKeySig <- + signDirectKeyWithRSAExtrasAt + primary + signingKey + signatureTime + [ SigSubPacket False (PreferredSymmetricAlgorithms [AES128]) + , SigSubPacket False (OtherSigSub 39 (BL.pack [9, 2, 7, 3])) + ] + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [ SigSubPacket + False + (KeyFlags (Set.fromList [EncryptCommunicationsKey])) + ] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [directKeySig] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk + case targets of + (target : _) -> + case recipientEncryptionTargetCapabilities target of + Nothing -> + assertFailure + "Expected TKUnknown-derived target to include extracted capabilities" + Just caps -> do + assertEqual + "self-signature capability extraction should include primary-key symmetric preferences" + [AES128] + (recipientCapabilityPreferredSymmetricAlgorithms caps) + assertEqual + "self-signature capability extraction should include primary-key preferred AEAD algorithms" + [OCB, GCM] + (recipientCapabilityPreferredAEADAlgorithms caps) + assertEqual + "self-signature capability extraction should include subkey key flags" + (Set.fromList [EncryptCommunicationsKey]) + (recipientCapabilityKeyFlags caps) + [] -> + assertFailure "Expected at least one TKUnknown-derived target" + +testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering + :: Assertion +testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering = do + (primary, signingKey) <- loadUnencryptedRsaSigner + (subkey, _privateKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000100 + beforeSignature = ThirtyTwoBitTimeStamp 1699999999 + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [ SigSubPacket + False + (KeyFlags (Set.fromList [EncryptCommunicationsKey])) + ] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + case recipientEncryptionTargetFromTKAtTimestamp beforeSignature tk of + Left err -> + assertFailure + ( "Expected timestamp-scoped TKUnknown target selection to succeed, got " + ++ show err + ) + Right target -> + case recipientEncryptionTargetCapabilities target of + Nothing -> + assertFailure + "Expected TKUnknown-derived target to include capabilities when timestamp-scoped" + Just caps -> + assertEqual + "subkey binding created after target timestamp should not contribute key flags" + Set.empty + (recipientCapabilityKeyFlags caps) + +testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary + :: Assertion +testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [ SigSubPacket + False + (KeyFlags (Set.fromList [EncryptCommunicationsKey])) + ] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + case recipientEncryptionTargetFromTKAtTimestampWithPolicy + RecipientTargetSelectionPreferPrimary + signatureTime + tk of + Left err -> + assertFailure + ( "Expected policy-based recipient selection to succeed, got " + ++ show err + ) + Right target -> + assertEqual + "prefer-primary policy should select primary key when both primary and subkey are valid" + (fingerprint primary) + (fingerprint (recipientEncryptionTargetKey target)) + +testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest + :: Assertion +testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000002) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [ SigSubPacket + False + (KeyFlags (Set.fromList [EncryptCommunicationsKey])) + ] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + case recipientEncryptionTargetFromTKAtTimestampWithPolicy + RecipientTargetSelectionPreferNewestCreationTime + signatureTime + tk of + Left err -> + assertFailure + ( "Expected policy-based recipient selection to succeed, got " + ++ show err + ) + Right target -> + assertEqual + "prefer-newest policy should select newest valid key" + (fingerprint subkey) + (fingerprint (recipientEncryptionTargetKey target)) + +testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags + :: Assertion +testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk + let subkeyFp = fingerprint subkey + primaryFp = fingerprint primary + targetFps = map (fingerprint . recipientEncryptionTargetKey) targets + assertBool + "subkey with sign-only key flags should be excluded from encryption targets" + (subkeyFp `notElem` targetFps) + assertBool + "primary key (no explicit flags) should still be included as encryption target" + (primaryFp `elem` targetFps) + +testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags + :: Assertion +testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags = do + (baseKey, signingKey) <- loadUnencryptedRsaSigner + let signatureTime = ThirtyTwoBitTimeStamp 1700000000 + primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey + subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey + subkeyBindingSig <- + signSubkeyBindingWithRSAExtrasAt + primary + subkey + signingKey + signatureTime + [] + let tk = + TKUnknown + { _tkuKey = (primary, Nothing) + , _tkuRevs = [] + , _tkuUIDs = [] + , _tkuUAts = [] + , _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])] + } + targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk + let subkeyFp = fingerprint subkey + targetFps = map (fingerprint . recipientEncryptionTargetKey) targets + assertBool + "subkey with no key flags should be included as encryption target (legacy-compatible)" + (subkeyFp `elem` targetFps) + +testEncryptRecipientsWithRequestEmitsOnePassSignatures + :: Assertion +testEncryptRecipientsWithRequestEmitsOnePassSignatures = do + (baseRecipient, privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V6 baseRecipient + signature = + SigV4 + BinarySig + RSA + SHA256 + [] + [ SigSubPacket + False + (Issuer (EightOctetKeyId (BL.pack [0x01 .. 0x08]))) + ] + 0 + (MPI 1 :| []) + payload = "recipient one-pass signature payload" + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [recipientEncryptionTarget recipient] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + { recipientPayloadUseOnePassSignatures = True + , recipientPayloadSignatures = [signature] + } + , recipientEncryptRequestPayload = payload + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = + Just (Salt (B.replicate 32 0x55)) + } + } + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipient + , pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey) + } + ) + ) + passphraseCallback _ = pure BL.empty + result <- encryptForRecipients request + packets <- + case result of + Left err -> + assertFailure + ( "Expected one-pass encryption request to succeed, got " + ++ show err + ) + >> fail "encryptForRecipients failed" + Right + RecipientEncryptResult + { recipientEncryptPackets = encryptedPackets + } -> pure encryptedPackets + decrypted <- + DC.runConduitRes $ + CL.sourceList packets + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [ OnePassSignaturePkt + (OPSPayloadV3Packet (OPSPayloadV3 3 BinarySig SHA256 RSA _ False)) + , LiteralDataPkt _ _ _ gotPayload + , SignaturePkt _ + ] -> + assertEqual + "decrypted payload matches original plaintext" + (BL.fromStrict payload) + gotPayload + other -> + assertFailure + ( "Expected decrypted [OPS3, LiteralData, Signature], got " + ++ show other + ) + +testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing + :: Assertion +testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing = do + (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner + let recipient = setKeyVersion V6 baseRecipient + signature = SigV4 BinarySig RSA SHA256 [] [] 0 (MPI 1 :| []) + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [recipientEncryptionTarget recipient] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + { recipientPayloadUseOnePassSignatures = True + , recipientPayloadSignatures = [signature] + } + , recipientEncryptRequestPayload = + "recipient one-pass missing issuer metadata payload" + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv2Overrides + { recipientEncryptRequestAEADOverride = Just OCB + , recipientEncryptRequestChunkSizeOverride = Just 6 + , recipientEncryptRequestSaltOverride = + Just (Salt (B.replicate 32 0x56)) + } + } + result <- encryptForRecipients request + case result of + Left (PayloadBuildFailure err) -> + assertBool + "missing issuer metadata should surface as payload build failure" + ("without issuer metadata" `isInfixOf` err) + Left err -> + assertFailure + ( "Expected PayloadBuildFailure for missing OPS issuer metadata, got " + ++ show err + ) + Right _ -> + assertFailure + "Expected one-pass request without issuer metadata to fail" + +testEncryptInteropLegacyProducesSEIPDv1 :: Assertion +testEncryptInteropLegacyProducesSEIPDv1 = do + (recipient, privateKey) <- loadUnencryptedRsaSigner + let iv = IV (B.replicate 16 0xAB) + payload = "legacy interop payload" + request = + RecipientEncryptRequest + { recipientEncryptRequestTargets = + [recipientEncryptionTarget recipient] + , recipientEncryptRequestPayloadShape = + defaultRecipientPayloadShape + , recipientEncryptRequestPayload = payload + , recipientEncryptRequestSymmetricOverride = Just AES256 + , recipientEncryptRequestOverrides = + RecipientEncryptRequestSEIPDv1Overrides + { recipientEncryptRequestIVOverride = Just iv + } + } + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipient + , pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey) + } + ) + ) + passphraseCallback _ = pure BL.empty + result <- encryptForRecipients request + packets <- + case result of + Left err -> + assertFailure + ( "Expected EncryptInteropLegacy request to succeed, got " + ++ show err + ) + >> fail "encryptForRecipients failed" + Right RecipientEncryptResult {recipientEncryptPackets = ps} -> pure ps + let seipdPkts = [p | SymEncIntegrityProtectedDataPkt p <- packets] + case seipdPkts of + [SEIPD1 1 _] -> pure () + [SEIPD2 {}] -> assertFailure "Expected SEIPDv1 but got SEIPDv2" + other -> assertFailure ("Unexpected SEIPD packets: " ++ show other) + let pkeskPkts = [p | PKESKPkt p <- packets] + assertBool "EncryptInteropLegacy should emit PKESKv3 packets" $ + all + (\p -> case p of PKESKPayloadV3Packet {} -> True; _ -> False) + pkeskPkts + decrypted <- + DC.runConduitRes $ + CL.sourceList packets + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "decrypted legacy interop payload matches original" + (BL.fromStrict payload) + gotPayload + other -> + assertFailure + ("Expected [LiteralData] from legacy decrypt, got " ++ show other) + +testCanonicalizePKESKRecipientIdHelper :: Assertion +testCanonicalizePKESKRecipientIdHelper = do + let rid = BL.pack (0x04 : replicate 20 0x11) + payload = PKESKPayloadV6Packet (PKESKPayloadV6 rid RSA "esk") + case canonicalizePKESKRecipientId payload of + Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _)) + | BL.length normalized == 20 -> pure () + | otherwise -> + assertFailure + ( "Expected canonicalized recipient id length 20, got " + ++ show (BL.length normalized) + ) + Left err -> + assertFailure + ("canonicalizePKESKRecipientId failed unexpectedly: " ++ show err) + Right other -> + assertFailure + ( "Expected PKESK6 payload after canonicalization, got " + ++ show other + ) + case canonicalizePKESKRecipientId + ( PKESKPayloadV6Packet + (PKESKPayloadV6 (BL.replicate 19 0x22) RSA "esk") + ) of + Left (InvalidRecipientIdentifier _) -> pure () + other -> + assertFailure + ( "Expected InvalidRecipientIdentifier for malformed rid, got " + ++ show other + ) + case canonicalizePKESKRecipientId + ( PKESKPayloadV6Packet + (PKESKPayloadV6 (BL.pack (0x06 : replicate 32 0x33)) RSA "esk") + ) of + Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _)) + | BL.length normalized == 32 -> pure () + | otherwise -> + assertFailure + ( "Expected canonicalized v6 recipient id length 32, got " + ++ show (BL.length normalized) + ) + other -> + assertFailure + ( "Expected 0x06-prefixed v6 recipient id to canonicalize, got " + ++ show other + ) + case canonicalizePKESKRecipientId + ( PKESKPayloadV6Packet + (PKESKPayloadV6 (BL.pack (0x04 : replicate 32 0x44)) RSA "esk") + ) of + Left (InvalidRecipientIdentifier _) -> pure () + other -> + assertFailure + ( "Expected InvalidRecipientIdentifier for mismatched v4-prefixed v6-length rid, got " + ++ show other + ) + +testBuildPKESKPayloadUnsupportedRecipient :: Assertion +testBuildPKESKPayloadUnsupportedRecipient = do + let recipient = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1))) + sessionKey = SessionKey (B.replicate 32 0x19) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + result <- + buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial + case result of + Left (UnsupportedRecipientAlgorithm EdDSA) -> pure () + Left err -> + assertFailure + ("Expected UnsupportedRecipientAlgorithm EdDSA, got " ++ show err) + Right payload -> + assertFailure + ( "Expected UnsupportedRecipientAlgorithm, got payload: " + ++ show payload + ) + +testBuildPKESKPayloadRejectsECDHSHA1 :: Assertion +testBuildPKESKPayloadRejectsECDHSHA1 = do + let (recipientPub, _) = syntheticNISTP256Low + recipient = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + ( ECDHPubKey + (ECDSAPubKey (ECDSA_PublicKey recipientPub)) + SHA1 + AES256 + ) + sessionKey = SessionKey (B.replicate 32 0x19) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + result <- + buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial + case result of + Left (RecipientKdfFailure ECDH err) + | "SHA1 is disallowed by policy" `isInfixOf` err -> pure () + | otherwise -> + assertFailure + ( "Expected SHA1 policy rejection in RecipientKdfFailure, got: " + ++ err + ) + Left err -> + assertFailure + ("Expected RecipientKdfFailure ECDH for SHA1, got " ++ show err) + Right payload -> + assertFailure + ("Expected SHA1 policy rejection, got payload: " ++ show payload) + +testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey + :: Assertion +testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey = do + armoredMessage <- readFixtureStrict "seipdv2.pgp.aa" + armoredEncryptedSecret <- + readFixtureStrict "v6-encrypted-secret.pgp.aa" + armoredPlainSecret <- readFixtureStrict "v6-secret.pgp.aa" + passphrase <- readPKIPassphrase + messageArmors <- + case (AA.decode armoredMessage :: Either String [Armor]) of + Left err -> + assertFailure ("failed to decode seipdv2 armor: " ++ err) + >> pure [] + Right as -> pure as + encryptedSecretArmors <- + case (AA.decode armoredEncryptedSecret :: Either String [Armor]) of + Left err -> + assertFailure + ("failed to decode v6 encrypted secret armor: " ++ err) + >> pure [] + Right as -> pure as + plainSecretArmors <- + case (AA.decode armoredPlainSecret :: Either String [Armor]) of + Left err -> + assertFailure ("failed to decode v6 plain secret armor: " ++ err) + >> pure [] + Right as -> pure as + messageBody <- + case messageArmors of + (a : _) -> pure (armorPayload a) + [] -> + assertFailure "seipdv2 armor file contained no armor blocks" + >> pure mempty + encryptedSecretBody <- + case encryptedSecretArmors of + (a : _) -> pure (armorPayload a) + [] -> + assertFailure + "v6-encrypted-secret armor file contained no armor blocks" + >> pure mempty + plainSecretBody <- + case plainSecretArmors of + (a : _) -> pure (armorPayload a) + [] -> + assertFailure "v6-secret armor file contained no armor blocks" + >> pure mempty + let messagePackets = parsePkts messageBody + encryptedSecretPackets = parsePkts encryptedSecretBody + plainSecretPackets = parsePkts plainSecretBody + passphraseCallback _ = pure BL.empty + allKeyInfos <- + collectSecretKeyInfos + (encryptedSecretPackets ++ plainSecretPackets) + passphrase + let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt allKeyInfos) + if null allKeyInfos + then + assertFailure + ( "no usable secret key material found in v6-encrypted-secret fixture: " + ++ show + ( [ (_pkalgo pkp, ska) + | SecretKeyPkt pkp ska <- encryptedSecretPackets + ] + ++ [ (_pkalgo pkp, ska) + | SecretSubkeyPkt pkp ska <- encryptedSecretPackets + ] + ) + ) + else do + decrypted <- + DC.runConduitRes $ + CL.sourceList messagePackets + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + case [p | LiteralDataPkt _ _ _ p <- decrypted] of + (payload : _) -> + if BL.null payload + then + assertFailure "fixture decrypt produced empty literal payload" + else pure () + [] -> + assertFailure + ( "expected decrypted literal payload from seipdv2 fixture, got: " + ++ show decrypted + ) + +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey + :: Assertion +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey = do + (messagePackets, encryptedSecretPackets, passphrase) <- + loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" + let + passphraseCallback _ = pure BL.empty + keyInfos <- + collectSecretKeyInfos encryptedSecretPackets passphrase + let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) + decrypted <- + DC.runConduitRes $ + CL.sourceList messagePackets + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + case [p | LiteralDataPkt _ _ _ p <- decrypted] of + (payload : _) -> + if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload + then pure () + else + assertFailure + ( "unexpected decrypted payload for seipdv2-for-v4-key fixture: " + ++ show payload + ) + [] -> + assertFailure + ( "expected decrypted literal payload from seipdv2-for-v4-key fixture, got: " + ++ show decrypted + ) + +testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK + :: Assertion +testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK = do + (messagePackets, encryptedSecretPackets, passphrase) <- + loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" + let + bogusRid = BL.pack (0x06 : replicate 32 0x99) + bogusPKESK = + PKESKPkt + (PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk")) + (eskPrefix, encryptedSuffix) = span isPrecedingESK messagePackets + packetsWithBogusLatestPKESK = eskPrefix ++ [bogusPKESK] ++ encryptedSuffix + passphraseCallback _ = pure BL.empty + keyInfos <- + collectSecretKeyInfos encryptedSecretPackets passphrase + let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) + decrypted <- + DC.runConduitRes $ + CL.sourceList packetsWithBogusLatestPKESK + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + case [p | LiteralDataPkt _ _ _ p <- decrypted] of + (payload : _) -> + if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload + then pure () + else + assertFailure + ( "unexpected decrypted payload for seipdv2-for-v4-key fixture with bogus latest PKESK: " + ++ show payload + ) + [] -> + assertFailure + ( "expected decrypted literal payload with bogus latest PKESK, got: " + ++ show decrypted + ) + +testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations + :: Assertion +testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations = do + (messagePacketsRaw, encryptedSecretPackets, passphrase) <- + loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" + let messagePackets = map forceVersionedRecipientIdentifier messagePacketsRaw + passphraseCallback _ = pure BL.empty + keyInfos <- + collectSecretKeyInfos encryptedSecretPackets passphrase + let keyContextCallback pkt = pure (selectRecipientKeyInfoByRawRecipientId pkt keyInfos) + decrypted <- + DC.runConduitRes $ + CL.sourceList messagePackets + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + case [p | LiteralDataPkt _ _ _ p <- decrypted] of + (payload : _) -> + if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload + then pure () + else + assertFailure + ( "unexpected decrypted payload for recipient-id normalization fixture: " + ++ show payload + ) + [] -> + assertFailure + ( "expected decrypted literal payload for recipient-id normalization fixture, got: " + ++ show decrypted + ) + +testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial + :: Assertion +testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial = do + armors <- loadArmor "seipdv2-for-v4-key.pgp.aa" + armor <- + case armors of + (a : _) -> pure a + [] -> + assertFailure + "seipdv2-for-v4-key.pgp.aa should contain one armored payload" + >> fail "expected one armored payload" + let packets = parsePkts (armorPayload armor) + keyContextCallback _ = pure Nothing + passphraseCallback prompt = + fail ("unexpected manual PKESK session key prompt: " ++ prompt) + result <- + catch + ( Right + <$> ( DC.runConduitRes $ + CL.sourceList packets + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + ) + ) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> do + assertBool + "failure should report PKESK candidate exhaustion" + ("no matching key context" `isInfixOf` err) + assertBool + "failure should not request manual PKESK session material" + ( not + ("unexpected manual PKESK session key prompt" `isInfixOf` err) + ) + Right decrypted -> + assertFailure + ( "expected decryption failure when no PKESK key context is available, got: " + ++ show decrypted + ) + +testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey + :: Assertion +testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey = + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform + "seipdv2-two-recipients.pgp.aa" + id + +testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey + :: Assertion +testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey = + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform + "seipdv2-three-recipients.pgp.aa" + id + +testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs + :: Assertion +testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs = + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform + "seipdv2-two-recipients.pgp.aa" + (prependUnusableLatestPKESK . reorderPrecedingPKESKs) + +testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs + :: Assertion +testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs = + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform + "seipdv2-three-recipients.pgp.aa" + (prependUnusableLatestPKESK . reorderPrecedingPKESKs) + +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFile + :: FilePath -> Assertion +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFile fixture = + testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform + fixture + id + +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform + :: FilePath + -> ([Pkt] -> [Pkt]) + -> Assertion +testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform fixture transformPackets = do + (messagePacketsRaw, encryptedSecretPackets, passphrase) <- + loadSEIPDv2FixtureWithV4Secret fixture + let messagePackets = transformPackets messagePacketsRaw + passphraseCallback _ = pure BL.empty + keyInfos <- + collectSecretKeyInfos encryptedSecretPackets passphrase + let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) + decrypted <- + DC.runConduitRes $ + CL.sourceList messagePackets + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + case [p | LiteralDataPkt _ _ _ p <- decrypted] of + (payload : _) -> + if BL.null payload + then + assertFailure + (fixture ++ " decrypt produced empty literal payload") + else pure () + [] -> + assertFailure + ( "expected decrypted literal payload from " + ++ fixture + ++ ", got: " + ++ show decrypted + ) + +testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey :: Assertion +testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey = do + let sessionKey = B.replicate 32 0x2a + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "v6 pkesk session key decrypt path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + packets ct = + [ PKESKPkt + ( PKESKPayloadV6Packet + ( PKESKPayloadV6 + "\x01\x02\x03\x04\x05\x06\x07\x08" + RSA + "\x99\x88\x77" + ) + ) + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct)) + ] + callback _ = pure (BL.fromStrict sessionKey) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList (packets ciphertext) + DC..| conduitDecrypt callback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESKv6 raw session-key decrypt payload" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength + :: Assertion +testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength = do + let sessionKey = B.replicate 32 0x2a + badSessionKey = B.replicate 31 0x2a + salt = Salt (B.pack [0x00 .. 0x1f]) + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + "payload" + ] + packets ct = + [ PKESKPkt + ( PKESKPayloadV6Packet + ( PKESKPayloadV6 + "\x10\x11\x12\x13\x14\x15\x16\x17" + RSA + "\x01\x02\x03" + ) + ) + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct)) + ] + callback _ = pure (BL.fromStrict badSessionKey) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + result <- + catch + ( Right + <$> ( DC.runConduitRes $ + CL.sourceList (packets ciphertext) + DC..| conduitDecrypt callback + DC..| CL.consume + ) + ) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + if "PKESK raw session key length does not match payload algorithm" + `isInfixOf` err + then return () + else + assertFailure + ( "Expected PKESKv6 raw session-key length validation failure, got: " + ++ err + ) + Right got -> + assertFailure + ( "Expected PKESKv6 raw session-key length failure, got packets: " + ++ show got + ) + +testConduitDecryptSEIPDv2WithPKESKRSAUnwrap :: Assertion +testConduitDecryptSEIPDv2WithPKESKRSAUnwrap = do + (baseRecipient, privateKey) <- loadUnencryptedRsaSigner + publicKey <- + case _pubkey baseRecipient of + RSAPubKey (RSA_PublicKey pub) -> pure pub + other -> + assertFailure + ( "unencrypted.seckey did not contain an RSA recipient, got " + ++ show other + ) + >> fail "expected RSA recipient" + let sessionKey = B.replicate 32 0x2b + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk rsa unwrap decrypt path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = do + let msk = Just (RSAPrivateKey (RSA_PrivateKey privateKey)) + pure $ + fmap + ( \sk -> + PKESKRecipientKey + { pkeskRecipientPKPayload = Nothing + , pkeskRecipientSKey = sk + } + ) + msk + encryptedResult <- + ( P15.encrypt publicKey sessionKey + :: IO (Either RSA.Error B.ByteString) + ) + encryptedSessionMaterial <- + case encryptedResult of + Left err -> + assertFailure ("RSA PKESK encryption failed: " ++ show err) + >> pure mempty + Right ct -> pure ct + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + let pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\x11\x22\x33\x44\x55\x66\x77\x88") + RSA + (MPI (os2ip encryptedSessionMaterial) :| []) + ) + ) + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual "PKESK RSA unwrap decrypt payload" payload gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback + :: Assertion +testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback = do + (baseRecipient, privateKey) <- loadUnencryptedRsaSigner + publicKey <- + case _pubkey baseRecipient of + RSAPubKey (RSA_PublicKey pub) -> pure pub + other -> + assertFailure + ( "unencrypted.seckey did not contain an RSA recipient, got " + ++ show other + ) + >> fail "expected RSA recipient" + let sessionKey = B.replicate 32 0x2e + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk rsa unwrap decrypt path via wildcard callback fallback" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback pkt = + case pkt of + PKESKPkt + (PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _)) + | BL.length rid == 8 && BL.all (== 0) rid -> + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Nothing + , pkeskRecipientSKey = + RSAPrivateKey (RSA_PrivateKey privateKey) + } + ) + ) + _ -> pure Nothing + encryptedResult <- + ( P15.encrypt publicKey sessionKey + :: IO (Either RSA.Error B.ByteString) + ) + encryptedSessionMaterial <- + case encryptedResult of + Left err -> + assertFailure ("RSA PKESK encryption failed: " ++ show err) + >> pure mempty + Right ct -> pure ct + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + let pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\xaa\xbb\xcc\xdd\xee\xff\x00\x11") + RSA + (MPI (os2ip encryptedSessionMaterial) :| []) + ) + ) + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESK RSA unwrap via wildcard callback fallback payload" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey + :: Assertion +testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey = do + passphrase <- readPKIPassphrase + secretPackets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/aes256-sha512.seckey" + DC..| conduitGet get + DC..| CL.consume + keyInfos <- collectSecretKeyInfos secretPackets passphrase + keyInfo <- + case keyInfos of + (ki : _) -> pure ki + [] -> + assertFailure + "aes256-sha512.seckey should yield at least one RSA key context" + >> fail "expected key info" + publicKey <- + case pkeskRecipientPKPayload keyInfo of + Nothing -> + assertFailure + "key info from file should include a public key payload" + >> fail "expected public key payload" + Just pkp -> + case _pubkey pkp of + RSAPubKey (RSA_PublicKey pub) -> pure pub + other -> + assertFailure + ( "expected RSA public key from aes256-sha512.seckey, got " + ++ show other + ) + >> fail "expected RSA public key" + let sessionKey = B.replicate 32 0x42 + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk rsa unwrap via sha1-cfb protected key loaded from file" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) + encryptedResult <- + ( P15.encrypt publicKey sessionKey + :: IO (Either RSA.Error B.ByteString) + ) + encryptedSessionMaterial <- + case encryptedResult of + Left err -> + assertFailure ("RSA PKESK encryption failed: " ++ show err) + >> pure mempty + Right ct -> pure ct + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + let pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\x11\x22\x33\x44\x55\x66\x77\x88") + RSA + (MPI (os2ip encryptedSessionMaterial) :| []) + ) + ) + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESK RSA unwrap with SHA1-CFB protected key from file" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2WithPKESKECDHUnwrap :: Assertion +testConduitDecryptSEIPDv2WithPKESKECDHUnwrap = do + let (recipientPub, recipientPriv) = syntheticNISTP256Low + (ephPub, ephPriv) = syntheticNISTP256High + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + ( ECDHPubKey + (ECDSAPubKey (ECDSA_PublicKey recipientPub)) + SHA256 + AES128 + ) + recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) + sessionKey = B.replicate 32 0x2c + encodedSession = + B.singleton (fromFVal AES256) + <> sessionKey + <> encodeChecksum16 sessionKey + <> B.replicate 5 0 + sharedSecret = + BA.convert + ( ECCDH.getShared + (ECDSA.public_curve recipientPub) + (ECDSA.private_d ephPriv) + (ECDSA.public_q recipientPub) + ) + :: B.ByteString + kdfParam = + buildECDHKDFParamForTest + recipientPKP + ECDH + (ECDSA.public_curve recipientPub) + SHA256 + AES128 + kek = deriveECDHKekForTest SHA256 AES128 sharedSecret kdfParam + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek encodedSession + ephPointBytes = + maybe + (error "failed to encode ephemeral point") + id + (point2MBS (ECDSA.public_q ephPub)) + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip ephPointBytes) :| [MPI (os2ip wrappedSession)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh unwrap decrypt path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + ) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESK ECDH unwrap decrypt payload" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength + :: Assertion +testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength = do + let (recipientPub, recipientPriv) = syntheticNISTP256Low + (ephPub, ephPriv) = syntheticNISTP256High + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + ( ECDHPubKey + (ECDSAPubKey (ECDSA_PublicKey recipientPub)) + SHA256 + AES128 + ) + recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) + sessionKey = B.replicate 32 0x2c + encodedSession = + B.singleton (fromFVal AES256) + <> sessionKey + <> encodeChecksum16 sessionKey + <> B.replicate 5 0 + sharedSecret = + BA.convert + ( ECCDH.getShared + (ECDSA.public_curve recipientPub) + (ECDSA.private_d ephPriv) + (ECDSA.public_q recipientPub) + ) + :: B.ByteString + kdfParam = + buildECDHKDFParamForTest + recipientPKP + ECDH + (ECDSA.public_curve recipientPub) + SHA256 + AES128 + kek = deriveECDHKekForTest SHA256 AES128 sharedSecret kdfParam + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek encodedSession + ephPointBytes = + maybe + (error "failed to encode ephemeral point") + id + (point2MBS (ECDSA.public_q ephPub)) + truncatedEphemeral = B.take (B.length ephPointBytes - 1) ephPointBytes + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip truncatedEphemeral) :| [MPI (os2ip wrappedSession)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh wrong ephemeral point length" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + ) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + result <- + catch + ( Right + <$> DC.runConduitRes + ( CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + ) + ) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + assertBool + "ECDH unwrap should reject wrong uncompressed point length for recipient curve" + ("invalid length for recipient curve" `isInfixOf` err) + Right packets -> + assertFailure + ( "Expected ECDH point-length validation failure, got: " + ++ show packets + ) + +testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap :: Assertion +testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + recipientSKey = X25519PrivateKey recipientSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> + error + ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = + deriveX25519KekForTest + ephPublicRaw + recipientPublicRaw + sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6a) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef") + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x25519 v3 unwrap decrypt path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + ) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESK X25519 v3 unwrap decrypt payload" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder + :: Assertion +testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + recipientSKey = X25519PrivateKey recipientSecretRaw + wrongRecipientSecretRaw = B.pack [0x61 .. 0x80] + wrongRecipientSecret = + case CE.eitherCryptoError (C25519.secretKey wrongRecipientSecretRaw) of + Left err -> + error + ( "failed to initialize wrong X25519 recipient secret key: " + ++ show err + ) + Right sk -> sk + wrongRecipientPublicRaw = + BA.convert (C25519.toPublic wrongRecipientSecret) :: B.ByteString + wrongRecipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip wrongRecipientPublicRaw))) + ) + wrongRecipientSKey = X25519PrivateKey wrongRecipientSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> + error + ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = + deriveX25519KekForTest + ephPublicRaw + recipientPublicRaw + sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6b) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x25519 v3 wildcard key-id retry path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + wrongKeyInfo = + PKESKRecipientKey + { pkeskRecipientPKPayload = Just wrongRecipientPKP + , pkeskRecipientSKey = wrongRecipientSKey + } + correctKeyInfo = + PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + keyContextCallback _rid _pka = pure [wrongKeyInfo, correctKeyInfo] + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithCandidatesCallbackAndPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESKv3 wildcard-keyid retries across recipient key order" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder + :: Assertion +testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> + error + ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = + deriveX25519KekForTest + ephPublicRaw + recipientPublicRaw + sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6c) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x25519 v3 wildcard key-id long retry path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + mkSecretBytes offset = + B.pack + [fromIntegral ((offset + i) `mod` 256) | i <- [0 .. 31 :: Int]] + mkX25519RecipientKeyInfo label secretRaw = + let sk = + case CE.eitherCryptoError (C25519.secretKey secretRaw) of + Left err -> + error + ( "failed to initialize " + ++ label + ++ " X25519 secret key: " + ++ show err + ) + Right secretKey -> secretKey + publicRaw = BA.convert (C25519.toPublic sk) :: B.ByteString + in PKESKRecipientKey + { pkeskRecipientPKPayload = + Just + ( PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip publicRaw))) + ) + ) + , pkeskRecipientSKey = X25519PrivateKey secretRaw + } + wrongKeyInfos = + [ mkX25519RecipientKeyInfo + ("wrong-" ++ show n) + (mkSecretBytes (96 + n * 7)) + | n <- [1 .. 20 :: Int] + ] + correctKeyInfo = mkX25519RecipientKeyInfo "correct" recipientSecretRaw + keyContextCallback _rid _pka = pure (wrongKeyInfos ++ [correctKeyInfo]) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithCandidatesCallbackAndPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESKv3 wildcard-keyid retries long recipient key order" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder + :: Assertion +testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> + error + ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = + deriveX25519KekForTest + ephPublicRaw + recipientPublicRaw + sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6d) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) + ) + ) + payload = + "pkesk x25519 v3 wildcard key-id long retry legacy seipd1 path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + cleartext = BL.toStrict (runPut (put literalBlock)) + iv = IV (B.pack [0x33 .. 0x42]) + cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext + passphraseCallback _ = pure BL.empty + mkSecretBytes offset = + B.pack + [fromIntegral ((offset + i) `mod` 256) | i <- [0 .. 31 :: Int]] + mkX25519RecipientKeyInfo label secretRaw = + let sk = + case CE.eitherCryptoError (C25519.secretKey secretRaw) of + Left err -> + error + ( "failed to initialize " + ++ label + ++ " X25519 secret key: " + ++ show err + ) + Right secretKey -> secretKey + publicRaw = BA.convert (C25519.toPublic sk) :: B.ByteString + in PKESKRecipientKey + { pkeskRecipientPKPayload = + Just + ( PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip publicRaw))) + ) + ) + , pkeskRecipientSKey = X25519PrivateKey secretRaw + } + wrongKeyInfos = + [ mkX25519RecipientKeyInfo + ("wrong-" ++ show n) + (mkSecretBytes (96 + n * 7)) + | n <- [1 .. 20 :: Int] + ] + correctKeyInfo = mkX25519RecipientKeyInfo "correct" recipientSecretRaw + keyContextCallback _rid _pka = pure (wrongKeyInfos ++ [correctKeyInfo]) + ciphertext <- + either + ( \e -> + assertFailure ("encryptOpenPGPCfbRaw failed: " ++ show e) + >> pure mempty + ) + pure + ( encryptOpenPGPCfbRaw + OpenPGPCFBNoResyncW + AES256 + iv + cleartextWithMDC + (unSessionKey sessionKey) + ) + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD1 1 (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithCandidatesCallbackAndPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESKv3 wildcard-keyid retries long recipient key order for SEIPDv1" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testMkCandidateResolverDecryptsWildcardPKESKv3 :: Assertion +testMkCandidateResolverDecryptsWildcardPKESKv3 = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + recipientSKey = X25519PrivateKey recipientSecretRaw + wrongSecretRaw = B.pack [0x61 .. 0x80] + wrongSecret = + case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of + Left err -> + error + ("failed to initialize wrong X25519 secret key: " ++ show err) + Right sk -> sk + wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString + wrongPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip wrongPublicRaw))) + ) + wrongSKey = X25519PrivateKey wrongSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> + error + ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = + deriveX25519KekForTest + ephPublicRaw + recipientPublicRaw + sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6d) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "unwrap callback wildcard path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + wrongKeyInfo = + PKESKRecipientKey + { pkeskRecipientPKPayload = Just wrongPKP + , pkeskRecipientSKey = wrongSKey + } + correctKeyInfo = + PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo] + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| ( void $ + DCD.conduitDecrypt + DCD.DecryptOptions + { DCD.decryptOptionsKeyResolution = + DCD.DecryptWithUnwrapCandidatesCallback resolver + , DCD.decryptOptionsPolicy = lenientDecryptPolicy + , DCD.decryptOptionsPassphraseCallback = passphraseCallback + } + ) + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "unwrap callback should decrypt wildcard PKESK via candidate list" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptWildcardResolverProvidesTypedPreviousFailures + :: Assertion +testConduitDecryptWildcardResolverProvidesTypedPreviousFailures = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + recipientSKey = X25519PrivateKey recipientSecretRaw + wrongSecretRaw = B.pack [0x61 .. 0x80] + wrongSecret = + case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of + Left err -> + error + ("failed to initialize wrong X25519 secret key: " ++ show err) + Right sk -> sk + wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString + wrongPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip wrongPublicRaw))) + ) + wrongSKey = X25519PrivateKey wrongSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> + error + ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = + deriveX25519KekForTest + ephPublicRaw + recipientPublicRaw + sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6e) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "typed previous failures for wildcard retries" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + wrongKeyInfo = + PKESKRecipientKey + { pkeskRecipientPKPayload = Just wrongPKP + , pkeskRecipientSKey = wrongSKey + } + correctKeyInfo = + PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo] + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| ( void $ + DCD.conduitDecrypt + DCD.DecryptOptions + { DCD.decryptOptionsKeyResolution = + DCD.DecryptWithUnwrapCandidatesCallback resolver + , DCD.decryptOptionsPolicy = lenientDecryptPolicy + , DCD.decryptOptionsPassphraseCallback = passphraseCallback + } + ) + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "wildcard retries with typed previous failures should still decrypt" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + pure () + +testConduitDecryptWithReportCapturesWildcardResolverDiagnostics + :: Assertion +testConduitDecryptWithReportCapturesWildcardResolverDiagnostics = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + recipientSKey = X25519PrivateKey recipientSecretRaw + wrongSecretRaw = B.pack [0x61 .. 0x80] + wrongSecret = + case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of + Left err -> + error + ("failed to initialize wrong X25519 secret key: " ++ show err) + Right sk -> sk + wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString + wrongPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip wrongPublicRaw))) + ) + wrongSKey = X25519PrivateKey wrongSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> + error + ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = + deriveX25519KekForTest + ephPublicRaw + recipientPublicRaw + sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6f) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId (BL.replicate 8 0)) + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "conduitDecryptWithReport wildcard diagnostics" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + wrongKeyInfo = + PKESKRecipientKey + { pkeskRecipientPKPayload = Just wrongPKP + , pkeskRecipientSKey = wrongSKey + } + correctKeyInfo = + PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo] + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + (report, decrypted) <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| DC.fuseBoth + ( DCD.conduitDecryptWithReport + DCD.DecryptOptions + { DCD.decryptOptionsKeyResolution = + DCD.DecryptWithUnwrapCandidatesCallback resolver + , DCD.decryptOptionsPolicy = lenientDecryptPolicy + , DCD.decryptOptionsPassphraseCallback = passphraseCallback + } + ) + CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "wildcard retries with report diagnostics should decrypt" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + assertEqual + "decrypt report should preserve outcome" + DCD.DecryptClean + (DCD.decryptReportOutcome report) + case DCD.decryptReportSessionKeyResolutions report of + [resolution] -> do + assertEqual + "resolution path should be PKESK for wildcard key retries" + DCD.DecryptResolvedViaPKESK + (DCD.decryptSessionResolutionPath resolution) + let attempts = DCD.decryptSessionResolutionResolverAttempts resolution + assertBool + "report should contain wildcard resolver attempts" + (length attempts >= 2) + assertBool + "report should record typed previous failures in resolver attempt context" + ( any + ( \attempt -> + any + ( \failure -> + DCD.pkeskAttemptFailureKind failure + == DCD.PKESKAttemptUnwrapFailed + && DCD.pkeskAttemptFailureKeyContext failure == Just (V4, X25519) + ) + (DCD.pkeskResolverAttemptPreviousFailures attempt) + ) + attempts + ) + assertBool + "report should capture ResolveWith key context for X25519" + ( any + ( \attempt -> + DCD.pkeskResolverAttemptAction attempt + == DCD.ResolverAttemptResolveWith (Just (V4, X25519)) + ) + attempts + ) + other -> + assertFailure + ( "Expected exactly one session-key resolution report, got " + ++ show (length other) + ) + +testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength + :: Assertion +testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + recipientSKey = X25519PrivateKey recipientSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> + error + ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = + deriveX25519KekForTest + ephPublicRaw + recipientPublicRaw + sharedSecret + sessionKey = SessionKey (B.replicate 32 0x6a) + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey) + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + overlongEphemeral = ephPublicRaw <> "\x00\x01" + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef") + X25519 + (MPI (os2ip overlongEphemeral) :| [MPI (os2ip eskWithAlgo)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x25519 v3 wrong ephemeral length" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + ) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + result <- + catch + ( Right + <$> DC.runConduitRes + ( CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + ) + ) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + assertBool + "PKESKv3 X25519 unwrap should reject non-32-byte ephemeral values" + ( "invalid X25519 ephemeral public key length/prefix" + `isInfixOf` err + ) + Right packets -> + assertFailure + ( "Expected X25519 ephemeral-length validation failure, got: " + ++ show packets + ) + +testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519 + :: Assertion +testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519 = do + let recipientSecretRaw = B.pack [0x21 .. 0x40] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X25519 recipient secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + recipientSKey = X25519PrivateKey recipientSecretRaw + ephSecretRaw = B.pack [0x41 .. 0x60] + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ("failed to initialize X25519 ephemeral secret key: " ++ show err) + Right sk -> sk + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPub = + case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of + Left err -> + error + ("failed to initialize X25519 recipient public key: " ++ show err) + Right pk -> pk + sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString + kek = + deriveX25519KekForTest + ephPublicRaw + recipientPublicRaw + sharedSecret + sessionKeyBytes = B.replicate 32 0x6a + sessionKey = SessionKey sessionKeyBytes + wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek sessionKeyBytes + eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef") + X25519 + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) + ) + ) + skeskS2K = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 + skeskPassphrase = "correct horse battery staple" + wrongPassphrase = "wrong passphrase" + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "skesk->pkesk fallback decrypt path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + ) + ) + passphraseCallback _ = pure wrongPassphrase + keyLen <- + case keySize AES256 of + Left err -> + assertFailure ("keySize failed for AES256: " ++ show err) + >> fail "keySize failed" + Right n -> pure n + skeskKek <- + case string2Key skeskS2K keyLen skeskPassphrase of + Left err -> + assertFailure + ("string2Key failed for Argon2 SKESK: " ++ renderS2KError err) + >> fail "string2Key failed" + Right x -> pure x + skeskEncryptedEsk <- + case withSymmetricCipher AES256 skeskKek $ \cipher -> + paddedCfbEncrypt + cipher + (B.replicate (blockSize cipher) 0) + (B.singleton (fromFVal AES256) <> sessionKeyBytes) of + Left err -> + assertFailure + ("encrypting Argon2 SKESK ESK failed: " ++ show err) + >> fail "encrypting SKESK ESK failed" + Right x -> pure x + let skesk = + SKESKPkt + ( SKESKPayloadV4Packet + ( SKESKPayloadV4 + AES256 + skeskS2K + (Just (BL.fromStrict skeskEncryptedEsk)) + ) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ skesk + , pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "conduitDecrypt should fall back from failing Argon2 SKESK to PKESKv3 X25519" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK + :: Assertion +testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK = do + let skeskS2K = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 + passphrase = "password" + sessionKeyBytes = B.replicate 32 0x7b + sessionKey = SessionKey sessionKeyBytes + badLatestEsk = BL.fromStrict (B.pack [0x00]) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "earlier argon2 skesk fallback decrypt path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure passphrase + keyLen <- + case keySize AES256 of + Left err -> + assertFailure ("keySize failed for AES256: " ++ show err) + >> fail "keySize failed" + Right n -> pure n + skeskKek <- + case string2Key skeskS2K keyLen passphrase of + Left err -> + assertFailure + ("string2Key failed for Argon2 SKESK: " ++ renderS2KError err) + >> fail "string2Key failed" + Right x -> pure x + validEsk <- + case withSymmetricCipher AES256 skeskKek $ \cipher -> + paddedCfbEncrypt + cipher + (B.replicate (blockSize cipher) 0) + (B.singleton (fromFVal AES256) <> sessionKeyBytes) of + Left err -> + assertFailure + ("encrypting Argon2 SKESK ESK failed: " ++ show err) + >> fail "encrypting SKESK ESK failed" + Right x -> pure x + let earlierValidSKESK = + SKESKPkt + ( SKESKPayloadV4Packet + (SKESKPayloadV4 AES256 skeskS2K (Just (BL.fromStrict validEsk))) + ) + latestUnusableSKESK = + SKESKPkt + ( SKESKPayloadV4Packet + (SKESKPayloadV4 AES256 skeskS2K (Just badLatestEsk)) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ earlierValidSKESK + , latestUnusableSKESK + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + (\_ -> pure Nothing) + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "conduitDecrypt should retry earlier Argon2 SKESK when latest SKESK is unusable" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RejectsECDHNonTable30Params :: Assertion +testConduitDecryptSEIPDv2RejectsECDHNonTable30Params = do + let (recipientPub, recipientPriv) = syntheticNISTP256Low + (ephPub, ephPriv) = syntheticNISTP256High + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + ( ECDHPubKey + (ECDSAPubKey (ECDSA_PublicKey recipientPub)) + SHA256 + AES256 + ) + recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv) + sessionKey = B.replicate 32 0x2c + encodedSession = + B.singleton (fromFVal AES256) + <> sessionKey + <> encodeChecksum16 sessionKey + <> B.replicate 5 0 + sharedSecret = + BA.convert + ( ECCDH.getShared + (ECDSA.public_curve recipientPub) + (ECDSA.private_d ephPriv) + (ECDSA.public_q recipientPub) + ) + :: B.ByteString + kdfParam = + buildECDHKDFParamForTest + recipientPKP + ECDH + (ECDSA.public_curve recipientPub) + SHA256 + AES256 + kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + ephPointBytes = + maybe + (error "failed to encode ephemeral point") + id + (point2MBS (ECDSA.public_q ephPub)) + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip ephPointBytes) :| [MPI (os2ip wrappedSession)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh unwrap policy failure path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + ) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + result <- + catch + ( Right + <$> DC.runConduitRes + ( CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + ) + ) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + assertBool + "ECDH unwrap should reject non-Table-30 parameters" + ("Table 30 policy violation" `isInfixOf` err) + Right packets -> + assertFailure + ( "Expected Table 30 policy failure, got decrypted packets: " + ++ show packets + ) + +testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams + :: Assertion +testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams = do + let recipientSecretRaw = B.pack [1 .. 32] + ephSecretRaw = B.pack [101 .. 132] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ( "failed to initialize Curve25519Legacy recipient secret key: " + ++ show err + ) + Right sk -> sk + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ( "failed to initialize Curve25519Legacy ephemeral secret key: " + ++ show err + ) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + ( ECDHPubKey + ( EdDSAPubKey + EdSigningCurve25519 + ( PrefixedNativeEPoint + (EPoint (os2ip (B.cons 0x40 recipientPublicRaw))) + ) + ) + SHA256 + AES256 + ) + recipientSKey = + ECDHPrivateKey + ( ECDSA_PrivateKey + ( ECDSA.PrivateKey + (ECCT.getCurveByName ECCT.SEC_p256r1) + (os2ip recipientSecretRaw) + ) + ) + sessionKey = B.replicate 32 0x3d + encodedSession = + B.singleton (fromFVal AES256) + <> sessionKey + <> encodeChecksum16 sessionKey + <> B.replicate 5 0 + sharedSecret = + BA.convert + (C25519.dh (C25519.toPublic ephSecret) recipientSecret) + :: B.ByteString + kdfParam = + buildCurve25519LegacyKdfParamForTest + recipientPKP + ECDH + SHA256 + AES256 + kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh v4 curve25519legacy accepted-combo path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + ) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "v4 Curve25519Legacy ECDH should allow RFC6637-accepted parameters" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI + :: Assertion +testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI = do + let recipientSecretRaw = B.pack [1 .. 32] + ephSecretRaw = B.pack [101 .. 132] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ( "failed to initialize Curve25519Legacy recipient secret key: " + ++ show err + ) + Right sk -> sk + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ( "failed to initialize Curve25519Legacy ephemeral secret key: " + ++ show err + ) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPKP = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + ( ECDHPubKey + ( EdDSAPubKey + EdSigningCurve25519 + ( PrefixedNativeEPoint + (EPoint (os2ip (B.cons 0x40 recipientPublicRaw))) + ) + ) + SHA256 + AES256 + ) + recipientSKey = + ECDHPrivateKey + ( ECDSA_PrivateKey + ( ECDSA.PrivateKey + (ECCT.getCurveByName ECCT.SEC_p256r1) + (os2ip recipientSecretRaw) + ) + ) + sharedSecret = + BA.convert + (C25519.dh (C25519.toPublic ephSecret) recipientSecret) + :: B.ByteString + kdfParam = + buildCurve25519LegacyKdfParamForTest + recipientPKP + ECDH + SHA256 + AES256 + kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam + candidate = + find + ( \(_, wrappedSession) -> not (B.null wrappedSession) && B.head wrappedSession == 0x00 + ) + [ let sessionKeyBytes = + B.pack + [ fromIntegral ((seed + offset) `mod` 256) + | offset <- [0 .. 31] + ] + encodedSession = + B.singleton (fromFVal AES256) + <> sessionKeyBytes + <> encodeChecksum16 sessionKeyBytes + <> B.replicate 5 0 + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + in (SessionKey sessionKeyBytes, wrappedSession) + | seed <- [0 .. 4095 :: Int] + ] + case candidate of + Nothing -> + assertFailure + "failed to find deterministic Curve25519Legacy wrapped session key with leading zero" + Just (sessionKey, wrappedSession) -> do + let pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh v4 curve25519legacy truncated wrapped-mpi path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + ) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "v4 Curve25519Legacy ECDH should unwrap after wrapped-MPI leading-zero truncation" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params + :: Assertion +testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params = do + let recipientSecretRaw = B.pack [1 .. 32] + ephSecretRaw = B.pack [101 .. 132] + recipientSecret = + case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of + Left err -> + error + ( "failed to initialize Curve25519Legacy recipient secret key: " + ++ show err + ) + Right sk -> sk + ephSecret = + case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of + Left err -> + error + ( "failed to initialize Curve25519Legacy ephemeral secret key: " + ++ show err + ) + Right sk -> sk + recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString + ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString + recipientPKP = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + ECDH + ( ECDHPubKey + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + SHA512 + AES256 + ) + recipientSKey = + ECDHPrivateKey + ( ECDSA_PrivateKey + ( ECDSA.PrivateKey + (ECCT.getCurveByName ECCT.SEC_p256r1) + (os2ip recipientSecretRaw) + ) + ) + sessionKey = B.replicate 32 0x3d + encodedSession = + B.singleton (fromFVal AES256) + <> sessionKey + <> encodeChecksum16 sessionKey + <> B.replicate 5 0 + sharedSecret = + BA.convert + (C25519.dh (C25519.toPublic ephSecret) recipientSecret) + :: B.ByteString + kdfParam = + buildCurve25519LegacyKdfParamForTest + recipientPKP + ECDH + SHA512 + AES256 + kek = deriveECDHKekForTest SHA512 AES256 sharedSecret kdfParam + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + pkesk = + PKESKPkt + ( PKESKPayloadV3Packet + ( PKESKPayloadV3 + 3 + (EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22") + ECDH + (MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)]) + ) + ) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk ecdh v6 curve25519legacy strict path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = recipientSKey + } + ) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + result <- + catch + ( Right + <$> DC.runConduitRes + ( CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + ) + ) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + assertBool + "v6 Curve25519Legacy ECDH should remain strict" + ("Table 30 policy violation" `isInfixOf` err) + Right packets -> + assertFailure + ( "Expected Table 30 policy failure, got decrypted packets: " + ++ show packets + ) + +testConduitDecryptSEIPDv2WithPKESKX448Unwrap :: Assertion +testConduitDecryptSEIPDv2WithPKESKX448Unwrap = do + let recipientSecretRaw = B.pack [1 .. 56] + ephSecretRaw = B.pack [57 .. 112] + sessionKey = B.replicate 32 0x4d + encodedSession = + B.singleton (fromFVal AES256) + <> sessionKey + <> encodeChecksum16 sessionKey + <> B.replicate 5 0 + recipientSecret = + case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X448 recipient secret key: " ++ show err) + Right sk -> sk + ephSecret = + case CE.eitherCryptoError (C448.secretKey ephSecretRaw) of + Left err -> + error + ("failed to initialize X448 ephemeral secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString + ephPublicRaw = BA.convert (C448.toPublic ephSecret) :: B.ByteString + sharedSecret = + BA.convert (C448.dh (C448.toPublic recipientSecret) ephSecret) + :: B.ByteString + kek = + deriveX448KekForTest ephPublicRaw recipientPublicRaw sharedSecret + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + esk = + ephPublicRaw + <> B.singleton (fromIntegral (B.length wrappedSession)) + <> wrappedSession + recipientPKP = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + X448 + ( EdDSAPubKey + EdSigningCurve448 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + recipientRid = unFingerprint (fingerprint recipientPKP) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x448 unwrap decrypt path" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = X448PrivateKey recipientSecretRaw + } + ) + ) + pkesk = + PKESKPkt + ( PKESKPayloadV6Packet + (PKESKPayloadV6 recipientRid X448 (BL.fromStrict esk)) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + decrypted <- + DC.runConduitRes $ + CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + case decrypted of + [LiteralDataPkt _ _ _ gotPayload] -> + assertEqual + "PKESK X448 unwrap decrypt payload" + payload + gotPayload + other -> + assertFailure + ("Expected one decrypted literal packet, got " ++ show other) + +testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength + :: Assertion +testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength = do + let recipientSecretRaw = B.pack [1 .. 56] + ephSecretRaw = B.pack [57 .. 112] + sessionKey = B.replicate 32 0x4d + encodedSession = + B.singleton (fromFVal AES256) + <> sessionKey + <> encodeChecksum16 sessionKey + <> B.replicate 5 0 + recipientSecret = + case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of + Left err -> + error + ("failed to initialize X448 recipient secret key: " ++ show err) + Right sk -> sk + ephSecret = + case CE.eitherCryptoError (C448.secretKey ephSecretRaw) of + Left err -> + error + ("failed to initialize X448 ephemeral secret key: " ++ show err) + Right sk -> sk + recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString + ephPublicRaw = BA.convert (C448.toPublic ephSecret) :: B.ByteString + shortEphemeral = B.tail ephPublicRaw + sharedSecret = + BA.convert (C448.dh (C448.toPublic recipientSecret) ephSecret) + :: B.ByteString + kek = + deriveX448KekForTest ephPublicRaw recipientPublicRaw sharedSecret + wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession + esk = + shortEphemeral + <> B.singleton (fromIntegral (B.length wrappedSession)) + <> wrappedSession + recipientPKP = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + X448 + ( EdDSAPubKey + EdSigningCurve448 + (NativeEPoint (EPoint (os2ip recipientPublicRaw))) + ) + recipientRid = unFingerprint (fingerprint recipientPKP) + salt = Salt (B.pack [0x00 .. 0x1f]) + payload = "pkesk x448 wrong ephemeral length" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + payload + ] + passphraseCallback _ = pure BL.empty + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipientPKP + , pkeskRecipientSKey = X448PrivateKey recipientSecretRaw + } + ) + ) + pkesk = + PKESKPkt + ( PKESKPayloadV6Packet + (PKESKPayloadV6 recipientRid X448 (BL.fromStrict esk)) + ) + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + (SessionKey sessionKey) + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + assertFailure ("encryptSEIPDv2Payload failed: " ++ err) + >> pure mempty + Right ct -> pure ct + result <- + catch + ( Right + <$> DC.runConduitRes + ( CL.sourceList + [ pkesk + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) + ] + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + ) + ) + (\e -> pure (Left (show (e :: SomeException)))) + case result of + Left err -> + assertBool + "PKESKv6 X448 unwrap should reject non-56-byte ephemeral values" + ("expected 56-octet ephemeral value" `isInfixOf` err) + Right packets -> + assertFailure + ( "Expected X448 ephemeral-length validation failure, got: " + ++ show packets + ) + +testDecodeOpenPGPEncodedSessionKeyRejectsTooShort :: Assertion +testDecodeOpenPGPEncodedSessionKeyRejectsTooShort = + assertEqual + "encoded session key should reject too-short payloads" + (Left EncodedSessionKeyTooShort) + (decodeOpenPGPEncodedSessionKey (B.pack [0x09, 0x01])) + +testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch + :: Assertion +testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch = + assertEqual + "encoded session key should reject algorithm/key-length mismatches" + (Left (EncodedSessionKeyLengthMismatch AES128 16 3)) + ( decodeOpenPGPEncodedSessionKey + (B.pack [fromFVal AES128, 0x01, 0x02, 0x03]) + ) + +testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch + :: Assertion +testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch = + assertEqual + "encoded session key should reject checksum mismatches" + (Left EncodedSessionKeyChecksumMismatch) + ( decodeOpenPGPEncodedSessionKey + (B.pack ([fromFVal AES128] <> replicate 16 0x00 <> [0x00, 0x01])) + ) + +testSKESKRejectsUnknownVersion :: Assertion +testSKESKRejectsUnknownVersion = do + let s2k = Simple SHA256 + pkt = + SKESKPkt + (SKESKPayloadV4Packet (SKESKPayloadV4 AES128 s2k Nothing)) + encoded = BL.toStrict (runPut (put pkt)) + malformed = + BL.fromStrict + (B.take 2 encoded <> B.singleton 5 <> B.drop 3 encoded) + case runGet (get :: Get Pkt) malformed of + Right (BrokenPacketPkt errReason 3 _) -> + assertBool + ("expected unsupported SKESK version error, got: " ++ errReason) + ("unsupported SKESK packet version" `isInfixOf` errReason) + Right other -> + assertFailure + ( "unknown SKESK version should not parse successfully: " + ++ show other + ) + Left err -> + assertFailure + ( "unknown SKESK version should be reported as a broken packet: " + ++ err + ) + +testSKESK4EncryptedSessionKeyRejectsSimpleS2K :: Assertion +testSKESK4EncryptedSessionKeyRejectsSimpleS2K = do + let pkt = + SKESKPkt + ( SKESKPayloadV4Packet + ( SKESKPayloadV4 + AES128 + (Simple SHA256) + (Just (BL.pack [0x01, 0x02, 0x03])) + ) + ) + encoded = runPut (put pkt) + case runGet (get :: Get Pkt) encoded of + Right (BrokenPacketPkt errReason 3 _) -> + assertBool + ("expected Simple S2K rejection, got: " ++ errReason) + ("must not use Simple S2K" `isInfixOf` errReason) + Right other -> + assertFailure + ( "Simple-S2K v4 SKESK with encrypted session key should not parse successfully: " + ++ show other + ) + Left err -> + assertFailure + ( "Simple-S2K v4 SKESK with encrypted session key should be reported as a broken packet: " + ++ err + ) + +testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES + :: Assertion +testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES = + mapM_ assertRoundTrip [AES128, AES192, AES256] + where + passphrase = "password" + s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 + assertRoundTrip sa = do + keyLen <- + case keySize sa of + Left err -> + assertFailure + ("keySize failed for " ++ show sa ++ ": " ++ show err) + >> fail "keySize failed" + Right n -> pure n + kek <- + case string2Key s2k keyLen passphrase of + Left err -> + assertFailure + ("string2Key failed for " ++ show sa ++ ": " ++ renderS2KError err) + >> fail "string2Key failed" + Right x -> pure x + let sessionKey = B.pack (take keyLen (cycle [0x11, 0x22, 0x33, 0x44])) + encodedSessionKey = B.singleton (fromFVal sa) <> sessionKey + encryptedEsk <- + case withSymmetricCipher sa kek $ \cipher -> + paddedCfbEncrypt + cipher + (B.replicate (blockSize cipher) 0) + encodedSessionKey of + Left err -> + assertFailure + ( "encrypting SKESK v4 ESK failed for " + ++ show sa + ++ ": " + ++ show err + ) + >> fail "encrypting SKESK v4 ESK failed" + Right x -> pure x + let skesk = SKESK4Packet sa s2k (Just (BL.fromStrict encryptedEsk)) + case skesk2SessionKey skesk passphrase of + Right (decodedAlgo, decodedSessionKey) -> do + assertEqual + ("decoded SKESK v4 encrypted ESK algorithm for " ++ show sa) + sa + decodedAlgo + assertEqual + ("decoded SKESK v4 encrypted ESK session key for " ++ show sa) + sessionKey + decodedSessionKey + Left err -> + assertFailure + ( "decoding SKESK v4 encrypted ESK failed for " + ++ show sa + ++ ": " + ++ renderS2KError err + ) + +testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum + :: Assertion +testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum = do + let sa = AES128 + passphrase = "password" + s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 + sessionKey = B.pack (take 16 (cycle [0xaa, 0xbb, 0xcc, 0xdd])) + keyLen <- + case keySize sa of + Left err -> + assertFailure ("keySize failed: " ++ show err) + >> fail "keySize failed" + Right n -> pure n + kek <- + case string2Key s2k keyLen passphrase of + Left err -> + assertFailure ("string2Key failed: " ++ renderS2KError err) + >> fail "string2Key failed" + Right x -> pure x + let encodedWithChecksum = + B.singleton (fromFVal sa) + <> sessionKey + <> encodeChecksum16 sessionKey + encryptedEsk <- + case withSymmetricCipher sa kek $ \cipher -> + paddedCfbEncrypt + cipher + (B.replicate (blockSize cipher) 0) + encodedWithChecksum of + Left err -> + assertFailure + ("encrypting malformed SKESK v4 ESK failed: " ++ show err) + >> fail "encrypting malformed SKESK v4 ESK failed" + Right x -> pure x + let skesk = SKESK4Packet sa s2k (Just (BL.fromStrict encryptedEsk)) + case skesk2SessionKey skesk passphrase of + Left + ( S2KEncryptedSessionKeyDecodeError + (EncodedSessionKeyLengthMismatch AES128 16 18) + ) -> pure () + Left err -> + assertFailure + ( "expected SKESK v4 trailing-checksum rejection, got: " + ++ renderS2KError err + ) + Right _ -> + assertFailure + "expected SKESK v4 trailing-checksum rejection, but decode succeeded" + +testEncryptPassphraseWithPolicyForceV4Interop :: Assertion +testEncryptPassphraseWithPolicyForceV4Interop = do + let request = + PassphraseEncryptRequest + { passphraseEncryptVersionPolicy = PassphraseSKESKForceV4Interop + , passphraseEncryptSymmetricAlgorithm = AES128 + , passphraseEncryptS2K = Simple SHA256 + , passphraseEncryptPassphrase = "password" + , passphraseEncryptPayload = "hello" + , passphraseEncryptSEIPDv1IVOverride = + Just (IV (B.replicate 16 0x22)) + , passphraseEncryptSEIPDv2AEADOverride = Nothing + , passphraseEncryptSEIPDv2ChunkSizeOverride = Nothing + , passphraseEncryptSEIPDv2SaltOverride = Nothing + } + result <- encryptPassphraseWithPolicy request + case result of + Left err -> + assertFailure + ( "Expected passphrase SKESK force-v4 encryption to succeed, got: " + ++ err + ) + Right + ( SKESKPkt (SKESKPayloadV4Packet _) + : SymEncIntegrityProtectedDataPkt (SEIPD1 _ _) + : _ + ) -> + pure () + Right packets -> + assertFailure + ( "Expected SKESKv4 + SEIPDv1 packet sequence, got: " + ++ show packets + ) + +testEncryptPassphraseWithPolicyPreferV6 :: Assertion +testEncryptPassphraseWithPolicyPreferV6 = do + let request = + PassphraseEncryptRequest + { passphraseEncryptVersionPolicy = PassphraseSKESKPreferV6 + , passphraseEncryptSymmetricAlgorithm = AES128 + , passphraseEncryptS2K = Simple SHA256 + , passphraseEncryptPassphrase = "password" + , passphraseEncryptPayload = "hello" + , passphraseEncryptSEIPDv1IVOverride = Nothing + , passphraseEncryptSEIPDv2AEADOverride = Just OCB + , passphraseEncryptSEIPDv2ChunkSizeOverride = Just 6 + , passphraseEncryptSEIPDv2SaltOverride = + Just (Salt (B.replicate 32 0x44)) + } + result <- encryptPassphraseWithPolicy request + case result of + Left err -> + assertFailure + ( "Expected passphrase SKESK prefer-v6 encryption to succeed, got: " + ++ err + ) + Right + ( SKESKPkt (SKESKPayloadV6Packet _) + : SymEncIntegrityProtectedDataPkt (SEIPD2 _ _ _ _ _) + : _ + ) -> + pure () + Right packets -> + assertFailure + ( "Expected SKESKv6 + SEIPDv2 packet sequence, got: " + ++ show packets + ) + +testArgon2S2KVector :: Assertion +testArgon2S2KVector = do + let s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 + pass = BLC8.pack "password" + derivedKeyResult = string2Key s2k 16 pass + derivedKey <- + case derivedKeyResult of + Left err -> + assertFailure + ("Argon2 S2K key derivation failed: " ++ renderS2KError err) + >> fail "Argon2 key derivation failed" + Right x -> pure x + let + hex = + map toUpper . BLC8.unpack . B16L.encode . BL.fromStrict $ + derivedKey + assertEqual + "Argon2 S2K key derivation vector" + "A3BDFE3814D790F1F366ABA6954EB386" + hex + +testArgon2S2KOrdTotal :: Assertion +testArgon2S2KOrdTotal = do + let argon2A = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 + argon2B = Argon2 (Salt16 (B.pack [0x01 .. 0x10])) 1 4 15 + assertEqual + "Argon2 S2K compares after simple S2K" + GT + (compare argon2A (Simple SHA256)) + assertEqual + "Argon2 S2K compares before unknown S2K types" + LT + (compare argon2A (OtherS2K 101 BL.empty)) + assertEqual + "Argon2 S2K constructor compares lexicographically by fields" + LT + (compare argon2A argon2B) diff --git a/tests/Tests/Keys.hs b/tests/Tests/Keys.hs --- a/tests/Tests/Keys.hs +++ b/tests/Tests/Keys.hs @@ -2,1771 +2,2248 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Tests.Keys (keyAndVerificationTests) where - -import Codec.Encryption.OpenPGP.Expirations - ( effectiveKeyPreferencesAtTimestamp - , effectiveUIDPreferencesAtTimestamp - , isTKTimeValid - ) -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) -import Codec.Encryption.OpenPGP.Internal - ( emptyPSC - , lastPrimaryKey - , lastSubkey - ) -import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize) -import Codec.Encryption.OpenPGP.Message - ( asV6PKPayload - , mkEd25519SignerV6 - , mkRSASignerV6 - ) -import Codec.Encryption.OpenPGP.Policy - ( OpenPGPRFC(..) - , isAllowedPrimaryKeySig - , isAllowedSubkeySig - , isAllowedUIDSig - ) -import Codec.Encryption.OpenPGP.SecretKey - ( changePrivateKeyPassphrase - , decryptPrivateKey - , mkUnencryptedSKAddendum - , reinterpretUnknownSKeyForPKPayload - ) -import Codec.Encryption.OpenPGP.Serialize - ( getSecretKey - , parsePkts - , putSKeyForPKPayload - ) -import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig) -import Codec.Encryption.OpenPGP.Signatures -import Codec.Encryption.OpenPGP.Subpackets - ( sigBuilderInit - , sigBuilderInitRuntime - , sigBuilderInitV6 - , sigBuilderInitV6Runtime - , addHashedSubs - , addUnhashedSubs - , LegalSubpacket(..) - , listToHashedSubs - , listToUnhashedSubs - , listToLegalSubs - ) -import Codec.Encryption.OpenPGP.Types -import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA -import Control.Error.Util (isRight) -import Crypto.Number.Serialize (os2ip) -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import Data.Bifunctor (first) -import Data.Binary (get, put) -import Data.Binary.Get (Get, runGetOrFail) -import Data.Binary.Put (runPut) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Conduit as DC -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL -import Data.Conduit.OpenPGP.Compression (conduitDecompress) -import Data.Conduit.OpenPGP.Keyring (conduitToUnknownTKs) -import Data.Conduit.OpenPGP.Verify (conduitVerify) -import Data.Conduit.Serialization.Binary (conduitGet) -import Data.IxSet.Typed ((@=), getOne, size) -import Data.List (find, isInfixOf) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (isJust) -import qualified Data.Set as Set -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Prettyprinter (pretty) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) -import Tests.Common - ( assertSingleFailureContainsTimeline - , assertSingleSignerFingerprint - , loadAndDecompressPkts - , messageIssuerSubpacketsAt - , addTimestampSeconds - , armorPayload - , assertFalse - , assertTrue - , certificateVerificationFixtures - , fixturePath - , loadArmor - , loadDeterministicEd25519Signer - , loadKeyring - , loadUnencryptedRsaSigner - , loadUnencryptedRsaSignerV6 - , messageVerificationFixtures - , mkTestKeyring - , readFixturePayload - , readPKIPassphrase - , runGet - , setKeyVersion - , signBinaryMessageWithRSAAt - , signCertificationAt - , signCertificationRevocationAt - , signCertificationRevocationWithEd25519At - , signCertificationWithEd25519At - , signSubkeyBindingWithRSAExtrasAt - , timestampToUTCTime - , verificationFixtureGroup - , verifyMessageFromBytestring - , verifyMessageFromBytestringBatch - , verifyMessageFromPackets - , verifyMessageFromPacketsBatch - , verifyTimelinePackets - ) - - -keyAndVerificationTests :: TestTree -keyAndVerificationTests = - testGroup - "Keys and verification" - [ testGroup - "PKA/Size/KeyID/fingerprint group" - [ testCase - "v3 key" - (testPKAandSizeAndKeyIDandFingerprint - "v3.key" - "rsa/1024:6DC580F5C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E") - , testCase - "v4 key" - (testPKAandSizeAndKeyIDandFingerprint - "000001-006.public_key" - "rsa/1248:D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E") - , testCase - "ECDSA key" - (testPKAandSizeAndKeyIDandFingerprint - "nist_p-256_key.gpg" - "ecd/256:F7708BADD6063224/174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224") - , testCase - "EdDSA key" - (testPKAandSizeAndKeyIDandFingerprint - "sample-eddsa.pubkey" - "edd/256:8CFDE12197965A9A/C959 BDBA FA32 A2F8 9A15 3B67 8CFD E121 9796 5A9A") - , testCase - "EdDSA secret key (projected to public key packet)" - (testPKAandSizeAndKeyIDandFingerprint - "ed25519.secretkey" - "edd/256:B05F9287601D5914/B6FE 0C23 12EB D832 0238 C252 B05F 9287 601D 5914") - , testCase - "v6 secret key (projected to public key packet)" - (testPKAandSizeAndKeyIDandFingerprint - "v6-secret.pgp.aa" - "e25/256:7106CB6DB27E4FC9/7106 CB6D B27E 4FC9 B050 B02B B316 4DBD 4BBD 7263 D4D2 9E78 A3BB 3BDB B022 2D19") - ] - , testGroup - "Keyring group" - [ testCase - "pubring 7732CF988A63EA86" - (testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True) - , testCase - "pubring 123456789ABCDEF0" - (testKeyringLookup "pubring.gpg" "123456789ABCDEF0" False) - , testCase - "pubsub AD992E9C24399832" - (testKeyringLookup "pubring.gpg" "AD992E9C24399832" True) - , testCase - "secring 7732CF988A63EA86" - (testKeyringLookup "secring.gpg" "7732CF988A63EA86" True) - , testCase - "secring 123456789ABCDEF0" - (testKeyringLookup "secring.gpg" "123456789ABCDEF0" False) - , testCase - "secsub AD992E9C24399832" - (testKeyringLookup "secring.gpg" "AD992E9C24399832" True) - , testCase "pubring.gpg has 4 keys" (testKeyringSize "pubring.gpg" 4) - , testCase "secring.gpg has 4 keys" (testKeyringSize "secring.gpg" 4) - ] - , verificationFixtureGroup - "Message verification group (packet-based)" - verifyMessageFromPackets - messageVerificationFixtures - , verificationFixtureGroup - "Message verification group (packet-based, batch)" - verifyMessageFromPacketsBatch - messageVerificationFixtures - , verificationFixtureGroup - "Message verification group (bytestring-based)" - verifyMessageFromBytestring - messageVerificationFixtures - , verificationFixtureGroup - "Message verification group (bytestring-based, batch)" - verifyMessageFromBytestringBatch - messageVerificationFixtures - , verificationFixtureGroup - "Certificate verification group (packet-based)" - verifyMessageFromPackets - certificateVerificationFixtures - , verificationFixtureGroup - "Certificate verification group (packet-based, batch)" - verifyMessageFromPacketsBatch - certificateVerificationFixtures - , verificationFixtureGroup - "Certificate verification group (bytestring-based)" - verifyMessageFromBytestring - certificateVerificationFixtures - , verificationFixtureGroup - "Certificate verification group (bytestring-based, batch)" - verifyMessageFromBytestringBatch - certificateVerificationFixtures - , testGroup - "Key verification group" - [ testCase - "6F87040E pubkey" - (testKeysSelfVerification True "6F87040E.pubkey") - , testCase - "revoked pubkey" - (testKeysSelfVerification False "revoked.pubkey") - , testCase - "expired pubkey" - (testKeysSelfVerification True "expired.pubkey") - , testCase - "nist_p-256 pubkey" - (testKeysSelfVerification True "nist_p-256_key.gpg") - , testCase - "ed25519 pubkey" - (testKeysSelfVerification True "ed25519.pubkey") - ] - , testGroup - "Verification error messaging group" - [ testCase - "missing signing key in keyring" - (testMissingSigningKeyMessage - "ecdsa-key-without-ecdh.pubkey" - "uncompressed-ops-rsa.gpg") - , testCase - "tampered message signature mismatch" - (testTamperedSignatureMessage "pubring.gpg" "uncompressed-ops-rsa.gpg") - , testCase - "revoked certificate reports revocation" - (testRevokedCertificateMessage "revoked.pubkey") - ] - , testGroup - "Key expiration group" - [ testCase "6F87040E pubkey" (testKeysExpiration True "6F87040E.pubkey") - , testCase "expired pubkey" (testKeysExpiration False "expired.pubkey") - , testCase - "nist_p-256 pubkey" - (testKeysExpiration True "nist_p-256_key.gpg") - , testCase - "ed25519-without-curve25519.pubkey" - (testKeysExpiration True "ed25519-without-curve25519.pubkey") - , testCase "ed25519.pubkey" (testKeysExpiration True "ed25519.pubkey") - ] - , testGroup - "misc group" - [ testCase "conduitVerify processes SigV6 packets" testConduitVerifyProcessesSigV6 - , testCase "signature builder API (Phase 2)" testSignatureBuilders - , testCase "typed legal subpacket builder API (P2.1)" testLegalSubpacketBuilders - , testCase - "legacy secret key passphrase changes preserve protection" - testChangePrivateKeyPassphraseLegacy - , testCase "change private key passphrase" testChangePrivateKeyPassphraseV6 - , testCase - "getSecretKey parses v4 X25519 ECDH key material" - testGetSecretKeyHandlesV4X25519ECDHPubkey - , testCase - "v4 Ed25519 secret-key roundtrip preserves leading zero byte" - testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte - , testCase - "v4 Ed448 secret-key roundtrip preserves leading zero byte" - testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte - , testCase - "mkUnencryptedSKAddendum computes legacy secret-key checksum" - testMkUnencryptedSKAddendumComputesLegacyChecksum - , testCase - "mkUnencryptedSKAddendum sets v6 unencrypted checksum to zero" - testMkUnencryptedSKAddendumUsesV6ChecksumConvention - , testCase - "reinterpretUnknownSKeyForPKPayload decodes EdDSA unknown key material" - testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA - , testCase - "fromPrimaryKeyPktToTKUnknown rejects subkey packets" - testFromPrimaryKeyPktToTKUnknownRejectsSubkey - , testCase "policy signature context validation (RFC9580)" testPolicySignatureContextValidation - , testCase - "temporary validity uses latest effective self-signature window" - testTemporaryKeyValidityRespectsLatestSelfSignature - , testCase - "temporary validity rejects gaps with no effective self-signature" - testTemporaryKeyValidityRejectsSelfSignatureGaps - , testCase - "temporary validity rejects the gap before the first self-signature" - testTemporaryKeyValidityRejectsPreCertificationGap - , testCase - "temporary validity follows temporary self-revocations" - testTemporaryKeyValidityFollowsTemporarySelfRevocation - , testCase - "temporary validity does not revive older self-signatures after newer expiry" - testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures - , testCase - "uid-retired revocation is historical until effective" - testUidRetiredRevocationIsHistorical - , testCase - "third-party certifications do not affect primary key validity windows" - testThirdPartyCertificationDoesNotAffectKeyValidityWindow - , testCase - "certification revocations only remove matching signer certifications" - testCertificationRevocationOnlyRemovesMatchingSigner - , testCase - "preference resolution tracks active self-certification timeline" - testPreferencesAtTimestamp - , testCase - "verifySigWith rejects v6 revocation Issuer key-id subpackets" - testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID - , testCase - "verifySigWith rejects v6 revocation unhashed Issuer key-id subpackets" - testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed - , testCase - "verifySigWith accepts matching v6 revocation IssuerFingerprint" - testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint - , testCase "v6 signer constructor rejects v4 key" testV6SignerConstructorRejectsV4Key - , testCase - "primary key binding rejects unsupported critical hashed subpackets" - testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket - , testCase - "subkey binding missing back-signature is surfaced as a warning" - testSubkeyBindingMissingBackSignatureProducesWarning - , testCase - "subkey binding rejects unsupported critical hashed subpackets" - testSubkeyBindingRejectsUnsupportedCriticalSubpacket - ] - ] - -testPKAandSizeAndKeyIDandFingerprint :: FilePath -> String -> Assertion -testPKAandSizeAndKeyIDandFingerprint fpr kf = do - bs <- readFixturePayload fpr - case runGet (get :: Get Pkt) bs of - Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke." - Right pkt -> - case publicKeyPacketOf pkt of - PublicKeyPkt pkp -> do - let pref = - concat - [ pkalgoAbbrev (_pkalgo pkp) - , "/" - , either (const "unknown") show (pubkeySize (_pubkey pkp)) - , ":" - , either (const "unknown") (show . pretty) (eightOctetKeyID pkp) - , "/" - ] - assertEqual - ("for " ++ fpr ++ " (spaceless)") - (spaceless kf) - (pref ++ show (pretty (fingerprint pkp))) - assertEqual - ("for " ++ fpr ++ " (spaced)") - kf - (pref ++ show (pretty (SpacedFingerprint (fingerprint pkp)))) - _ -> assertFailure "Expected (possibly secret) key packet, got something else." - where - spaceless = filter (/= ' ') - -testKeyringLookup :: FilePath -> String -> Bool -> Assertion -testKeyringLookup fpr eok expected = do - kr <- loadKeyring fpr - let foundKey = getOne (kr @= (read eok :: EightOctetKeyId)) - assertEqual (eok ++ " in " ++ fpr) expected (isJust foundKey) - -testKeyringSize :: FilePath -> Int -> Assertion -testKeyringSize fpr expected = do - kr <- loadKeyring fpr - assertEqual ("key count in " ++ fpr) expected (size kr) - -assertLeftContains :: String -> Either VerificationError a -> Assertion -assertLeftContains needle result = - case result of - Left err -> - let rendered = renderVerificationError err - in - if needle `isInfixOf` rendered - then pure () - else - assertFailure - ("Expected error containing '" ++ needle ++ "', got '" ++ rendered ++ "'.") - Right _ -> assertFailure ("Expected Left containing '" ++ needle ++ "', got Right.") - -testMissingSigningKeyMessage :: FilePath -> FilePath -> Assertion -testMissingSigningKeyMessage keyring message = do - kr <- loadKeyring keyring - verification <- - DC.runConduitRes $ - CB.sourceFile (fixturePath message) DC..| conduitGet get DC..| conduitDecompress DC..| - conduitVerify kr Nothing DC..| - CL.consume - case verification of - [] -> assertFailure "Expected at least one verification result." - (firstResult:_) -> - assertLeftContains "signing key not found in keyring" firstResult - -testTamperedSignatureMessage :: FilePath -> FilePath -> Assertion -testTamperedSignatureMessage keyring message = do - kr <- loadKeyring keyring - packets <- loadAndDecompressPkts message - let tamperedPackets = map tamperLiteral packets - verification <- - DC.runConduitRes $ - CL.sourceList tamperedPackets DC..| conduitVerify kr Nothing DC..| CL.consume - case verification of - [] -> assertFailure "Expected at least one verification result." - (firstResult:_) -> - assertLeftContains "signature mismatch" firstResult - where - tamperLiteral (LiteralDataPkt dt fn ts payload) = - LiteralDataPkt dt fn ts (BL.snoc payload 0) - tamperLiteral pkt = pkt - -testRevokedCertificateMessage :: FilePath -> Assertion -testRevokedCertificateMessage keyfile = do - ks <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| conduitToUnknownTKs DC..| - CL.consume - assertLeftContains - "signing key is revoked" - (mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks) - -testKeysSelfVerification :: Bool -> FilePath -> Assertion -testKeysSelfVerification expectsuccess keyfile = do - ks <- - DC.runConduitRes $ - CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| - conduitToUnknownTKs DC..| - CL.consume - let verifieds = - mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks - assertEqual - (keyfile ++ " self-verification") - expectsuccess - (isRight verifieds) - -testKeysExpiration :: Bool -> FilePath -> Assertion -testKeysExpiration expectsuccess keyfile = do - ks <- - DC.runConduitRes $ - CB.sourceFile (fixturePath keyfile) DC..| conduitGet get DC..| - conduitToUnknownTKs DC..| - CL.consume - case mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks of - Left err -> - assertFailure - (keyfile ++ " key self-verification failed before expiration check: " ++ - renderVerificationError err) - Right verifieds -> do - let tvalid = - all - (isTKTimeValid - (posixSecondsToUTCTime (realToFrac (1400000000 :: Integer)))) - verifieds - assertEqual (keyfile ++ " key expiration") expectsuccess tvalid - -testConduitVerifyProcessesSigV6 :: Assertion -testConduitVerifyProcessesSigV6 = do - kr <- loadKeyring "pubring.gpg" - let sigPayload = - SigV6 - BinarySig - RSA - SHA256 - (SignatureSalt (BL.replicate 16 0)) - [] - [] - 0 - (MPI 0 :| []) - packets = - [ LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) "payload" - , SignaturePkt sigPayload - ] - verification <- - DC.runConduitRes $ - CL.sourceList packets DC..| conduitVerify kr Nothing DC..| CL.consume - case verification of - [Left _] -> return () - other -> - assertFailure - ("Expected one v6 verification result (failure is fine), got " ++ - show (length other) ++ " results") - -testSubkeyBindingRejectsUnsupportedCriticalSubpacket :: Assertion -testSubkeyBindingRejectsUnsupportedCriticalSubpacket = do - (primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner - (subkeySigner, _) <- loadDeterministicEd25519Signer - let creationTime = addTimestampSeconds (_timestamp primarySigner) 10 - (hashed, unhashed) <- messageIssuerSubpacketsAt primarySigner creationTime - let bindingPayload = - payloadForSig - SubkeyBindingSig - emptyPSC - { lastPrimaryKey = PublicKeyPkt primarySigner - , lastSubkey = PublicSubkeyPkt subkeySigner - } - hashedWithUnsupportedCritical = - SigSubPacket True (OtherSigSub 111 "unsupported-critical") : hashed - keyring = [TKUnknown (primarySigner, Nothing) [] [] [] []] - state = - emptyPSC - { lastPrimaryKey = PublicKeyPkt primarySigner - , lastSubkey = PublicSubkeyPkt subkeySigner - } - sigPayload <- - case signDataWithRSA - SubkeyBindingSig - primarySigningKey - hashedWithUnsupportedCritical - unhashed - bindingPayload of - Left err -> - assertFailure ("failed to sign subkey binding with unsupported critical subpacket: " ++ renderSignError err) >> - fail "expected subkey binding signature" - Right sig -> pure sig - case verifySigWith (verifyAgainstKeys keyring) (SignaturePkt sigPayload) state Nothing of - Left (UnsupportedCriticalSubpacket SubkeyBindingSig) -> pure () - Left err -> - assertFailure - ("Expected unsupported critical subpacket rejection for subkey binding signature, got: " ++ - renderVerificationError err) - Right _ -> - assertFailure - "Expected unsupported critical subpacket rejection for subkey binding signature, but verification succeeded" - -testSubkeyBindingMissingBackSignatureProducesWarning :: Assertion -testSubkeyBindingMissingBackSignatureProducesWarning = do - (primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner - (subkeySignerRaw, _) <- loadDeterministicEd25519Signer - let subkeySigner = setKeyVersion V6 subkeySignerRaw - creationTime = addTimestampSeconds (_timestamp primarySigner) 10 - keyring = [TKUnknown (primarySigner, Nothing) [] [] [] []] - state = - emptyPSC - { lastPrimaryKey = PublicKeyPkt primarySigner - , lastSubkey = PublicSubkeyPkt subkeySigner - } - sigPayload <- - signSubkeyBindingWithRSAExtrasAt - primarySigner - subkeySigner - primarySigningKey - creationTime - [SigSubPacket False (KeyFlags (Set.singleton SignDataKey))] - case verifySigWith (verifyAgainstKeys keyring) (SignaturePkt sigPayload) state Nothing of - Left err -> - assertFailure - ("Expected successful verification with warning for missing back-signature, got: " ++ - renderVerificationError err) - Right verification -> - assertBool - "v6 signing-capable subkey binding without embedded back-signature should emit warning" - (MissingSubkeyBackSignatureWarning `elem` _verificationWarnings verification) - -testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket :: Assertion -testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket = do - (signer, _) <- loadUnencryptedRsaSigner - let sigPayload = - SigV4 - PrimaryKeyBindingSig - RSA - SHA256 - [SigSubPacket True (OtherSigSub 111 "unsupported-critical")] - [] - 0 - (MPI 0 :| []) - verifyFn _ _ _ = Right (Verification signer sigPayload []) - state = - emptyPSC - { lastPrimaryKey = PublicKeyPkt signer - , lastSubkey = PublicSubkeyPkt signer - } - case verifySigWith verifyFn (SignaturePkt sigPayload) state Nothing of - Left (UnsupportedCriticalSubpacket PrimaryKeyBindingSig) -> pure () - Left err -> - assertFailure - ("Expected unsupported critical subpacket rejection for primary key binding signature, got: " ++ - renderVerificationError err) - Right _ -> - assertFailure - "Expected unsupported critical subpacket rejection for primary key binding signature, but verification succeeded" - -testSignatureBuilders :: Assertion -testSignatureBuilders = do - (_, signingKey) <- loadUnencryptedRsaSigner - -- Test RSA builder API with empty subpackets - let builderRsa = sigBuilderInit @'PKA.RSA BinarySig SHA512 - let builderRsaWithHashed = addHashedSubs (listToHashedSubs []) builderRsa - let builderRsaFinal = addUnhashedSubs (listToUnhashedSubs []) builderRsaWithHashed - case signDataWithRSABuilder builderRsaFinal signingKey "test payload" of - Left err -> assertFailure ("RSA builder API failed: " ++ renderSignError err) - Right (SigV4 BinarySig RSA SHA512 _ _ _ _) -> pure () - Right other -> - assertFailure ("RSA builder API should generate BinarySig RSA SHA512, got " ++ show other) - - -- Test RSA builder API with non-default hash algorithm - let builderRsaSha256 = sigBuilderInit @'PKA.RSA BinarySig SHA256 - builderRsaSha256WithHashed = - addHashedSubs (listToHashedSubs []) builderRsaSha256 - builderRsaSha256Final = - addUnhashedSubs (listToUnhashedSubs []) builderRsaSha256WithHashed - case signDataWithRSABuilder builderRsaSha256Final signingKey "test payload" of - Left err -> - assertFailure ("RSA SHA256 builder API failed: " ++ renderSignError err) - Right (SigV4 BinarySig RSA SHA256 _ _ _ _) -> - pure () - Right other -> - assertFailure ("RSA builder API should generate BinarySig RSA SHA256, got " ++ show other) - - -- Unsupported hash algorithms should be rejected by RSA PKCS#1 v1.5 backend - let builderRsaUnsupported = sigBuilderInit @'PKA.RSA BinarySig (OtherHA 99) - builderRsaUnsupportedWithHashed = - addHashedSubs (listToHashedSubs []) builderRsaUnsupported - builderRsaUnsupportedFinal = - addUnhashedSubs (listToUnhashedSubs []) builderRsaUnsupportedWithHashed - case signDataWithRSABuilder builderRsaUnsupportedFinal signingKey "test payload" of - Left (SignBackendError _) -> pure () - Left err -> - assertFailure - ("RSA builder API should reject unsupported hash with backend error, got " ++ - renderSignError err) - Right sig -> - assertFailure - ("RSA builder API should reject unsupported hash algorithm, got " ++ show sig) - - -- Runtime hash witness promotion should build RFC9580-compatible builders. - let runtimeRsa = - case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig SHA512 of - Left err -> Left err - Right builder -> - let withHashed = addHashedSubs (listToHashedSubs []) builder - withUnhashed = addUnhashedSubs (listToUnhashedSubs []) withHashed - in first renderSignError (signDataWithRSABuilder withUnhashed signingKey "test payload") - case runtimeRsa of - Left err -> - assertFailure - ("runtime RFC9580 SHA512 builder initialization should succeed, got " ++ err) - Right (SigV4 BinarySig RSA SHA512 _ _ _ _) -> pure () - Right other -> - assertFailure - ("runtime RFC9580 SHA512 builder should produce BinarySig RSA SHA512, got " ++ - show other) - - case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig SHA1 of - Left _ -> pure () - Right _ -> - assertFailure - "runtime RFC9580 builder initialization should reject deprecated SHA1" - - case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig (OtherHA 99) of - Left _ -> pure () - Right _ -> - assertFailure - "runtime builder initialization should reject non-witness-backed hash algorithms" - - -- Test Ed25519 builder API with empty subpackets - (_, edSigningKey) <- loadDeterministicEd25519Signer - let builderEd25519 = sigBuilderInit @'PKA.Ed25519 BinarySig SHA512 - let builderEd25519WithHashed = addHashedSubs (listToHashedSubs []) builderEd25519 - let builderEd25519Final = addUnhashedSubs (listToUnhashedSubs []) builderEd25519WithHashed - case signDataWithEd25519Builder builderEd25519Final edSigningKey "test payload" of - Left err -> assertFailure ("Ed25519 builder API failed: " ++ renderSignError err) - Right (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _) -> pure () - Right other -> - assertFailure ("Ed25519 builder API should generate BinarySig Ed25519 SHA512, got " ++ show other) - - -- Test Ed25519 v6 builder API - let v6Salt = SignatureSalt (BL.replicate 32 0x42) - let builderEd25519V6 = sigBuilderInitV6 @'PKA.Ed25519 BinarySig SHA512 v6Salt - let builderEd25519V6WithHashed = addHashedSubs (listToHashedSubs []) builderEd25519V6 - let builderEd25519V6Final = addUnhashedSubs (listToUnhashedSubs []) builderEd25519V6WithHashed - case signDataWithEd25519V6Builder builderEd25519V6Final edSigningKey "test payload" of - Left err -> assertFailure ("Ed25519 v6 builder API failed: " ++ renderSignError err) - Right (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _) -> - assertEqual "Ed25519 v6 builder API should preserve 32-byte salt" 32 (BL.length (unSignatureSalt salt)) - Right other -> - assertFailure ("Ed25519 v6 builder API should generate BinarySig Ed25519 SHA512 SigV6, got " ++ show other) - - -- Runtime v6 builder initialization should support SHA3 witness-backed hashes. - let v6Sha3Salt = SignatureSalt (BL.replicate 16 0x33) - runtimeEd25519V6Sha3 = - case sigBuilderInitV6Runtime @'PKA.Ed25519 RFC9580 BinarySig SHA3_256 v6Sha3Salt of - Left err -> Left err - Right builder -> - let withHashed = addHashedSubs (listToHashedSubs []) builder - withUnhashed = addUnhashedSubs (listToUnhashedSubs []) withHashed - in first - renderSignError - (signDataWithEd25519V6Builder withUnhashed edSigningKey "test payload") - case runtimeEd25519V6Sha3 of - Left err -> - assertFailure - ("runtime RFC9580 SHA3-256 v6 builder should succeed, got " ++ err) - Right (SigV6 BinarySig PKA.Ed25519 SHA3_256 salt _ _ _ _) -> - assertEqual - "runtime RFC9580 SHA3-256 v6 builder should preserve 16-byte salt" - 16 - (BL.length (unSignatureSalt salt)) - Right other -> - assertFailure - ("runtime RFC9580 SHA3-256 v6 builder should produce Ed25519 SigV6 SHA3_256, got " ++ - show other) - -testLegalSubpacketBuilders :: Assertion -testLegalSubpacketBuilders = do - (signer, signingKey) <- loadUnencryptedRsaSigner - issuerKeyId <- - case eightOctetKeyID signer of - Left err -> - assertFailure ("failed to derive issuer key id for legal-subpacket builder test: " ++ err) >> - fail "expected issuer key id" - Right i -> pure i - - let signerFp = fingerprint signer - creation = ThirtyTwoBitTimeStamp 1 - v4Builder = sigBuilderInit @'PKA.RSA BinarySig SHA512 - v4WithHashed = - addHashedSubs - (listToLegalSubs [LegalSigCreationTime creation, LegalIssuerFingerprintV4 signerFp]) - v4Builder - v4Final = addUnhashedSubs (listToLegalSubs [LegalIssuerV4 issuerKeyId]) v4WithHashed - - case signDataWithRSABuilder v4Final signingKey "typed legal subpacket payload" of - Left err -> - assertFailure ("v4 legal-subpacket builder failed: " ++ renderSignError err) - Right (SigV4 _ _ _ hashed unhashed _ _) -> do - assertBool - "v4 legal-subpacket builder should include creation time in hashed subpackets" - (SigSubPacket False (SigCreationTime creation) `elem` hashed) - assertBool - "v4 legal-subpacket builder should include v4 issuer fingerprint in hashed subpackets" - (SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 signerFp) `elem` hashed) - assertBool - "v4 legal-subpacket builder should include issuer key ID only in unhashed subpackets" - (SigSubPacket False (Issuer issuerKeyId) `elem` unhashed) - Right other -> - assertFailure ("v4 legal-subpacket builder should generate SigV4, got " ++ show other) - - (_, edSigningKey) <- loadDeterministicEd25519Signer - let v6Salt = SignatureSalt (BL.replicate 32 0x17) - v6Builder = sigBuilderInitV6 @'PKA.Ed25519 BinarySig SHA512 v6Salt - v6WithHashed = - addHashedSubs - (listToLegalSubs [LegalSigCreationTime creation, LegalIssuerFingerprintV6 signerFp]) - v6Builder - v6Final = addUnhashedSubs (listToLegalSubs []) v6WithHashed - - case signDataWithEd25519V6Builder v6Final edSigningKey "typed legal subpacket payload" of - Left err -> - assertFailure ("v6 legal-subpacket builder failed: " ++ renderSignError err) - Right (SigV6 _ _ _ _ hashed unhashed _ _) -> do - assertBool - "v6 legal-subpacket builder should include creation time in hashed subpackets" - (SigSubPacket False (SigCreationTime creation) `elem` hashed) - assertBool - "v6 legal-subpacket builder should include v6 issuer fingerprint in hashed subpackets" - (SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 signerFp) `elem` hashed) - assertEqual - "v6 legal-subpacket builder should keep unhashed set empty for typed legal set used here" - [] - unhashed - Right other -> - assertFailure ("v6 legal-subpacket builder should generate SigV6, got " ++ show other) - -testTemporaryKeyValidityRespectsLatestSelfSignature :: Assertion -testTemporaryKeyValidityRespectsLatestSelfSignature = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let uidText = "temporary-validity@example.org" - uid = UserId uidText - keyCreated = _timestamp signer - longValidityCertTime = addTimestampSeconds keyCreated 10 - temporaryValidityCertTime = addTimestampSeconds keyCreated 20 - validCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) - expiredCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 200) - preExpirySignatureTime = addTimestampSeconds keyCreated 25 - postExpirySignatureTime = addTimestampSeconds keyCreated 40 - payload = "temporary validity signer timeline payload" - longValidityCert <- - signCertificationAt - signer - signingKey - uid - longValidityCertTime - [SigSubPacket False (KeyExpirationTime 1000)] - temporaryValidityCert <- - signCertificationAt - signer - signingKey - uid - temporaryValidityCertTime - [SigSubPacket False (KeyExpirationTime 30)] - preExpirySignature <- - signBinaryMessageWithRSAAt signer signingKey preExpirySignatureTime payload - postExpirySignature <- - signBinaryMessageWithRSAAt signer signingKey postExpirySignatureTime payload - let tk = TKUnknown (signer, Nothing) [] [(uidText, [longValidityCert, temporaryValidityCert])] [] [] - keyring = mkTestKeyring [tk] - assertBool - "latest effective self-signature should keep key valid before temporary expiration" - (isTKTimeValid validCheckTime tk) - assertBool - "latest effective self-signature should expire key at the temporary validity boundary" - (not (isTKTimeValid expiredCheckTime tk)) - assertSingleSignerFingerprint - "pre-expiry signatures should still verify" - (fingerprint signer) - (verifyTimelinePackets keyring payload preExpirySignature) - assertSingleFailureContainsTimeline - "post-expiry signatures should be rejected" - "signing key was not valid at the signature creation time" - (verifyTimelinePackets keyring payload postExpirySignature) - -testTemporaryKeyValidityRejectsSelfSignatureGaps :: Assertion -testTemporaryKeyValidityRejectsSelfSignatureGaps = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let uidText = "temporary-validity-gap@example.org" - uid = UserId uidText - keyCreated = _timestamp signer - firstCertTime = addTimestampSeconds keyCreated 10 - secondCertTime = addTimestampSeconds keyCreated 30 - gapCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) - renewedCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 35) - gapSignatureTime = addTimestampSeconds keyCreated 25 - renewedSignatureTime = addTimestampSeconds keyCreated 35 - payload = "temporary validity gap signer timeline payload" - firstCertification <- - signCertificationAt - signer - signingKey - uid - firstCertTime - [ SigSubPacket False (KeyExpirationTime 1000) - , SigSubPacket False (SigExpirationTime 10) - ] - secondCertification <- - signCertificationAt - signer - signingKey - uid - secondCertTime - [SigSubPacket False (KeyExpirationTime 1000)] - gapSignature <- - signBinaryMessageWithRSAAt signer signingKey gapSignatureTime payload - renewedSignature <- - signBinaryMessageWithRSAAt signer signingKey renewedSignatureTime payload - let tk = TKUnknown (signer, Nothing) [] [(uidText, [firstCertification, secondCertification])] [] [] - keyring = mkTestKeyring [tk] - assertBool - "a gap with no effective self-signature should make the key temporarily invalid" - (not (isTKTimeValid gapCheckTime tk)) - assertBool - "a later self-signature should restore validity once it becomes effective" - (isTKTimeValid renewedCheckTime tk) - assertSingleFailureContainsTimeline - "signatures made during a self-signature gap should be rejected" - "signing key was not valid at the signature creation time" - (verifyTimelinePackets keyring payload gapSignature) - assertSingleSignerFingerprint - "signatures made after a later self-signature becomes effective should verify" - (fingerprint signer) - (verifyTimelinePackets keyring payload renewedSignature) - -testTemporaryKeyValidityRejectsPreCertificationGap :: Assertion -testTemporaryKeyValidityRejectsPreCertificationGap = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let uidText = "temporary-validity-pre-cert-gap@example.org" - uid = UserId uidText - keyCreated = _timestamp signer - certificationTime = addTimestampSeconds keyCreated 20 - invalidCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 10) - validCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) - invalidSignatureTime = addTimestampSeconds keyCreated 10 - validSignatureTime = addTimestampSeconds keyCreated 25 - payload = "temporary validity pre-certification gap signer timeline payload" - certification <- - signCertificationAt - signer - signingKey - uid - certificationTime - [SigSubPacket False (KeyExpirationTime 1000)] - invalidSignature <- - signBinaryMessageWithRSAAt signer signingKey invalidSignatureTime payload - validSignature <- - signBinaryMessageWithRSAAt signer signingKey validSignatureTime payload - let tk = TKUnknown (signer, Nothing) [] [(uidText, [certification])] [] [] - keyring = mkTestKeyring [tk] - assertBool - "a key should be invalid before its first self-signature becomes effective" - (not (isTKTimeValid invalidCheckTime tk)) - assertBool - "a key should become valid once its first self-signature becomes effective" - (isTKTimeValid validCheckTime tk) - assertSingleFailureContainsTimeline - "signatures made before the first self-signature should be rejected" - "signing key was not valid at the signature creation time" - (verifyTimelinePackets keyring payload invalidSignature) - assertSingleSignerFingerprint - "signatures made after the first self-signature becomes effective should verify" - (fingerprint signer) - (verifyTimelinePackets keyring payload validSignature) - -testTemporaryKeyValidityFollowsTemporarySelfRevocation :: Assertion -testTemporaryKeyValidityFollowsTemporarySelfRevocation = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let uidText = "temporary-validity-self-revocation@example.org" - uid = UserId uidText - keyCreated = _timestamp signer - certificationTime = addTimestampSeconds keyCreated 10 - revocationTime = addTimestampSeconds keyCreated 20 - revokedCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) - restoredCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 35) - revokedSignatureTime = addTimestampSeconds keyCreated 25 - restoredSignatureTime = addTimestampSeconds keyCreated 35 - payload = "temporary validity self-revocation signer timeline payload" - certification <- - signCertificationAt - signer - signingKey - uid - certificationTime - [SigSubPacket False (KeyExpirationTime 1000)] - temporaryRevocation <- - signCertificationRevocationAt - signer - signingKey - uid - revocationTime - [SigSubPacket False (SigExpirationTime 10)] - revokedSignature <- - signBinaryMessageWithRSAAt signer signingKey revokedSignatureTime payload - restoredSignature <- - signBinaryMessageWithRSAAt signer signingKey restoredSignatureTime payload - let tk = TKUnknown (signer, Nothing) [] [(uidText, [certification, temporaryRevocation])] [] [] - keyring = mkTestKeyring [tk] - assertBool - "a temporary self-revocation should disable signing while it is effective" - (not (isTKTimeValid revokedCheckTime tk)) - assertBool - "a self-certification should become valid again once its temporary revocation expires" - (isTKTimeValid restoredCheckTime tk) - assertSingleFailureContainsTimeline - "signatures made during a temporary self-revocation should be rejected" - "signing key was not valid at the signature creation time" - (verifyTimelinePackets keyring payload revokedSignature) - assertSingleSignerFingerprint - "signatures made after a temporary self-revocation expires should verify" - (fingerprint signer) - (verifyTimelinePackets keyring payload restoredSignature) - -testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures :: Assertion -testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let uidText = "temporary-validity-no-revival@example.org" - uid = UserId uidText - keyCreated = _timestamp signer - firstCertTime = addTimestampSeconds keyCreated 10 - secondCertTime = addTimestampSeconds keyCreated 20 - invalidCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 30) - invalidSignatureTime = addTimestampSeconds keyCreated 30 - payload = "temporary validity no revival signer timeline payload" - firstCertification <- - signCertificationAt - signer - signingKey - uid - firstCertTime - [SigSubPacket False (KeyExpirationTime 1000)] - secondCertification <- - signCertificationAt - signer - signingKey - uid - secondCertTime - [ SigSubPacket False (KeyExpirationTime 1000) - , SigSubPacket False (SigExpirationTime 5) - ] - invalidSignature <- - signBinaryMessageWithRSAAt signer signingKey invalidSignatureTime payload - let tk = TKUnknown (signer, Nothing) [] [(uidText, [firstCertification, secondCertification])] [] [] - keyring = mkTestKeyring [tk] - assertBool - "an expired newer self-signature should not revive an older certification" - (not (isTKTimeValid invalidCheckTime tk)) - assertSingleFailureContainsTimeline - "signatures after a newer self-signature expires should be rejected until re-certified" - "signing key was not valid at the signature creation time" - (verifyTimelinePackets keyring payload invalidSignature) - -testUidRetiredRevocationIsHistorical :: Assertion -testUidRetiredRevocationIsHistorical = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let uidText = "retired-uid@example.org" - uid = UserId uidText - keyCreated = _timestamp signer - certificationTime = addTimestampSeconds keyCreated 10 - revocationTime = addTimestampSeconds keyCreated 20 - certification <- - signCertificationAt signer signingKey uid certificationTime [] - retirementRevocation <- - signCertificationRevocationAt - signer - signingKey - uid - revocationTime - [SigSubPacket False (ReasonForRevocation UserIdInfoNoLongerValid "")] - let tk = TKUnknown (signer, Nothing) [] [(uidText, [certification, retirementRevocation])] [] [] - verifyAt ts = - verifyUnknownTKWith - (verifySigWith (verifyAgainstKeys [tk])) - (Just (timestampToUTCTime ts)) - tk - beforeRetirement <- - case verifyAt (addTimestampSeconds keyCreated 15) of - Left err -> - assertFailure - ("uid-retired pre-revocation verification failed: " ++ renderVerificationError err) >> - fail "expected verified transferable key before uid retirement" - Right verifiedTK -> pure verifiedTK - afterRetirement <- - case verifyAt (addTimestampSeconds keyCreated 25) of - Left err -> - assertFailure - ("uid-retired post-revocation verification failed: " ++ renderVerificationError err) >> - fail "expected verified transferable key after uid retirement" - Right verifiedTK -> pure verifiedTK - assertEqual - "uid-retired revocation should preserve the UID before it becomes effective" - 1 - (length (_tkuUIDs beforeRetirement)) - assertEqual - "uid-retired revocation should retire the UID once effective" - 0 - (length (_tkuUIDs afterRetirement)) - -testThirdPartyCertificationDoesNotAffectKeyValidityWindow :: Assertion -testThirdPartyCertificationDoesNotAffectKeyValidityWindow = do - (targetSigner, _) <- loadUnencryptedRsaSigner - (thirdPartySigner, thirdPartySigningKey) <- loadDeterministicEd25519Signer - let uidText = "third-party-validity@example.org" - uid = UserId uidText - keyCreated = _timestamp targetSigner - certificationTime = addTimestampSeconds keyCreated 10 - validityCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 200) - thirdPartyCertification <- - signCertificationWithEd25519At - targetSigner - thirdPartySigner - thirdPartySigningKey - uid - certificationTime - [SigSubPacket False (KeyExpirationTime 30)] - let targetTK = TKUnknown (targetSigner, Nothing) [] [(uidText, [thirdPartyCertification])] [] [] - certifierTK = TKUnknown (thirdPartySigner, Nothing) [] [] [] [] - verifyAt = - verifyUnknownTKWith - (verifySigWith (verifyAgainstKeys [targetTK, certifierTK])) - (Just validityCheckTime) - targetTK - verifiedTK <- - case verifyAt of - Left err -> - assertFailure - ("third-party certification verification failed: " ++ renderVerificationError err) >> - fail "expected verified transferable key" - Right tk -> pure tk - assertBool - "third-party certifications must not define the primary key validity window" - (isTKTimeValid validityCheckTime verifiedTK) - -testCertificationRevocationOnlyRemovesMatchingSigner :: Assertion -testCertificationRevocationOnlyRemovesMatchingSigner = do - (targetSigner, targetSigningKey) <- loadUnencryptedRsaSigner - (thirdPartySigner, thirdPartySigningKey) <- loadDeterministicEd25519Signer - let uidText = "cert-revocation-scope@example.org" - uid = UserId uidText - keyCreated = _timestamp targetSigner - selfCertificationTime = addTimestampSeconds keyCreated 10 - thirdPartyCertificationTime = addTimestampSeconds keyCreated 12 - thirdPartyRevocationTime = addTimestampSeconds keyCreated 20 - beforeRevocationTime = timestampToUTCTime (addTimestampSeconds keyCreated 15) - afterRevocationTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) - selfCertification <- - signCertificationAt targetSigner targetSigningKey uid selfCertificationTime [] - thirdPartyCertification <- - signCertificationWithEd25519At - targetSigner - thirdPartySigner - thirdPartySigningKey - uid - thirdPartyCertificationTime - [] - thirdPartyRevocation <- - signCertificationRevocationWithEd25519At - targetSigner - thirdPartySigner - thirdPartySigningKey - uid - thirdPartyRevocationTime - [] - let targetTK = - TKUnknown - (targetSigner, Nothing) - [] - [(uidText, [selfCertification, thirdPartyCertification, thirdPartyRevocation])] - [] - [] - certifierTK = TKUnknown (thirdPartySigner, Nothing) [] [] [] [] - verifyAt ts = - verifyUnknownTKWith - (verifySigWith (verifyAgainstKeys [targetTK, certifierTK])) - (Just ts) - targetTK - beforeRevocation <- - case verifyAt beforeRevocationTime of - Left err -> - assertFailure - ("pre-revocation certification verification failed: " ++ renderVerificationError err) >> - fail "expected verified transferable key before certification revocation" - Right tk -> pure tk - afterRevocation <- - case verifyAt afterRevocationTime of - Left err -> - assertFailure - ("post-revocation certification verification failed: " ++ renderVerificationError err) >> - fail "expected verified transferable key after certification revocation" - Right tk -> pure tk - let beforeSigs = maybe [] snd (find ((== uidText) . fst) (_tkuUIDs beforeRevocation)) - afterSigs = maybe [] snd (find ((== uidText) . fst) (_tkuUIDs afterRevocation)) - assertEqual - "certification revocations should not apply before they become effective" - [selfCertification, thirdPartyCertification] - beforeSigs - assertEqual - "a certification revocation should remove only certifications from the same signer" - [selfCertification] - afterSigs - -testPreferencesAtTimestamp :: Assertion -testPreferencesAtTimestamp = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let uid = UserId "prefs@example.org" - UserId uidText = uid - t1 = addTimestampSeconds (_timestamp signer) 1 - t2 = addTimestampSeconds t1 100 - t3 = addTimestampSeconds t2 100 - queryDuring = addTimestampSeconds t2 1 - queryAfterRevocation = addTimestampSeconds t3 1 - - initialCertification <- - signCertificationAt - signer - signingKey - uid - t1 - [SigSubPacket False (PreferredHashAlgorithms [SHA256])] - updatedCertification <- - signCertificationAt - signer - signingKey - uid - t2 - [SigSubPacket False (PreferredHashAlgorithms [SHA512])] - certificationRevocation <- - signCertificationRevocationAt signer signingKey uid t3 [] - - let tk = - TKUnknown - (signer, Nothing) - [] - [(uidText, [initialCertification, updatedCertification, certificationRevocation])] - [] - [] - - assertEqual - "key preferences at timestamp should use the latest active self-certification" - (Just [PreferredHashAlgorithms [SHA512]]) - (effectiveKeyPreferencesAtTimestamp queryDuring tk) - assertEqual - "UID preferences at timestamp should use the latest active self-certification" - (Just [PreferredHashAlgorithms [SHA512]]) - (effectiveUIDPreferencesAtTimestamp queryDuring uidText tk) - assertEqual - "revoked UID certifications should not provide effective UID preferences" - Nothing - (effectiveUIDPreferencesAtTimestamp queryAfterRevocation uidText tk) - assertEqual - "key preferences should become unavailable when no active self-certification remains" - Nothing - (effectiveKeyPreferencesAtTimestamp queryAfterRevocation tk) - -testChangePrivateKeyPassphraseLegacy :: Assertion -testChangePrivateKeyPassphraseLegacy = do - passphrase <- readPKIPassphrase - packets <- - DC.runConduitRes $ - CB.sourceFile "tests/data/aes256-sha512.seckey" DC..| conduitGet get DC..| - CL.consume - (pkp, ska) <- - case packets of - (SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum) - _ -> - assertFailure "aes256-sha512.seckey did not begin with a secret key packet" >> - fail "expected secret key packet" - originalDecrypted <- - case decryptPrivateKey (pkp, ska) passphrase of - Left err -> - assertFailure ("decrypting original legacy key failed: " ++ err) >> - fail "decrypting original legacy key failed" - Right x -> pure x - originalSKey <- - case originalDecrypted of - SUUnencrypted skey _ -> pure skey - _ -> - assertFailure "original legacy key should decrypt to unencrypted secret material" >> - fail "expected unencrypted secret key" - changed <- - case - changePrivateKeyPassphrase - (pkp, ska) - passphrase - (Salt "12345678") - (IV "1234567890ABCDEF") - "changed-pki-password" of - Left err -> - assertFailure - ("legacy passphrase change should preserve the existing protection envelope, got: " ++ - err) >> - fail "legacy passphrase change failed" - Right skaddendum -> pure skaddendum - originalIterCount <- - case ska of - SUSSHA1 AES256 (IteratedSalted SHA512 _ iter) _ _ -> pure iter - _ -> - assertFailure - "legacy key fixture should use SUSSHA1/AES256/IteratedSalted SHA512" >> - fail "expected legacy key fixture" - case changed of - SUSSHA1 AES256 (IteratedSalted SHA512 _ iter) _ encryptedPayload -> do - assertEqual - "legacy passphrase change should preserve the S2K iteration count" - originalIterCount - iter - assertBool - "legacy passphrase change should emit encrypted payload" - (not (BL.null encryptedPayload)) - _ -> - assertFailure - "legacy passphrase change should preserve the SUSSHA1/AES256 envelope" - decrypted <- - case decryptPrivateKey (pkp, changed) "changed-pki-password" of - Left err -> - assertFailure ("re-decrypting changed legacy key failed: " ++ err) >> - fail "re-decrypting changed legacy key failed" - Right x -> pure x - case decrypted of - SUUnencrypted skey _ -> - assertEqual - "legacy passphrase change should preserve secret key material" - originalSKey - skey - _ -> - assertFailure - "legacy passphrase change should decrypt back to unencrypted secret material" - -testChangePrivateKeyPassphraseV6 :: Assertion -testChangePrivateKeyPassphraseV6 = do - oldPassphrase <- readPKIPassphrase - armors <- loadArmor "v6-encrypted-secret.pgp.aa" - armor <- - case armors of - (a:_) -> pure a - [] -> - assertFailure "v6-encrypted-secret.pgp.aa should contain one armored payload" >> - fail "expected one armored payload" - let packets = parsePkts (armorPayload armor) - (pkp, ska) <- - case packets of - (SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum) - _ -> - assertFailure "v6-encrypted-secret.pgp.aa did not begin with a secret key packet" >> - fail "expected secret key packet" - let newPassphrase = "changed-pki-password" - originalDecrypted <- - case decryptPrivateKey (pkp, ska) oldPassphrase of - Left err -> - assertFailure ("decrypting original v6 key failed: " ++ err) >> - fail "decrypting original v6 key failed" - Right x -> pure x - originalSKey <- - case originalDecrypted of - SUUnencrypted skey _ -> pure skey - _ -> - assertFailure "original v6 key should decrypt to unencrypted secret material" >> - fail "expected unencrypted secret key" - let changedResult = - changePrivateKeyPassphrase - (pkp, ska) - oldPassphrase - (Salt "1234567890ABCDEF") - (IV "1234567890ABCDE") - newPassphrase - changed <- - case changedResult of - Left err -> - assertFailure ("changing v6 key passphrase failed: " ++ err) >> pure ska - Right skaddendum -> pure skaddendum - case changed of - SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do - assertEqual - "changed v6 key addendum should use expected Argon2 t parameter" - 1 - t - assertEqual - "changed v6 key addendum should use expected Argon2 p parameter" - 4 - p - assertEqual - "changed v6 key addendum should use expected Argon2 encoded memory parameter" - 15 - em - assertBool - "changed v6 key addendum should contain encrypted key material" - (not (BL.null encryptedPayload)) - _ -> assertFailure "changed v6 key addendum should be encrypted with SUSAEAD" - let decryptedResult = decryptPrivateKey (pkp, changed) newPassphrase - decrypted <- - case decryptedResult of - Left err -> - assertFailure ("decryption with changed v6 passphrase failed: " ++ err) >> - fail "decryption with changed v6 passphrase failed" - Right x -> pure x - case decrypted of - SUUnencrypted skey _ -> - assertEqual - "changing a v6 key passphrase should preserve secret key material" - originalSKey - skey - _ -> assertFailure "changed v6 key should decrypt with the new passphrase" - -testPolicySignatureContextValidation :: Assertion -testPolicySignatureContextValidation = do - let pkSigV4PK = SigV4 KeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| []) - pkSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| []) - pkSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) - pkSigV6PK = - SigV6 - KeyRevocationSig - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x11)) - [] - [] - 0 - (MPI 0 :| []) - pkSigV6Direct = - SigV6 - SignatureDirectlyOnAKey - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x12)) - [] - [] - 0 - (MPI 0 :| []) - pkSigV6Binding = - SigV6 - SubkeyBindingSig - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x13)) - [] - [] - 0 - (MPI 0 :| []) - skSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) - skSigV4Revocation = SigV4 SubkeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| []) - skSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| []) - skSigV6Binding = - SigV6 - SubkeyBindingSig - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x14)) - [] - [] - 0 - (MPI 0 :| []) - skSigV6Revocation = - SigV6 - SubkeyRevocationSig - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x15)) - [] - [] - 0 - (MPI 0 :| []) - skSigV6Direct = - SigV6 - SignatureDirectlyOnAKey - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x16)) - [] - [] - 0 - (MPI 0 :| []) - uidSigV4Generic = SigV4 GenericCert RSA SHA512 [] [] 0 (MPI 0 :| []) - uidSigV4Persona = SigV4 PersonaCert RSA SHA512 [] [] 0 (MPI 0 :| []) - uidSigV4Casual = SigV4 CasualCert RSA SHA512 [] [] 0 (MPI 0 :| []) - uidSigV4Positive = SigV4 PositiveCert RSA SHA512 [] [] 0 (MPI 0 :| []) - uidSigV4CertRev = SigV4 CertRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| []) - uidSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) - uidSigV6Generic = - SigV6 - GenericCert - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x17)) - [] - [] - 0 - (MPI 0 :| []) - uidSigV6Persona = - SigV6 - PersonaCert - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x18)) - [] - [] - 0 - (MPI 0 :| []) - uidSigV6Casual = - SigV6 - CasualCert - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x19)) - [] - [] - 0 - (MPI 0 :| []) - uidSigV6Positive = - SigV6 - PositiveCert - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x1a)) - [] - [] - 0 - (MPI 0 :| []) - uidSigV6CertRev = - SigV6 - CertRevocationSig - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x1b)) - [] - [] - 0 - (MPI 0 :| []) - uidSigV6Binding = - SigV6 - SubkeyBindingSig - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x1c)) - [] - [] - 0 - (MPI 0 :| []) - assertTrue "KeyRevocationSig allowed on primary key" (isAllowedPrimaryKeySig pkSigV4PK) - assertTrue "SignatureDirectlyOnAKey allowed on primary key" (isAllowedPrimaryKeySig pkSigV4Direct) - assertFalse "SubkeyBindingSig not allowed on primary key" (isAllowedPrimaryKeySig pkSigV4Binding) - assertTrue "v6 KeyRevocationSig allowed on primary key" (isAllowedPrimaryKeySig pkSigV6PK) - assertTrue "v6 SignatureDirectlyOnAKey allowed on primary key" (isAllowedPrimaryKeySig pkSigV6Direct) - assertFalse "v6 SubkeyBindingSig not allowed on primary key" (isAllowedPrimaryKeySig pkSigV6Binding) - assertTrue "SubkeyBindingSig allowed on subkey" (isAllowedSubkeySig skSigV4Binding) - assertTrue "SubkeyRevocationSig allowed on subkey" (isAllowedSubkeySig skSigV4Revocation) - assertFalse "SignatureDirectlyOnAKey not allowed on subkey" (isAllowedSubkeySig skSigV4Direct) - assertTrue "v6 SubkeyBindingSig allowed on subkey" (isAllowedSubkeySig skSigV6Binding) - assertTrue "v6 SubkeyRevocationSig allowed on subkey" (isAllowedSubkeySig skSigV6Revocation) - assertFalse "v6 SignatureDirectlyOnAKey not allowed on subkey" (isAllowedSubkeySig skSigV6Direct) - assertTrue "GenericCert allowed on UID" (isAllowedUIDSig uidSigV4Generic) - assertTrue "PersonaCert allowed on UID" (isAllowedUIDSig uidSigV4Persona) - assertTrue "CasualCert allowed on UID" (isAllowedUIDSig uidSigV4Casual) - assertTrue "PositiveCert allowed on UID" (isAllowedUIDSig uidSigV4Positive) - assertTrue "CertRevocationSig allowed on UID" (isAllowedUIDSig uidSigV4CertRev) - assertFalse "SubkeyBindingSig not allowed on UID" (isAllowedUIDSig uidSigV4Binding) - assertTrue "v6 GenericCert allowed on UID" (isAllowedUIDSig uidSigV6Generic) - assertTrue "v6 PersonaCert allowed on UID" (isAllowedUIDSig uidSigV6Persona) - assertTrue "v6 CasualCert allowed on UID" (isAllowedUIDSig uidSigV6Casual) - assertTrue "v6 PositiveCert allowed on UID" (isAllowedUIDSig uidSigV6Positive) - assertTrue "v6 CertRevocationSig allowed on UID" (isAllowedUIDSig uidSigV6CertRev) - assertFalse "v6 SubkeyBindingSig not allowed on UID" (isAllowedUIDSig uidSigV6Binding) - -testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID :: Assertion -testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID = do - (signer, _) <- loadUnencryptedRsaSigner - issuerKeyId <- - case eightOctetKeyID signer of - Left err -> - assertFailure ("failed to derive RSA issuer key id: " ++ err) >> - fail "expected issuer key id" - Right i -> pure i - let sigPayload = - SigV6 - KeyRevocationSig - RSA - SHA256 - (SignatureSalt (BL.replicate 16 0)) - [SigSubPacket False (Issuer issuerKeyId)] - [] - 0 - (MPI 0 :| []) - verifyFn _ _ _ = Right (Verification signer sigPayload []) - result = - verifySigWith - verifyFn - (SignaturePkt sigPayload) - emptyPSC {lastPrimaryKey = PublicKeyPkt signer} - Nothing - case result of - Left err -> - assertBool - "v6 revocation verification should reject legacy Issuer key-id subpackets" - ("Issuer Key ID subpacket is prohibited in v6 signatures" `isInfixOf` - renderVerificationError err) - Right _ -> - assertFailure - "Expected v6 revocation verification to reject legacy Issuer key-id subpacket" - -testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed :: Assertion -testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed = do - (signer, _) <- loadUnencryptedRsaSigner - issuerKeyId <- - case eightOctetKeyID signer of - Left err -> - assertFailure ("failed to derive RSA issuer key id: " ++ err) >> - fail "expected issuer key id" - Right i -> pure i - let sigPayload = - SigV6 - KeyRevocationSig - RSA - SHA256 - (SignatureSalt (BL.replicate 16 0)) - [] - [SigSubPacket False (Issuer issuerKeyId)] - 0 - (MPI 0 :| []) - verifyFn _ _ _ = Right (Verification signer sigPayload []) - result = - verifySigWith - verifyFn - (SignaturePkt sigPayload) - emptyPSC {lastPrimaryKey = PublicKeyPkt signer} - Nothing - case result of - Left err -> - assertBool - "v6 revocation verification should reject legacy Issuer key-id subpackets in unhashed area" - ("Issuer Key ID subpacket is prohibited in v6 signatures" `isInfixOf` - renderVerificationError err) - Right _ -> - assertFailure - "Expected v6 revocation verification to reject legacy Issuer key-id subpacket in unhashed area" - -testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint :: Assertion -testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint = do - (signer, _) <- loadUnencryptedRsaSigner - let sigPayload = - SigV6 - KeyRevocationSig - RSA - SHA256 - (SignatureSalt (BL.replicate 16 0)) - [SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 (fingerprint signer))] - [] - 0 - (MPI 0 :| []) - verifyFn _ _ _ = Right (Verification signer sigPayload []) - result = - verifySigWith - verifyFn - (SignaturePkt sigPayload) - emptyPSC {lastPrimaryKey = PublicKeyPkt signer} - Nothing - case result of - Left err -> - assertFailure - ("Expected matching IssuerFingerprint to verify for v6 revocation signature, got: " ++ - renderVerificationError err) - Right _ -> pure () - -testV6SignerConstructorRejectsV4Key :: Assertion -testV6SignerConstructorRejectsV4Key = do - (signer, signingKey) <- loadDeterministicEd25519Signer - case asV6PKPayload signer of - Left _ -> pure () - Right signerV6 -> - seq (mkEd25519SignerV6 signerV6 signingKey) $ - assertFailure "asV6PKPayload should reject v4 Ed25519 key payloads" - (rsaSigner, rsaSigningKey) <- loadUnencryptedRsaSigner - case asV6PKPayload rsaSigner of - Left _ -> pure () - Right signerV6 -> - seq (mkRSASignerV6 signerV6 rsaSigningKey) $ - assertFailure "asV6PKPayload should reject v4 RSA key payloads" - -testGetSecretKeyHandlesV4X25519ECDHPubkey :: Assertion -testGetSecretKeyHandlesV4X25519ECDHPubkey = do - let pkp = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - X25519 - (ECDHPubKey - (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01)))))) - SHA256 - AES128) - encodedSecret = runPut (put (MPI 42)) - case runGetOrFail (getSecretKey pkp) encodedSecret of - Left (_, _, err) -> - assertFailure ("getSecretKey should parse v4 X25519 secret key material: " ++ err) - Right (_, _, ECDHPrivateKey (ECDSA_PrivateKey prv)) -> - assertEqual - "getSecretKey should preserve X25519 private scalar" - 42 - (ECDSA.private_d prv) - Right (_, _, other) -> - assertFailure ("unexpected parsed secret key type: " ++ show other) - -testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte :: Assertion -testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte = do - let secretBytes = B.pack (0 : replicate 31 1) - pkt = - SecretKeyPkt - (PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - EdDSA - (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01))))))) - (SUUnencrypted (EdDSAPrivateKey Ed25519 secretBytes) 0) - case runGetOrFail (get :: Get Pkt) (runPut (put pkt)) of - Left (_, _, err) -> - assertFailure ("v4 Ed25519 secret key should round-trip: " ++ err) - Right (_, _, parsedPkt) -> - case parsedPkt of - SecretKeyPkt _ (SUUnencrypted (EdDSAPrivateKey Ed25519 parsedBytes) _) -> - assertEqual - "v4 Ed25519 secret-key round-trip should preserve MPI-encoded bytes" - secretBytes - parsedBytes - _ -> - assertFailure ("unexpected parsed packet shape: " ++ show parsedPkt) - -testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte :: Assertion -testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte = do - let secretBytes = B.pack (0 : replicate 56 2) - pkp = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - EdDSA - (EdDSAPubKey Ed448 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 57 0x02)))))) - encodedSecret = runPut (put (MPI (os2ip secretBytes))) - case runGetOrFail (getSecretKey pkp) encodedSecret of - Left (_, _, err) -> - assertFailure ("v4 Ed448 secret key should parse with preserved padding: " ++ err) - Right (_, _, parsedSecret) -> - assertEqual - "v4 Ed448 secret-key parsing should restore the curve-width byte string" - (EdDSAPrivateKey Ed448 secretBytes) - parsedSecret - -testMkUnencryptedSKAddendumComputesLegacyChecksum :: Assertion -testMkUnencryptedSKAddendumComputesLegacyChecksum = do - packets <- - DC.runConduitRes $ - CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| CL.consume - case packets of - (SecretKeyPkt pkp (SUUnencrypted sk _):_) -> - case mkUnencryptedSKAddendum pkp sk of - Left err -> - assertFailure ("mkUnencryptedSKAddendum should succeed for fixture key: " ++ err) - Right (SUUnencrypted _ actualChecksum) -> do - skPayload <- - case putSKeyForPKPayload pkp sk of - Left err -> - assertFailure ("failed to serialize secret key payload for checksum expectation: " ++ err) >> - fail "expected serializable secret key payload" - Right payload -> pure payload - let expectedChecksum = - fromIntegral - (BL.foldl' - (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) - 0 - (runPut skPayload) :: Integer) - assertEqual - "mkUnencryptedSKAddendum should use OpenPGP 16-bit checksum over serialized key material" - expectedChecksum - actualChecksum - Right other -> - assertFailure ("unexpected addendum constructor: " ++ show other) - _ -> - assertFailure "unencrypted.seckey did not begin with an unencrypted secret key packet" - -testMkUnencryptedSKAddendumUsesV6ChecksumConvention :: Assertion -testMkUnencryptedSKAddendumUsesV6ChecksumConvention = do - (pkp, rsaPrivateKey) <- loadUnencryptedRsaSignerV6 - case mkUnencryptedSKAddendum pkp (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) of - Left err -> - assertFailure ("mkUnencryptedSKAddendum should support v6 key payloads: " ++ err) - Right (SUUnencrypted _ checksum) -> - assertEqual "v6 unencrypted addendum checksum should be zero" 0 checksum - Right other -> - assertFailure ("unexpected addendum constructor: " ++ show other) - -testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA :: Assertion -testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA = do - let secretBytes = B.pack (0 : replicate 31 1) - pkp = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - EdDSA - (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01)))))) - unknown = UnknownSKey (runPut (put (MPI (os2ip secretBytes)))) - case reinterpretUnknownSKeyForPKPayload pkp unknown of - Left err -> - assertFailure ("reinterpretUnknownSKeyForPKPayload should decode Ed25519 key: " ++ err) - Right skey -> - assertEqual - "reinterpretUnknownSKeyForPKPayload should return typed EdDSA secret key" - (EdDSAPrivateKey Ed25519 secretBytes) - skey - -testFromPrimaryKeyPktToTKUnknownRejectsSubkey :: Assertion -testFromPrimaryKeyPktToTKUnknownRejectsSubkey = do - packets <- - DC.runConduitRes $ - CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| CL.consume - case packets of - (SecretKeyPkt pkp _ : _) -> - case fromPrimaryKeyPktToTKUnknown (PublicSubkeyPkt pkp) of - Left err -> - assertBool - "fromPrimaryKeyPktToTKUnknown should report non-primary packet tags" - ("expected primary key packet" `isInfixOf` err) - Right _ -> - assertFailure "fromPrimaryKeyPktToTKUnknown should reject subkey packets" - _ -> - assertFailure "unencrypted.seckey did not begin with a secret key packet" +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.Keys (keyAndVerificationTests) where + +import Control.Error.Util (isRight) +import Crypto.Number.Serialize (os2ip) +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import Data.Bifunctor (first) +import Data.Binary (get, put) +import Data.Binary.Get (Get, runGetOrFail) +import Data.Binary.Put (runPut) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Conduit as DC +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.IxSet.Typed (getOne, size, (@=)) +import Data.List (find, isInfixOf) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (isJust) +import qualified Data.Set as Set +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Prettyprinter (pretty) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + ( Assertion + , assertBool + , assertEqual + , assertFailure + , testCase + ) + +import Codec.Encryption.OpenPGP.Expirations + ( effectiveKeyPreferencesAtTimestamp + , effectiveUIDPreferencesAtTimestamp + , isTKTimeValid + ) +import Codec.Encryption.OpenPGP.Fingerprint + ( eightOctetKeyID + , fingerprint + ) +import Codec.Encryption.OpenPGP.Internal + ( emptyPSC + , lastPrimaryKey + , lastSubkey + ) +import Codec.Encryption.OpenPGP.KeyInfo + ( pkalgoAbbrev + , pubkeySize + ) +import Codec.Encryption.OpenPGP.Message + ( asV6PKPayload + , mkEd25519SignerV6 + , mkRSASignerV6 + ) +import Codec.Encryption.OpenPGP.Policy + ( OpenPGPRFC (..) + , defaultVerificationPolicy + , isAllowedPrimaryKeySig + , isAllowedSubkeySig + , isAllowedUIDSig + ) +import Codec.Encryption.OpenPGP.SecretKey + ( changePrivateKeyPassphrase + , decryptPrivateKey + , mkUnencryptedSKAddendum + , reinterpretUnknownSKeyForPKPayload + ) +import Codec.Encryption.OpenPGP.Serialize + ( getSecretKey + , parsePkts + , putSKeyForPKPayload + ) +import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig) +import Codec.Encryption.OpenPGP.Signatures +import Codec.Encryption.OpenPGP.Subpackets + ( LegalSubpacket (..) + , addHashedSubs + , addUnhashedSubs + , listToHashedSubs + , listToLegalSubs + , listToUnhashedSubs + , sigBuilderInit + , sigBuilderInitRuntime + , sigBuilderInitV6 + , sigBuilderInitV6Runtime + ) +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA +import Data.Conduit.OpenPGP.Compression (conduitDecompress) +import Data.Conduit.OpenPGP.Keyring + ( conduitDropErrorsAndNothings + , conduitToTKsEither + ) +import Data.Conduit.OpenPGP.Verify (conduitVerify) +import Tests.Common + ( addTimestampSeconds + , armorPayload + , assertFalse + , assertSingleFailureContainsTimeline + , assertSingleSignerFingerprint + , assertTrue + , certificateVerificationFixtures + , fixturePath + , loadAndDecompressPkts + , loadArmor + , loadDeterministicEd25519Signer + , loadKeyring + , loadUnencryptedRsaSigner + , loadUnencryptedRsaSignerV6 + , messageIssuerSubpacketsAt + , messageVerificationFixtures + , mkTestKeyring + , readFixturePayload + , readPKIPassphrase + , runGet + , setKeyVersion + , signBinaryMessageWithRSAAt + , signCertificationAt + , signCertificationRevocationAt + , signCertificationRevocationWithEd25519At + , signCertificationWithEd25519At + , signSubkeyBindingWithRSAExtrasAt + , timestampToUTCTime + , verificationFixtureGroup + , verifyMessageFromBytestring + , verifyMessageFromBytestringBatch + , verifyMessageFromPackets + , verifyMessageFromPacketsBatch + , verifyTimelinePackets + ) + +keyAndVerificationTests :: TestTree +keyAndVerificationTests = + testGroup + "Keys and verification" + [ testGroup + "PKA/Size/KeyID/fingerprint group" + [ testCase + "v3 key" + ( testPKAandSizeAndKeyIDandFingerprint + "v3.key" + "rsa/1024:6DC580F5C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E" + ) + , testCase + "v4 key" + ( testPKAandSizeAndKeyIDandFingerprint + "000001-006.public_key" + "rsa/1248:D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E" + ) + , testCase + "ECDSA key" + ( testPKAandSizeAndKeyIDandFingerprint + "nist_p-256_key.gpg" + "ecd/256:F7708BADD6063224/174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224" + ) + , testCase + "EdDSA key" + ( testPKAandSizeAndKeyIDandFingerprint + "sample-eddsa.pubkey" + "edd/256:8CFDE12197965A9A/C959 BDBA FA32 A2F8 9A15 3B67 8CFD E121 9796 5A9A" + ) + , testCase + "EdDSA secret key (projected to public key packet)" + ( testPKAandSizeAndKeyIDandFingerprint + "ed25519.secretkey" + "edd/256:B05F9287601D5914/B6FE 0C23 12EB D832 0238 C252 B05F 9287 601D 5914" + ) + , testCase + "v6 secret key (projected to public key packet)" + ( testPKAandSizeAndKeyIDandFingerprint + "v6-secret.pgp.aa" + "e25/256:7106CB6DB27E4FC9/7106 CB6D B27E 4FC9 B050 B02B B316 4DBD 4BBD 7263 D4D2 9E78 A3BB 3BDB B022 2D19" + ) + ] + , testGroup + "Keyring group" + [ testCase + "pubring 7732CF988A63EA86" + (testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True) + , testCase + "pubring 123456789ABCDEF0" + (testKeyringLookup "pubring.gpg" "123456789ABCDEF0" False) + , testCase + "pubsub AD992E9C24399832" + (testKeyringLookup "pubring.gpg" "AD992E9C24399832" True) + , testCase + "secring 7732CF988A63EA86" + (testKeyringLookup "secring.gpg" "7732CF988A63EA86" True) + , testCase + "secring 123456789ABCDEF0" + (testKeyringLookup "secring.gpg" "123456789ABCDEF0" False) + , testCase + "secsub AD992E9C24399832" + (testKeyringLookup "secring.gpg" "AD992E9C24399832" True) + , testCase + "pubring.gpg has 4 keys" + (testKeyringSize "pubring.gpg" 4) + , testCase + "secring.gpg has 4 keys" + (testKeyringSize "secring.gpg" 4) + ] + , verificationFixtureGroup + "Message verification group (packet-based)" + verifyMessageFromPackets + messageVerificationFixtures + , verificationFixtureGroup + "Message verification group (packet-based, batch)" + verifyMessageFromPacketsBatch + messageVerificationFixtures + , verificationFixtureGroup + "Message verification group (bytestring-based)" + verifyMessageFromBytestring + messageVerificationFixtures + , verificationFixtureGroup + "Message verification group (bytestring-based, batch)" + verifyMessageFromBytestringBatch + messageVerificationFixtures + , verificationFixtureGroup + "Certificate verification group (packet-based)" + verifyMessageFromPackets + certificateVerificationFixtures + , verificationFixtureGroup + "Certificate verification group (packet-based, batch)" + verifyMessageFromPacketsBatch + certificateVerificationFixtures + , verificationFixtureGroup + "Certificate verification group (bytestring-based)" + verifyMessageFromBytestring + certificateVerificationFixtures + , verificationFixtureGroup + "Certificate verification group (bytestring-based, batch)" + verifyMessageFromBytestringBatch + certificateVerificationFixtures + , testGroup + "Key verification group" + [ testCase + "6F87040E pubkey" + (testKeysSelfVerification True "6F87040E.pubkey") + , testCase + "revoked pubkey" + (testKeysSelfVerification False "revoked.pubkey") + , testCase + "expired pubkey" + (testKeysSelfVerification True "expired.pubkey") + , testCase + "nist_p-256 pubkey" + (testKeysSelfVerification True "nist_p-256_key.gpg") + , testCase + "ed25519 pubkey" + (testKeysSelfVerification True "ed25519.pubkey") + ] + , testGroup + "Verification error messaging group" + [ testCase + "missing signing key in keyring" + ( testMissingSigningKeyMessage + "ecdsa-key-without-ecdh.pubkey" + "uncompressed-ops-rsa.gpg" + ) + , testCase + "tampered message signature mismatch" + ( testTamperedSignatureMessage + "pubring.gpg" + "uncompressed-ops-rsa.gpg" + ) + , testCase + "revoked certificate reports revocation" + (testRevokedCertificateMessage "revoked.pubkey") + ] + , testGroup + "Key expiration group" + [ testCase + "6F87040E pubkey" + (testKeysExpiration True "6F87040E.pubkey") + , testCase + "expired pubkey" + (testKeysExpiration False "expired.pubkey") + , testCase + "nist_p-256 pubkey" + (testKeysExpiration True "nist_p-256_key.gpg") + , testCase + "ed25519-without-curve25519.pubkey" + (testKeysExpiration True "ed25519-without-curve25519.pubkey") + , testCase + "ed25519.pubkey" + (testKeysExpiration True "ed25519.pubkey") + ] + , testGroup + "misc group" + [ testCase + "conduitVerify processes SigV6 packets" + testConduitVerifyProcessesSigV6 + , testCase "signature builder API (Phase 2)" testSignatureBuilders + , testCase + "typed legal subpacket builder API (P2.1)" + testLegalSubpacketBuilders + , testCase + "legacy secret key passphrase changes preserve protection" + testChangePrivateKeyPassphraseLegacy + , testCase + "change private key passphrase" + testChangePrivateKeyPassphraseV6 + , testCase + "getSecretKey parses v4 X25519 ECDH key material" + testGetSecretKeyHandlesV4X25519ECDHPubkey + , testCase + "v4 Ed25519 secret-key roundtrip preserves leading zero byte" + testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte + , testCase + "v4 Ed448 secret-key roundtrip preserves leading zero byte" + testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte + , testCase + "mkUnencryptedSKAddendum computes legacy secret-key checksum" + testMkUnencryptedSKAddendumComputesLegacyChecksum + , testCase + "mkUnencryptedSKAddendum sets v6 unencrypted checksum to zero" + testMkUnencryptedSKAddendumUsesV6ChecksumConvention + , testCase + "reinterpretUnknownSKeyForPKPayload decodes EdDSA unknown key material" + testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA + , testCase + "fromPrimaryKeyPktToTKUnknown rejects subkey packets" + testFromPrimaryKeyPktToTKUnknownRejectsSubkey + , testCase + "policy signature context validation (RFC9580)" + testPolicySignatureContextValidation + , testCase + "temporary validity uses latest effective self-signature window" + testTemporaryKeyValidityRespectsLatestSelfSignature + , testCase + "temporary validity rejects gaps with no effective self-signature" + testTemporaryKeyValidityRejectsSelfSignatureGaps + , testCase + "temporary validity rejects the gap before the first self-signature" + testTemporaryKeyValidityRejectsPreCertificationGap + , testCase + "temporary validity follows temporary self-revocations" + testTemporaryKeyValidityFollowsTemporarySelfRevocation + , testCase + "temporary validity does not revive older self-signatures after newer expiry" + testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures + , testCase + "uid-retired revocation is historical until effective" + testUidRetiredRevocationIsHistorical + , testCase + "third-party certifications do not affect primary key validity windows" + testThirdPartyCertificationDoesNotAffectKeyValidityWindow + , testCase + "certification revocations only remove matching signer certifications" + testCertificationRevocationOnlyRemovesMatchingSigner + , testCase + "preference resolution tracks active self-certification timeline" + testPreferencesAtTimestamp + , testCase + "verifySigWith rejects v6 revocation Issuer key-id subpackets" + testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID + , testCase + "verifySigWith rejects v6 revocation unhashed Issuer key-id subpackets" + testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed + , testCase + "verifySigWith accepts matching v6 revocation IssuerFingerprint" + testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint + , testCase + "v6 signer constructor rejects v4 key" + testV6SignerConstructorRejectsV4Key + , testCase + "primary key binding rejects unsupported critical hashed subpackets" + testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket + , testCase + "subkey binding missing back-signature is surfaced as a warning" + testSubkeyBindingMissingBackSignatureProducesWarning + , testCase + "subkey binding rejects unsupported critical hashed subpackets" + testSubkeyBindingRejectsUnsupportedCriticalSubpacket + ] + ] + +testPKAandSizeAndKeyIDandFingerprint + :: FilePath -> String -> Assertion +testPKAandSizeAndKeyIDandFingerprint fpr kf = do + bs <- readFixturePayload fpr + case runGet (get :: Get Pkt) bs of + Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke." + Right pkt -> + case publicKeyPacketOf pkt of + PublicKeyPkt pkp -> do + let pref = + concat + [ pkalgoAbbrev (_pkalgo pkp) + , "/" + , either (const "unknown") show (pubkeySize (_pubkey pkp)) + , ":" + , either (const "unknown") (show . pretty) (eightOctetKeyID pkp) + , "/" + ] + assertEqual + ("for " ++ fpr ++ " (spaceless)") + (spaceless kf) + (pref ++ show (pretty (fingerprint pkp))) + assertEqual + ("for " ++ fpr ++ " (spaced)") + kf + (pref ++ show (pretty (SpacedFingerprint (fingerprint pkp)))) + _ -> + assertFailure + "Expected (possibly secret) key packet, got something else." + where + spaceless = filter (/= ' ') + +testKeyringLookup :: FilePath -> String -> Bool -> Assertion +testKeyringLookup fpr eok expected = do + kr <- loadKeyring fpr + let foundKey = getOne (kr @= (read eok :: EightOctetKeyId)) + assertEqual (eok ++ " in " ++ fpr) expected (isJust foundKey) + +testKeyringSize :: FilePath -> Int -> Assertion +testKeyringSize fpr expected = do + kr <- loadKeyring fpr + assertEqual ("key count in " ++ fpr) expected (size kr) + +assertLeftContains + :: String -> Either VerificationError a -> Assertion +assertLeftContains needle result = + case result of + Left err -> + let rendered = renderVerificationError err + in if needle `isInfixOf` rendered + then pure () + else + assertFailure + ( "Expected error containing '" + ++ needle + ++ "', got '" + ++ rendered + ++ "'." + ) + Right _ -> + assertFailure + ("Expected Left containing '" ++ needle ++ "', got Right.") + +testMissingSigningKeyMessage :: FilePath -> FilePath -> Assertion +testMissingSigningKeyMessage keyring message = do + kr <- loadKeyring keyring + verification <- + DC.runConduitRes $ + CB.sourceFile (fixturePath message) + DC..| conduitGet get + DC..| conduitDecompress + DC..| conduitVerify kr Nothing + DC..| CL.consume + case verification of + [] -> assertFailure "Expected at least one verification result." + (firstResult : _) -> + assertLeftContains "signing key not found in keyring" firstResult + +testTamperedSignatureMessage :: FilePath -> FilePath -> Assertion +testTamperedSignatureMessage keyring message = do + kr <- loadKeyring keyring + packets <- loadAndDecompressPkts message + let tamperedPackets = map tamperLiteral packets + verification <- + DC.runConduitRes $ + CL.sourceList tamperedPackets + DC..| conduitVerify kr Nothing + DC..| CL.consume + case verification of + [] -> assertFailure "Expected at least one verification result." + (firstResult : _) -> + assertLeftContains "signature mismatch" firstResult + where + tamperLiteral (LiteralDataPkt dt fn ts payload) = + LiteralDataPkt dt fn ts (BL.snoc payload 0) + tamperLiteral pkt = pkt + +testRevokedCertificateMessage :: FilePath -> Assertion +testRevokedCertificateMessage keyfile = do + ks <- + DC.runConduitRes $ + CB.sourceFile ("tests/data/" ++ keyfile) + DC..| conduitGet get + DC..| conduitToTKsEither + DC..| conduitDropErrorsAndNothings + DC..| CL.consume + assertLeftContains + "signing key is revoked" + ( mapM + ( verifyUnknownTKWith + (verifySigWith defaultVerificationPolicy (verifyAgainstKeys ks)) + Nothing + ) + ks + ) + +testKeysSelfVerification :: Bool -> FilePath -> Assertion +testKeysSelfVerification expectsuccess keyfile = do + ks <- + DC.runConduitRes $ + CB.sourceFile ("tests/data/" ++ keyfile) + DC..| conduitGet get + DC..| conduitToTKsEither + DC..| conduitDropErrorsAndNothings + DC..| CL.consume + let verifieds = + mapM + ( verifyUnknownTKWith + (verifySigWith defaultVerificationPolicy (verifyAgainstKeys ks)) + Nothing + ) + ks + assertEqual + (keyfile ++ " self-verification") + expectsuccess + (isRight verifieds) + +testKeysExpiration :: Bool -> FilePath -> Assertion +testKeysExpiration expectsuccess keyfile = do + ks <- + DC.runConduitRes $ + CB.sourceFile (fixturePath keyfile) + DC..| conduitGet get + DC..| conduitToTKsEither + DC..| conduitDropErrorsAndNothings + DC..| CL.consume + case mapM + ( verifyUnknownTKWith + (verifySigWith defaultVerificationPolicy (verifyAgainstKeys ks)) + Nothing + ) + ks of + Left err -> + assertFailure + ( keyfile + ++ " key self-verification failed before expiration check: " + ++ renderVerificationError err + ) + Right verifieds -> do + let tvalid = + all + ( isTKTimeValid + (posixSecondsToUTCTime (realToFrac (1400000000 :: Integer))) + ) + verifieds + assertEqual (keyfile ++ " key expiration") expectsuccess tvalid + +testConduitVerifyProcessesSigV6 :: Assertion +testConduitVerifyProcessesSigV6 = do + kr <- loadKeyring "pubring.gpg" + let sigPayload = + SigV6 + BinarySig + RSA + SHA256 + (SignatureSalt (BL.replicate 16 0)) + [] + [] + 0 + (MPI 0 :| []) + packets = + [ LiteralDataPkt + BinaryData + BL.empty + (ThirtyTwoBitTimeStamp 0) + "payload" + , SignaturePkt sigPayload + ] + verification <- + DC.runConduitRes $ + CL.sourceList packets + DC..| conduitVerify kr Nothing + DC..| CL.consume + case verification of + [Left _] -> return () + other -> + assertFailure + ( "Expected one v6 verification result (failure is fine), got " + ++ show (length other) + ++ " results" + ) + +testSubkeyBindingRejectsUnsupportedCriticalSubpacket :: Assertion +testSubkeyBindingRejectsUnsupportedCriticalSubpacket = do + (primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner + (subkeySigner, _) <- loadDeterministicEd25519Signer + let creationTime = addTimestampSeconds (_timestamp primarySigner) 10 + (hashed, unhashed) <- + messageIssuerSubpacketsAt primarySigner creationTime + let bindingPayload = + payloadForSig + SubkeyBindingSig + emptyPSC + { lastPrimaryKey = PublicKeyPkt primarySigner + , lastSubkey = PublicSubkeyPkt subkeySigner + } + hashedWithUnsupportedCritical = + SigSubPacket True (OtherSigSub 111 "unsupported-critical") + : hashed + keyring = [TKUnknown (primarySigner, Nothing) [] [] [] []] + state = + emptyPSC + { lastPrimaryKey = PublicKeyPkt primarySigner + , lastSubkey = PublicSubkeyPkt subkeySigner + } + sigPayload <- + case signDataWithRSA + SubkeyBindingSig + primarySigningKey + hashedWithUnsupportedCritical + unhashed + bindingPayload of + Left err -> + assertFailure + ( "failed to sign subkey binding with unsupported critical subpacket: " + ++ renderSignError err + ) + >> fail "expected subkey binding signature" + Right sig -> pure sig + case verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys keyring) + (SignaturePkt sigPayload) + state + Nothing of + Left (UnsupportedCriticalSubpacket SubkeyBindingSig) -> pure () + Left err -> + assertFailure + ( "Expected unsupported critical subpacket rejection for subkey binding signature, got: " + ++ renderVerificationError err + ) + Right _ -> + assertFailure + "Expected unsupported critical subpacket rejection for subkey binding signature, but verification succeeded" + +testSubkeyBindingMissingBackSignatureProducesWarning :: Assertion +testSubkeyBindingMissingBackSignatureProducesWarning = do + (primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner + (subkeySignerRaw, _) <- loadDeterministicEd25519Signer + let subkeySigner = setKeyVersion V6 subkeySignerRaw + creationTime = addTimestampSeconds (_timestamp primarySigner) 10 + keyring = [TKUnknown (primarySigner, Nothing) [] [] [] []] + state = + emptyPSC + { lastPrimaryKey = PublicKeyPkt primarySigner + , lastSubkey = PublicSubkeyPkt subkeySigner + } + sigPayload <- + signSubkeyBindingWithRSAExtrasAt + primarySigner + subkeySigner + primarySigningKey + creationTime + [SigSubPacket False (KeyFlags (Set.singleton SignDataKey))] + case verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys keyring) + (SignaturePkt sigPayload) + state + Nothing of + Left err -> + assertFailure + ( "Expected successful verification with warning for missing back-signature, got: " + ++ renderVerificationError err + ) + Right verification -> + assertBool + "v6 signing-capable subkey binding without embedded back-signature should emit warning" + ( MissingSubkeyBackSignatureWarning + `elem` _verificationWarnings verification + ) + +testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket + :: Assertion +testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket = do + (signer, _) <- loadUnencryptedRsaSigner + let sigPayload = + SigV4 + PrimaryKeyBindingSig + RSA + SHA256 + [SigSubPacket True (OtherSigSub 111 "unsupported-critical")] + [] + 0 + (MPI 0 :| []) + verifyFn _ _ _ = Right (Verification signer sigPayload []) + state = + emptyPSC + { lastPrimaryKey = PublicKeyPkt signer + , lastSubkey = PublicSubkeyPkt signer + } + case verifySigWith + defaultVerificationPolicy + verifyFn + (SignaturePkt sigPayload) + state + Nothing of + Left (UnsupportedCriticalSubpacket PrimaryKeyBindingSig) -> pure () + Left err -> + assertFailure + ( "Expected unsupported critical subpacket rejection for primary key binding signature, got: " + ++ renderVerificationError err + ) + Right _ -> + assertFailure + "Expected unsupported critical subpacket rejection for primary key binding signature, but verification succeeded" + +testSignatureBuilders :: Assertion +testSignatureBuilders = do + (_, signingKey) <- loadUnencryptedRsaSigner + -- Test RSA builder API with empty subpackets + let builderRsa = sigBuilderInit @'PKA.RSA BinarySig SHA512 + let builderRsaWithHashed = addHashedSubs (listToHashedSubs []) builderRsa + let builderRsaFinal = addUnhashedSubs (listToUnhashedSubs []) builderRsaWithHashed + case signDataWithRSABuilder builderRsaFinal signingKey "test payload" of + Left err -> + assertFailure ("RSA builder API failed: " ++ renderSignError err) + Right (SigV4 BinarySig RSA SHA512 _ _ _ _) -> pure () + Right other -> + assertFailure + ( "RSA builder API should generate BinarySig RSA SHA512, got " + ++ show other + ) + + -- Test RSA builder API with non-default hash algorithm + let builderRsaSha256 = sigBuilderInit @'PKA.RSA BinarySig SHA256 + builderRsaSha256WithHashed = + addHashedSubs (listToHashedSubs []) builderRsaSha256 + builderRsaSha256Final = + addUnhashedSubs + (listToUnhashedSubs []) + builderRsaSha256WithHashed + case signDataWithRSABuilder + builderRsaSha256Final + signingKey + "test payload" of + Left err -> + assertFailure + ("RSA SHA256 builder API failed: " ++ renderSignError err) + Right (SigV4 BinarySig RSA SHA256 _ _ _ _) -> + pure () + Right other -> + assertFailure + ( "RSA builder API should generate BinarySig RSA SHA256, got " + ++ show other + ) + + -- Unsupported hash algorithms should be rejected by RSA PKCS#1 v1.5 backend + let builderRsaUnsupported = sigBuilderInit @'PKA.RSA BinarySig (OtherHA 99) + builderRsaUnsupportedWithHashed = + addHashedSubs (listToHashedSubs []) builderRsaUnsupported + builderRsaUnsupportedFinal = + addUnhashedSubs + (listToUnhashedSubs []) + builderRsaUnsupportedWithHashed + case signDataWithRSABuilder + builderRsaUnsupportedFinal + signingKey + "test payload" of + Left (SignBackendError _) -> pure () + Left err -> + assertFailure + ( "RSA builder API should reject unsupported hash with backend error, got " + ++ renderSignError err + ) + Right sig -> + assertFailure + ( "RSA builder API should reject unsupported hash algorithm, got " + ++ show sig + ) + + -- Runtime hash witness promotion should build RFC9580-compatible builders. + let runtimeRsa = + case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig SHA512 of + Left err -> Left err + Right builder -> + let withHashed = addHashedSubs (listToHashedSubs []) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs []) withHashed + in first + renderSignError + (signDataWithRSABuilder withUnhashed signingKey "test payload") + case runtimeRsa of + Left err -> + assertFailure + ( "runtime RFC9580 SHA512 builder initialization should succeed, got " + ++ err + ) + Right (SigV4 BinarySig RSA SHA512 _ _ _ _) -> pure () + Right other -> + assertFailure + ( "runtime RFC9580 SHA512 builder should produce BinarySig RSA SHA512, got " + ++ show other + ) + + case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig SHA1 of + Left _ -> pure () + Right _ -> + assertFailure + "runtime RFC9580 builder initialization should reject deprecated SHA1" + + case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig (OtherHA 99) of + Left _ -> pure () + Right _ -> + assertFailure + "runtime builder initialization should reject non-witness-backed hash algorithms" + + -- Test Ed25519 builder API with empty subpackets + (_, edSigningKey) <- loadDeterministicEd25519Signer + let builderEd25519 = sigBuilderInit @'PKA.Ed25519 BinarySig SHA512 + let builderEd25519WithHashed = addHashedSubs (listToHashedSubs []) builderEd25519 + let builderEd25519Final = + addUnhashedSubs (listToUnhashedSubs []) builderEd25519WithHashed + case signDataWithEd25519Builder + builderEd25519Final + edSigningKey + "test payload" of + Left err -> + assertFailure + ("Ed25519 builder API failed: " ++ renderSignError err) + Right (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _) -> pure () + Right other -> + assertFailure + ( "Ed25519 builder API should generate BinarySig Ed25519 SHA512, got " + ++ show other + ) + + -- Test Ed25519 v6 builder API + let v6Salt = SignatureSalt (BL.replicate 32 0x42) + let builderEd25519V6 = sigBuilderInitV6 @'PKA.Ed25519 BinarySig SHA512 v6Salt + let builderEd25519V6WithHashed = addHashedSubs (listToHashedSubs []) builderEd25519V6 + let builderEd25519V6Final = + addUnhashedSubs + (listToUnhashedSubs []) + builderEd25519V6WithHashed + case signDataWithEd25519V6Builder + builderEd25519V6Final + edSigningKey + "test payload" of + Left err -> + assertFailure + ("Ed25519 v6 builder API failed: " ++ renderSignError err) + Right (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _) -> + assertEqual + "Ed25519 v6 builder API should preserve 32-byte salt" + 32 + (BL.length (unSignatureSalt salt)) + Right other -> + assertFailure + ( "Ed25519 v6 builder API should generate BinarySig Ed25519 SHA512 SigV6, got " + ++ show other + ) + + -- Runtime v6 builder initialization should support SHA3 witness-backed hashes. + let v6Sha3Salt = SignatureSalt (BL.replicate 16 0x33) + runtimeEd25519V6Sha3 = + case sigBuilderInitV6Runtime @'PKA.Ed25519 + RFC9580 + BinarySig + SHA3_256 + v6Sha3Salt of + Left err -> Left err + Right builder -> + let withHashed = addHashedSubs (listToHashedSubs []) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs []) withHashed + in first + renderSignError + ( signDataWithEd25519V6Builder + withUnhashed + edSigningKey + "test payload" + ) + case runtimeEd25519V6Sha3 of + Left err -> + assertFailure + ("runtime RFC9580 SHA3-256 v6 builder should succeed, got " ++ err) + Right (SigV6 BinarySig PKA.Ed25519 SHA3_256 salt _ _ _ _) -> + assertEqual + "runtime RFC9580 SHA3-256 v6 builder should preserve 16-byte salt" + 16 + (BL.length (unSignatureSalt salt)) + Right other -> + assertFailure + ( "runtime RFC9580 SHA3-256 v6 builder should produce Ed25519 SigV6 SHA3_256, got " + ++ show other + ) + +testLegalSubpacketBuilders :: Assertion +testLegalSubpacketBuilders = do + (signer, signingKey) <- loadUnencryptedRsaSigner + issuerKeyId <- + case eightOctetKeyID signer of + Left err -> + assertFailure + ( "failed to derive issuer key id for legal-subpacket builder test: " + ++ err + ) + >> fail "expected issuer key id" + Right i -> pure i + + let signerFp = fingerprint signer + creation = ThirtyTwoBitTimeStamp 1 + v4Builder = sigBuilderInit @'PKA.RSA BinarySig SHA512 + v4WithHashed = + addHashedSubs + ( listToLegalSubs + [ LegalSigCreationTime creation + , LegalIssuerFingerprintV4 signerFp + ] + ) + v4Builder + v4Final = + addUnhashedSubs + (listToLegalSubs [LegalIssuerV4 issuerKeyId]) + v4WithHashed + + case signDataWithRSABuilder + v4Final + signingKey + "typed legal subpacket payload" of + Left err -> + assertFailure + ("v4 legal-subpacket builder failed: " ++ renderSignError err) + Right (SigV4 _ _ _ hashed unhashed _ _) -> do + assertBool + "v4 legal-subpacket builder should include creation time in hashed subpackets" + (SigSubPacket False (SigCreationTime creation) `elem` hashed) + assertBool + "v4 legal-subpacket builder should include v4 issuer fingerprint in hashed subpackets" + ( SigSubPacket + False + (IssuerFingerprint IssuerFingerprintV4 signerFp) + `elem` hashed + ) + assertBool + "v4 legal-subpacket builder should include issuer key ID only in unhashed subpackets" + (SigSubPacket False (Issuer issuerKeyId) `elem` unhashed) + Right other -> + assertFailure + ( "v4 legal-subpacket builder should generate SigV4, got " + ++ show other + ) + + (_, edSigningKey) <- loadDeterministicEd25519Signer + let v6Salt = SignatureSalt (BL.replicate 32 0x17) + v6Builder = sigBuilderInitV6 @'PKA.Ed25519 BinarySig SHA512 v6Salt + v6WithHashed = + addHashedSubs + ( listToLegalSubs + [ LegalSigCreationTime creation + , LegalIssuerFingerprintV6 signerFp + ] + ) + v6Builder + v6Final = addUnhashedSubs (listToLegalSubs []) v6WithHashed + + case signDataWithEd25519V6Builder + v6Final + edSigningKey + "typed legal subpacket payload" of + Left err -> + assertFailure + ("v6 legal-subpacket builder failed: " ++ renderSignError err) + Right (SigV6 _ _ _ _ hashed unhashed _ _) -> do + assertBool + "v6 legal-subpacket builder should include creation time in hashed subpackets" + (SigSubPacket False (SigCreationTime creation) `elem` hashed) + assertBool + "v6 legal-subpacket builder should include v6 issuer fingerprint in hashed subpackets" + ( SigSubPacket + False + (IssuerFingerprint IssuerFingerprintV6 signerFp) + `elem` hashed + ) + assertEqual + "v6 legal-subpacket builder should keep unhashed set empty for typed legal set used here" + [] + unhashed + Right other -> + assertFailure + ( "v6 legal-subpacket builder should generate SigV6, got " + ++ show other + ) + +testTemporaryKeyValidityRespectsLatestSelfSignature :: Assertion +testTemporaryKeyValidityRespectsLatestSelfSignature = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "temporary-validity@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + longValidityCertTime = addTimestampSeconds keyCreated 10 + temporaryValidityCertTime = addTimestampSeconds keyCreated 20 + validCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) + expiredCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 200) + preExpirySignatureTime = addTimestampSeconds keyCreated 25 + postExpirySignatureTime = addTimestampSeconds keyCreated 40 + payload = "temporary validity signer timeline payload" + longValidityCert <- + signCertificationAt + signer + signingKey + uid + longValidityCertTime + [SigSubPacket False (KeyExpirationTime 1000)] + temporaryValidityCert <- + signCertificationAt + signer + signingKey + uid + temporaryValidityCertTime + [SigSubPacket False (KeyExpirationTime 30)] + preExpirySignature <- + signBinaryMessageWithRSAAt + signer + signingKey + preExpirySignatureTime + payload + postExpirySignature <- + signBinaryMessageWithRSAAt + signer + signingKey + postExpirySignatureTime + payload + let tk = + TKUnknown + (signer, Nothing) + [] + [(uidText, [longValidityCert, temporaryValidityCert])] + [] + [] + keyring = mkTestKeyring [tk] + assertBool + "latest effective self-signature should keep key valid before temporary expiration" + (isTKTimeValid validCheckTime tk) + assertBool + "latest effective self-signature should expire key at the temporary validity boundary" + (not (isTKTimeValid expiredCheckTime tk)) + assertSingleSignerFingerprint + "pre-expiry signatures should still verify" + (fingerprint signer) + (verifyTimelinePackets keyring payload preExpirySignature) + assertSingleFailureContainsTimeline + "post-expiry signatures should be rejected" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload postExpirySignature) + +testTemporaryKeyValidityRejectsSelfSignatureGaps :: Assertion +testTemporaryKeyValidityRejectsSelfSignatureGaps = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "temporary-validity-gap@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + firstCertTime = addTimestampSeconds keyCreated 10 + secondCertTime = addTimestampSeconds keyCreated 30 + gapCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) + renewedCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 35) + gapSignatureTime = addTimestampSeconds keyCreated 25 + renewedSignatureTime = addTimestampSeconds keyCreated 35 + payload = "temporary validity gap signer timeline payload" + firstCertification <- + signCertificationAt + signer + signingKey + uid + firstCertTime + [ SigSubPacket False (KeyExpirationTime 1000) + , SigSubPacket False (SigExpirationTime 10) + ] + secondCertification <- + signCertificationAt + signer + signingKey + uid + secondCertTime + [SigSubPacket False (KeyExpirationTime 1000)] + gapSignature <- + signBinaryMessageWithRSAAt + signer + signingKey + gapSignatureTime + payload + renewedSignature <- + signBinaryMessageWithRSAAt + signer + signingKey + renewedSignatureTime + payload + let tk = + TKUnknown + (signer, Nothing) + [] + [(uidText, [firstCertification, secondCertification])] + [] + [] + keyring = mkTestKeyring [tk] + assertBool + "a gap with no effective self-signature should make the key temporarily invalid" + (not (isTKTimeValid gapCheckTime tk)) + assertBool + "a later self-signature should restore validity once it becomes effective" + (isTKTimeValid renewedCheckTime tk) + assertSingleFailureContainsTimeline + "signatures made during a self-signature gap should be rejected" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload gapSignature) + assertSingleSignerFingerprint + "signatures made after a later self-signature becomes effective should verify" + (fingerprint signer) + (verifyTimelinePackets keyring payload renewedSignature) + +testTemporaryKeyValidityRejectsPreCertificationGap :: Assertion +testTemporaryKeyValidityRejectsPreCertificationGap = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "temporary-validity-pre-cert-gap@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + certificationTime = addTimestampSeconds keyCreated 20 + invalidCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 10) + validCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) + invalidSignatureTime = addTimestampSeconds keyCreated 10 + validSignatureTime = addTimestampSeconds keyCreated 25 + payload = + "temporary validity pre-certification gap signer timeline payload" + certification <- + signCertificationAt + signer + signingKey + uid + certificationTime + [SigSubPacket False (KeyExpirationTime 1000)] + invalidSignature <- + signBinaryMessageWithRSAAt + signer + signingKey + invalidSignatureTime + payload + validSignature <- + signBinaryMessageWithRSAAt + signer + signingKey + validSignatureTime + payload + let tk = + TKUnknown (signer, Nothing) [] [(uidText, [certification])] [] [] + keyring = mkTestKeyring [tk] + assertBool + "a key should be invalid before its first self-signature becomes effective" + (not (isTKTimeValid invalidCheckTime tk)) + assertBool + "a key should become valid once its first self-signature becomes effective" + (isTKTimeValid validCheckTime tk) + assertSingleFailureContainsTimeline + "signatures made before the first self-signature should be rejected" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload invalidSignature) + assertSingleSignerFingerprint + "signatures made after the first self-signature becomes effective should verify" + (fingerprint signer) + (verifyTimelinePackets keyring payload validSignature) + +testTemporaryKeyValidityFollowsTemporarySelfRevocation + :: Assertion +testTemporaryKeyValidityFollowsTemporarySelfRevocation = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "temporary-validity-self-revocation@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + certificationTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + revokedCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) + restoredCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 35) + revokedSignatureTime = addTimestampSeconds keyCreated 25 + restoredSignatureTime = addTimestampSeconds keyCreated 35 + payload = "temporary validity self-revocation signer timeline payload" + certification <- + signCertificationAt + signer + signingKey + uid + certificationTime + [SigSubPacket False (KeyExpirationTime 1000)] + temporaryRevocation <- + signCertificationRevocationAt + signer + signingKey + uid + revocationTime + [SigSubPacket False (SigExpirationTime 10)] + revokedSignature <- + signBinaryMessageWithRSAAt + signer + signingKey + revokedSignatureTime + payload + restoredSignature <- + signBinaryMessageWithRSAAt + signer + signingKey + restoredSignatureTime + payload + let tk = + TKUnknown + (signer, Nothing) + [] + [(uidText, [certification, temporaryRevocation])] + [] + [] + keyring = mkTestKeyring [tk] + assertBool + "a temporary self-revocation should disable signing while it is effective" + (not (isTKTimeValid revokedCheckTime tk)) + assertBool + "a self-certification should become valid again once its temporary revocation expires" + (isTKTimeValid restoredCheckTime tk) + assertSingleFailureContainsTimeline + "signatures made during a temporary self-revocation should be rejected" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload revokedSignature) + assertSingleSignerFingerprint + "signatures made after a temporary self-revocation expires should verify" + (fingerprint signer) + (verifyTimelinePackets keyring payload restoredSignature) + +testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures + :: Assertion +testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "temporary-validity-no-revival@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + firstCertTime = addTimestampSeconds keyCreated 10 + secondCertTime = addTimestampSeconds keyCreated 20 + invalidCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 30) + invalidSignatureTime = addTimestampSeconds keyCreated 30 + payload = "temporary validity no revival signer timeline payload" + firstCertification <- + signCertificationAt + signer + signingKey + uid + firstCertTime + [SigSubPacket False (KeyExpirationTime 1000)] + secondCertification <- + signCertificationAt + signer + signingKey + uid + secondCertTime + [ SigSubPacket False (KeyExpirationTime 1000) + , SigSubPacket False (SigExpirationTime 5) + ] + invalidSignature <- + signBinaryMessageWithRSAAt + signer + signingKey + invalidSignatureTime + payload + let tk = + TKUnknown + (signer, Nothing) + [] + [(uidText, [firstCertification, secondCertification])] + [] + [] + keyring = mkTestKeyring [tk] + assertBool + "an expired newer self-signature should not revive an older certification" + (not (isTKTimeValid invalidCheckTime tk)) + assertSingleFailureContainsTimeline + "signatures after a newer self-signature expires should be rejected until re-certified" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload invalidSignature) + +testUidRetiredRevocationIsHistorical :: Assertion +testUidRetiredRevocationIsHistorical = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uidText = "retired-uid@example.org" + uid = UserId uidText + keyCreated = _timestamp signer + certificationTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + certification <- + signCertificationAt signer signingKey uid certificationTime [] + retirementRevocation <- + signCertificationRevocationAt + signer + signingKey + uid + revocationTime + [ SigSubPacket + False + (ReasonForRevocation UserIdInfoNoLongerValid "") + ] + let tk = + TKUnknown + (signer, Nothing) + [] + [(uidText, [certification, retirementRevocation])] + [] + [] + verifyAt ts = + verifyUnknownTKWith + (verifySigWith defaultVerificationPolicy (verifyAgainstKeys [tk])) + (Just (timestampToUTCTime ts)) + tk + beforeRetirement <- + case verifyAt (addTimestampSeconds keyCreated 15) of + Left err -> + assertFailure + ( "uid-retired pre-revocation verification failed: " + ++ renderVerificationError err + ) + >> fail "expected verified transferable key before uid retirement" + Right verifiedTK -> pure verifiedTK + afterRetirement <- + case verifyAt (addTimestampSeconds keyCreated 25) of + Left err -> + assertFailure + ( "uid-retired post-revocation verification failed: " + ++ renderVerificationError err + ) + >> fail "expected verified transferable key after uid retirement" + Right verifiedTK -> pure verifiedTK + assertEqual + "uid-retired revocation should preserve the UID before it becomes effective" + 1 + (length (_tkuUIDs beforeRetirement)) + assertEqual + "uid-retired revocation should retire the UID once effective" + 0 + (length (_tkuUIDs afterRetirement)) + +testThirdPartyCertificationDoesNotAffectKeyValidityWindow + :: Assertion +testThirdPartyCertificationDoesNotAffectKeyValidityWindow = do + (targetSigner, _) <- loadUnencryptedRsaSigner + (thirdPartySigner, thirdPartySigningKey) <- + loadDeterministicEd25519Signer + let uidText = "third-party-validity@example.org" + uid = UserId uidText + keyCreated = _timestamp targetSigner + certificationTime = addTimestampSeconds keyCreated 10 + validityCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 200) + thirdPartyCertification <- + signCertificationWithEd25519At + targetSigner + thirdPartySigner + thirdPartySigningKey + uid + certificationTime + [SigSubPacket False (KeyExpirationTime 30)] + let targetTK = + TKUnknown + (targetSigner, Nothing) + [] + [(uidText, [thirdPartyCertification])] + [] + [] + certifierTK = TKUnknown (thirdPartySigner, Nothing) [] [] [] [] + verifyAt = + verifyUnknownTKWith + ( verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys [targetTK, certifierTK]) + ) + (Just validityCheckTime) + targetTK + verifiedTK <- + case verifyAt of + Left err -> + assertFailure + ( "third-party certification verification failed: " + ++ renderVerificationError err + ) + >> fail "expected verified transferable key" + Right tk -> pure tk + assertBool + "third-party certifications must not define the primary key validity window" + (isTKTimeValid validityCheckTime verifiedTK) + +testCertificationRevocationOnlyRemovesMatchingSigner :: Assertion +testCertificationRevocationOnlyRemovesMatchingSigner = do + (targetSigner, targetSigningKey) <- loadUnencryptedRsaSigner + (thirdPartySigner, thirdPartySigningKey) <- + loadDeterministicEd25519Signer + let uidText = "cert-revocation-scope@example.org" + uid = UserId uidText + keyCreated = _timestamp targetSigner + selfCertificationTime = addTimestampSeconds keyCreated 10 + thirdPartyCertificationTime = addTimestampSeconds keyCreated 12 + thirdPartyRevocationTime = addTimestampSeconds keyCreated 20 + beforeRevocationTime = timestampToUTCTime (addTimestampSeconds keyCreated 15) + afterRevocationTime = timestampToUTCTime (addTimestampSeconds keyCreated 25) + selfCertification <- + signCertificationAt + targetSigner + targetSigningKey + uid + selfCertificationTime + [] + thirdPartyCertification <- + signCertificationWithEd25519At + targetSigner + thirdPartySigner + thirdPartySigningKey + uid + thirdPartyCertificationTime + [] + thirdPartyRevocation <- + signCertificationRevocationWithEd25519At + targetSigner + thirdPartySigner + thirdPartySigningKey + uid + thirdPartyRevocationTime + [] + let targetTK = + TKUnknown + (targetSigner, Nothing) + [] + [ + ( uidText + , + [ selfCertification + , thirdPartyCertification + , thirdPartyRevocation + ] + ) + ] + [] + [] + certifierTK = TKUnknown (thirdPartySigner, Nothing) [] [] [] [] + verifyAt ts = + verifyUnknownTKWith + ( verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys [targetTK, certifierTK]) + ) + (Just ts) + targetTK + beforeRevocation <- + case verifyAt beforeRevocationTime of + Left err -> + assertFailure + ( "pre-revocation certification verification failed: " + ++ renderVerificationError err + ) + >> fail + "expected verified transferable key before certification revocation" + Right tk -> pure tk + afterRevocation <- + case verifyAt afterRevocationTime of + Left err -> + assertFailure + ( "post-revocation certification verification failed: " + ++ renderVerificationError err + ) + >> fail + "expected verified transferable key after certification revocation" + Right tk -> pure tk + let beforeSigs = + maybe + [] + snd + (find ((== uidText) . fst) (_tkuUIDs beforeRevocation)) + afterSigs = + maybe + [] + snd + (find ((== uidText) . fst) (_tkuUIDs afterRevocation)) + assertEqual + "certification revocations should not apply before they become effective" + [selfCertification, thirdPartyCertification] + beforeSigs + assertEqual + "a certification revocation should remove only certifications from the same signer" + [selfCertification] + afterSigs + +testPreferencesAtTimestamp :: Assertion +testPreferencesAtTimestamp = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let uid = UserId "prefs@example.org" + UserId uidText = uid + t1 = addTimestampSeconds (_timestamp signer) 1 + t2 = addTimestampSeconds t1 100 + t3 = addTimestampSeconds t2 100 + queryDuring = addTimestampSeconds t2 1 + queryAfterRevocation = addTimestampSeconds t3 1 + + initialCertification <- + signCertificationAt + signer + signingKey + uid + t1 + [SigSubPacket False (PreferredHashAlgorithms [SHA256])] + updatedCertification <- + signCertificationAt + signer + signingKey + uid + t2 + [SigSubPacket False (PreferredHashAlgorithms [SHA512])] + certificationRevocation <- + signCertificationRevocationAt signer signingKey uid t3 [] + + let tk = + TKUnknown + (signer, Nothing) + [] + [ + ( uidText + , + [ initialCertification + , updatedCertification + , certificationRevocation + ] + ) + ] + [] + [] + + assertEqual + "key preferences at timestamp should use the latest active self-certification" + (Just [PreferredHashAlgorithms [SHA512]]) + (effectiveKeyPreferencesAtTimestamp queryDuring tk) + assertEqual + "UID preferences at timestamp should use the latest active self-certification" + (Just [PreferredHashAlgorithms [SHA512]]) + (effectiveUIDPreferencesAtTimestamp queryDuring uidText tk) + assertEqual + "revoked UID certifications should not provide effective UID preferences" + Nothing + ( effectiveUIDPreferencesAtTimestamp + queryAfterRevocation + uidText + tk + ) + assertEqual + "key preferences should become unavailable when no active self-certification remains" + Nothing + (effectiveKeyPreferencesAtTimestamp queryAfterRevocation tk) + +testChangePrivateKeyPassphraseLegacy :: Assertion +testChangePrivateKeyPassphraseLegacy = do + passphrase <- readPKIPassphrase + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/aes256-sha512.seckey" + DC..| conduitGet get + DC..| CL.consume + (pkp, ska) <- + case packets of + (SecretKeyPkt pkpayload skaddendum : _) -> pure (pkpayload, skaddendum) + _ -> + assertFailure + "aes256-sha512.seckey did not begin with a secret key packet" + >> fail "expected secret key packet" + originalDecrypted <- + case decryptPrivateKey (pkp, ska) passphrase of + Left err -> + assertFailure ("decrypting original legacy key failed: " ++ err) + >> fail "decrypting original legacy key failed" + Right x -> pure x + originalSKey <- + case originalDecrypted of + SUUnencrypted skey _ -> pure skey + _ -> + assertFailure + "original legacy key should decrypt to unencrypted secret material" + >> fail "expected unencrypted secret key" + changed <- + case changePrivateKeyPassphrase + (pkp, ska) + passphrase + (Salt "12345678") + (IV "1234567890ABCDEF") + "changed-pki-password" of + Left err -> + assertFailure + ( "legacy passphrase change should preserve the existing protection envelope, got: " + ++ err + ) + >> fail "legacy passphrase change failed" + Right skaddendum -> pure skaddendum + originalIterCount <- + case ska of + SUSSHA1 AES256 (IteratedSalted SHA512 _ iter) _ _ -> pure iter + _ -> + assertFailure + "legacy key fixture should use SUSSHA1/AES256/IteratedSalted SHA512" + >> fail "expected legacy key fixture" + case changed of + SUSSHA1 AES256 (IteratedSalted SHA512 _ iter) _ encryptedPayload -> do + assertEqual + "legacy passphrase change should preserve the S2K iteration count" + originalIterCount + iter + assertBool + "legacy passphrase change should emit encrypted payload" + (not (BL.null encryptedPayload)) + _ -> + assertFailure + "legacy passphrase change should preserve the SUSSHA1/AES256 envelope" + decrypted <- + case decryptPrivateKey (pkp, changed) "changed-pki-password" of + Left err -> + assertFailure + ("re-decrypting changed legacy key failed: " ++ err) + >> fail "re-decrypting changed legacy key failed" + Right x -> pure x + case decrypted of + SUUnencrypted skey _ -> + assertEqual + "legacy passphrase change should preserve secret key material" + originalSKey + skey + _ -> + assertFailure + "legacy passphrase change should decrypt back to unencrypted secret material" + +testChangePrivateKeyPassphraseV6 :: Assertion +testChangePrivateKeyPassphraseV6 = do + oldPassphrase <- readPKIPassphrase + armors <- loadArmor "v6-encrypted-secret.pgp.aa" + armor <- + case armors of + (a : _) -> pure a + [] -> + assertFailure + "v6-encrypted-secret.pgp.aa should contain one armored payload" + >> fail "expected one armored payload" + let packets = parsePkts (armorPayload armor) + (pkp, ska) <- + case packets of + (SecretKeyPkt pkpayload skaddendum : _) -> pure (pkpayload, skaddendum) + _ -> + assertFailure + "v6-encrypted-secret.pgp.aa did not begin with a secret key packet" + >> fail "expected secret key packet" + let newPassphrase = "changed-pki-password" + originalDecrypted <- + case decryptPrivateKey (pkp, ska) oldPassphrase of + Left err -> + assertFailure ("decrypting original v6 key failed: " ++ err) + >> fail "decrypting original v6 key failed" + Right x -> pure x + originalSKey <- + case originalDecrypted of + SUUnencrypted skey _ -> pure skey + _ -> + assertFailure + "original v6 key should decrypt to unencrypted secret material" + >> fail "expected unencrypted secret key" + let changedResult = + changePrivateKeyPassphrase + (pkp, ska) + oldPassphrase + (Salt "1234567890ABCDEF") + (IV "1234567890ABCDE") + newPassphrase + changed <- + case changedResult of + Left err -> + assertFailure ("changing v6 key passphrase failed: " ++ err) + >> pure ska + Right skaddendum -> pure skaddendum + case changed of + SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do + assertEqual + "changed v6 key addendum should use expected Argon2 t parameter" + 1 + t + assertEqual + "changed v6 key addendum should use expected Argon2 p parameter" + 4 + p + assertEqual + "changed v6 key addendum should use expected Argon2 encoded memory parameter" + 15 + em + assertBool + "changed v6 key addendum should contain encrypted key material" + (not (BL.null encryptedPayload)) + _ -> + assertFailure + "changed v6 key addendum should be encrypted with SUSAEAD" + let decryptedResult = decryptPrivateKey (pkp, changed) newPassphrase + decrypted <- + case decryptedResult of + Left err -> + assertFailure + ("decryption with changed v6 passphrase failed: " ++ err) + >> fail "decryption with changed v6 passphrase failed" + Right x -> pure x + case decrypted of + SUUnencrypted skey _ -> + assertEqual + "changing a v6 key passphrase should preserve secret key material" + originalSKey + skey + _ -> + assertFailure + "changed v6 key should decrypt with the new passphrase" + +testPolicySignatureContextValidation :: Assertion +testPolicySignatureContextValidation = do + let pkSigV4PK = SigV4 KeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| []) + pkSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| []) + pkSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) + pkSigV6PK = + SigV6 + KeyRevocationSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x11)) + [] + [] + 0 + (MPI 0 :| []) + pkSigV6Direct = + SigV6 + SignatureDirectlyOnAKey + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x12)) + [] + [] + 0 + (MPI 0 :| []) + pkSigV6Binding = + SigV6 + SubkeyBindingSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x13)) + [] + [] + 0 + (MPI 0 :| []) + skSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) + skSigV4Revocation = SigV4 SubkeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| []) + skSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| []) + skSigV6Binding = + SigV6 + SubkeyBindingSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x14)) + [] + [] + 0 + (MPI 0 :| []) + skSigV6Revocation = + SigV6 + SubkeyRevocationSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x15)) + [] + [] + 0 + (MPI 0 :| []) + skSigV6Direct = + SigV6 + SignatureDirectlyOnAKey + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x16)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV4Generic = SigV4 GenericCert RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV4Persona = SigV4 PersonaCert RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV4Casual = SigV4 CasualCert RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV4Positive = SigV4 PositiveCert RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV4CertRev = SigV4 CertRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) + uidSigV6Generic = + SigV6 + GenericCert + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x17)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV6Persona = + SigV6 + PersonaCert + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x18)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV6Casual = + SigV6 + CasualCert + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x19)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV6Positive = + SigV6 + PositiveCert + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x1a)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV6CertRev = + SigV6 + CertRevocationSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x1b)) + [] + [] + 0 + (MPI 0 :| []) + uidSigV6Binding = + SigV6 + SubkeyBindingSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x1c)) + [] + [] + 0 + (MPI 0 :| []) + assertTrue + "KeyRevocationSig allowed on primary key" + (isAllowedPrimaryKeySig pkSigV4PK) + assertTrue + "SignatureDirectlyOnAKey allowed on primary key" + (isAllowedPrimaryKeySig pkSigV4Direct) + assertFalse + "SubkeyBindingSig not allowed on primary key" + (isAllowedPrimaryKeySig pkSigV4Binding) + assertTrue + "v6 KeyRevocationSig allowed on primary key" + (isAllowedPrimaryKeySig pkSigV6PK) + assertTrue + "v6 SignatureDirectlyOnAKey allowed on primary key" + (isAllowedPrimaryKeySig pkSigV6Direct) + assertFalse + "v6 SubkeyBindingSig not allowed on primary key" + (isAllowedPrimaryKeySig pkSigV6Binding) + assertTrue + "SubkeyBindingSig allowed on subkey" + (isAllowedSubkeySig skSigV4Binding) + assertTrue + "SubkeyRevocationSig allowed on subkey" + (isAllowedSubkeySig skSigV4Revocation) + assertFalse + "SignatureDirectlyOnAKey not allowed on subkey" + (isAllowedSubkeySig skSigV4Direct) + assertTrue + "v6 SubkeyBindingSig allowed on subkey" + (isAllowedSubkeySig skSigV6Binding) + assertTrue + "v6 SubkeyRevocationSig allowed on subkey" + (isAllowedSubkeySig skSigV6Revocation) + assertFalse + "v6 SignatureDirectlyOnAKey not allowed on subkey" + (isAllowedSubkeySig skSigV6Direct) + assertTrue + "GenericCert allowed on UID" + (isAllowedUIDSig uidSigV4Generic) + assertTrue + "PersonaCert allowed on UID" + (isAllowedUIDSig uidSigV4Persona) + assertTrue + "CasualCert allowed on UID" + (isAllowedUIDSig uidSigV4Casual) + assertTrue + "PositiveCert allowed on UID" + (isAllowedUIDSig uidSigV4Positive) + assertTrue + "CertRevocationSig allowed on UID" + (isAllowedUIDSig uidSigV4CertRev) + assertFalse + "SubkeyBindingSig not allowed on UID" + (isAllowedUIDSig uidSigV4Binding) + assertTrue + "v6 GenericCert allowed on UID" + (isAllowedUIDSig uidSigV6Generic) + assertTrue + "v6 PersonaCert allowed on UID" + (isAllowedUIDSig uidSigV6Persona) + assertTrue + "v6 CasualCert allowed on UID" + (isAllowedUIDSig uidSigV6Casual) + assertTrue + "v6 PositiveCert allowed on UID" + (isAllowedUIDSig uidSigV6Positive) + assertTrue + "v6 CertRevocationSig allowed on UID" + (isAllowedUIDSig uidSigV6CertRev) + assertFalse + "v6 SubkeyBindingSig not allowed on UID" + (isAllowedUIDSig uidSigV6Binding) + +testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID + :: Assertion +testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID = do + (signer, _) <- loadUnencryptedRsaSigner + issuerKeyId <- + case eightOctetKeyID signer of + Left err -> + assertFailure ("failed to derive RSA issuer key id: " ++ err) + >> fail "expected issuer key id" + Right i -> pure i + let sigPayload = + SigV6 + KeyRevocationSig + RSA + SHA256 + (SignatureSalt (BL.replicate 16 0)) + [SigSubPacket False (Issuer issuerKeyId)] + [] + 0 + (MPI 0 :| []) + verifyFn _ _ _ = Right (Verification signer sigPayload []) + result = + verifySigWith + defaultVerificationPolicy + verifyFn + (SignaturePkt sigPayload) + emptyPSC {lastPrimaryKey = PublicKeyPkt signer} + Nothing + case result of + Left err -> + assertBool + "v6 revocation verification should reject legacy Issuer key-id subpackets" + ( "Issuer Key ID subpacket is prohibited in v6 signatures" + `isInfixOf` renderVerificationError err + ) + Right _ -> + assertFailure + "Expected v6 revocation verification to reject legacy Issuer key-id subpacket" + +testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed + :: Assertion +testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed = do + (signer, _) <- loadUnencryptedRsaSigner + issuerKeyId <- + case eightOctetKeyID signer of + Left err -> + assertFailure ("failed to derive RSA issuer key id: " ++ err) + >> fail "expected issuer key id" + Right i -> pure i + let sigPayload = + SigV6 + KeyRevocationSig + RSA + SHA256 + (SignatureSalt (BL.replicate 16 0)) + [] + [SigSubPacket False (Issuer issuerKeyId)] + 0 + (MPI 0 :| []) + verifyFn _ _ _ = Right (Verification signer sigPayload []) + result = + verifySigWith + defaultVerificationPolicy + verifyFn + (SignaturePkt sigPayload) + emptyPSC {lastPrimaryKey = PublicKeyPkt signer} + Nothing + case result of + Left err -> + assertBool + "v6 revocation verification should reject legacy Issuer key-id subpackets in unhashed area" + ( "Issuer Key ID subpacket is prohibited in v6 signatures" + `isInfixOf` renderVerificationError err + ) + Right _ -> + assertFailure + "Expected v6 revocation verification to reject legacy Issuer key-id subpacket in unhashed area" + +testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint + :: Assertion +testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint = do + (signer, _) <- loadUnencryptedRsaSigner + let sigPayload = + SigV6 + KeyRevocationSig + RSA + SHA256 + (SignatureSalt (BL.replicate 16 0)) + [ SigSubPacket + False + (IssuerFingerprint IssuerFingerprintV6 (fingerprint signer)) + ] + [] + 0 + (MPI 0 :| []) + verifyFn _ _ _ = Right (Verification signer sigPayload []) + result = + verifySigWith + defaultVerificationPolicy + verifyFn + (SignaturePkt sigPayload) + emptyPSC {lastPrimaryKey = PublicKeyPkt signer} + Nothing + case result of + Left err -> + assertFailure + ( "Expected matching IssuerFingerprint to verify for v6 revocation signature, got: " + ++ renderVerificationError err + ) + Right _ -> pure () + +testV6SignerConstructorRejectsV4Key :: Assertion +testV6SignerConstructorRejectsV4Key = do + (signer, signingKey) <- loadDeterministicEd25519Signer + case asV6PKPayload signer of + Left _ -> pure () + Right signerV6 -> + seq (mkEd25519SignerV6 signerV6 signingKey) $ + assertFailure + "asV6PKPayload should reject v4 Ed25519 key payloads" + (rsaSigner, rsaSigningKey) <- loadUnencryptedRsaSigner + case asV6PKPayload rsaSigner of + Left _ -> pure () + Right signerV6 -> + seq (mkRSASignerV6 signerV6 rsaSigningKey) $ + assertFailure "asV6PKPayload should reject v4 RSA key payloads" + +testGetSecretKeyHandlesV4X25519ECDHPubkey :: Assertion +testGetSecretKeyHandlesV4X25519ECDHPubkey = do + let pkp = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( ECDHPubKey + ( EdDSAPubKey + EdSigningCurve25519 + ( PrefixedNativeEPoint + (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01)))) + ) + ) + SHA256 + AES128 + ) + encodedSecret = runPut (put (MPI 42)) + case runGetOrFail (getSecretKey pkp) encodedSecret of + Left (_, _, err) -> + assertFailure + ( "getSecretKey should parse v4 X25519 secret key material: " + ++ err + ) + Right (_, _, ECDHPrivateKey (ECDSA_PrivateKey prv)) -> + assertEqual + "getSecretKey should preserve X25519 private scalar" + 42 + (ECDSA.private_d prv) + Right (_, _, other) -> + assertFailure + ("unexpected parsed secret key type: " ++ show other) + +testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte + :: Assertion +testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte = do + let secretBytes = B.pack (0 : replicate 31 1) + pkt = + SecretKeyPkt + ( PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + ( EdDSAPubKey + EdSigningCurve25519 + ( PrefixedNativeEPoint + (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01)))) + ) + ) + ) + (SUUnencrypted (EdDSAPrivateKey EdSigningCurve25519 secretBytes) 0) + case runGetOrFail (get :: Get Pkt) (runPut (put pkt)) of + Left (_, _, err) -> + assertFailure + ("v4 Ed25519 secret key should round-trip: " ++ err) + Right (_, _, parsedPkt) -> + case parsedPkt of + SecretKeyPkt + _ + (SUUnencrypted (EdDSAPrivateKey EdSigningCurve25519 parsedBytes) _) -> + assertEqual + "v4 Ed25519 secret-key round-trip should preserve MPI-encoded bytes" + secretBytes + parsedBytes + _ -> + assertFailure + ("unexpected parsed packet shape: " ++ show parsedPkt) + +testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte + :: Assertion +testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte = do + let secretBytes = B.pack (0 : replicate 56 2) + pkp = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + ( EdDSAPubKey + EdSigningCurve448 + ( PrefixedNativeEPoint + (EPoint (os2ip (B.cons 0x40 (B.replicate 57 0x02)))) + ) + ) + encodedSecret = runPut (put (MPI (os2ip secretBytes))) + case runGetOrFail (getSecretKey pkp) encodedSecret of + Left (_, _, err) -> + assertFailure + ( "v4 Ed448 secret key should parse with preserved padding: " + ++ err + ) + Right (_, _, parsedSecret) -> + assertEqual + "v4 Ed448 secret-key parsing should restore the curve-width byte string" + (EdDSAPrivateKey EdSigningCurve448 secretBytes) + parsedSecret + +testMkUnencryptedSKAddendumComputesLegacyChecksum :: Assertion +testMkUnencryptedSKAddendumComputesLegacyChecksum = do + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" + DC..| conduitGet get + DC..| CL.consume + case packets of + (SecretKeyPkt pkp (SUUnencrypted sk _) : _) -> + case mkUnencryptedSKAddendum pkp sk of + Left err -> + assertFailure + ("mkUnencryptedSKAddendum should succeed for fixture key: " ++ err) + Right (SUUnencrypted _ actualChecksum) -> do + skPayload <- + case putSKeyForPKPayload pkp sk of + Left err -> + assertFailure + ( "failed to serialize secret key payload for checksum expectation: " + ++ err + ) + >> fail "expected serializable secret key payload" + Right payload -> pure payload + let expectedChecksum = + fromIntegral + ( BL.foldl' + (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) + 0 + (runPut skPayload) + :: Integer + ) + assertEqual + "mkUnencryptedSKAddendum should use OpenPGP 16-bit checksum over serialized key material" + expectedChecksum + actualChecksum + Right other -> + assertFailure ("unexpected addendum constructor: " ++ show other) + _ -> + assertFailure + "unencrypted.seckey did not begin with an unencrypted secret key packet" + +testMkUnencryptedSKAddendumUsesV6ChecksumConvention :: Assertion +testMkUnencryptedSKAddendumUsesV6ChecksumConvention = do + (pkp, rsaPrivateKey) <- loadUnencryptedRsaSignerV6 + case mkUnencryptedSKAddendum + pkp + (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) of + Left err -> + assertFailure + ("mkUnencryptedSKAddendum should support v6 key payloads: " ++ err) + Right (SUUnencrypted _ checksum) -> + assertEqual + "v6 unencrypted addendum checksum should be zero" + 0 + checksum + Right other -> + assertFailure ("unexpected addendum constructor: " ++ show other) + +testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA :: Assertion +testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA = do + let secretBytes = B.pack (0 : replicate 31 1) + pkp = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + ( EdDSAPubKey + EdSigningCurve25519 + ( PrefixedNativeEPoint + (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01)))) + ) + ) + unknown = UnknownSKey (runPut (put (MPI (os2ip secretBytes)))) + case reinterpretUnknownSKeyForPKPayload pkp unknown of + Left err -> + assertFailure + ( "reinterpretUnknownSKeyForPKPayload should decode Ed25519 key: " + ++ err + ) + Right skey -> + assertEqual + "reinterpretUnknownSKeyForPKPayload should return typed EdDSA secret key" + (EdDSAPrivateKey EdSigningCurve25519 secretBytes) + skey + +testFromPrimaryKeyPktToTKUnknownRejectsSubkey :: Assertion +testFromPrimaryKeyPktToTKUnknownRejectsSubkey = do + packets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" + DC..| conduitGet get + DC..| CL.consume + case packets of + (SecretKeyPkt pkp _ : _) -> + case fromPrimaryKeyPktToTKUnknown (PublicSubkeyPkt pkp) of + Left err -> + assertBool + "fromPrimaryKeyPktToTKUnknown should report non-primary packet tags" + ("expected primary key packet" `isInfixOf` err) + Right _ -> + assertFailure + "fromPrimaryKeyPktToTKUnknown should reject subkey packets" + _ -> + assertFailure + "unencrypted.seckey did not begin with a secret key packet" diff --git a/tests/Tests/MessageAndArmor.hs b/tests/Tests/MessageAndArmor.hs --- a/tests/Tests/MessageAndArmor.hs +++ b/tests/Tests/MessageAndArmor.hs @@ -2,1940 +2,2640 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Tests.MessageAndArmor (messageAndArmorTests) where - -import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..)) -import Codec.Encryption.OpenPGP.BlockCipher (keySize) -import Codec.Encryption.OpenPGP.CFB (decryptPreservingNonce, validateSEIPD1MDC) -import Codec.Encryption.OpenPGP.Encrypt (encryptSEIPDv2WithSKESKBlock) -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) -import Codec.Encryption.OpenPGP.Internal (emptyPSC, lastLD) -import Codec.Encryption.OpenPGP.KeyringParser (parseUnknownTKs) -import Codec.Encryption.OpenPGP.Message -import Codec.Encryption.OpenPGP.Policy (signatureV6SaltSizeForHashAlgorithm) -import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key) -import Codec.Encryption.OpenPGP.Serialize - ( armorPayloadsOfType - , parsePkts - , parsePktsEither - , recommendedArmorType - , singleClearSignedBlock - , singleArmorPayloadOfType - ) -import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig, payloadForSigWith) -import Codec.Encryption.OpenPGP.Signatures - ( renderSignError - , renderVerificationError - , signCertRevocationWithRSA - , signCertificationWithRSA - , signDataWithEd25519 - , signDataWithEd25519V6 - , signDataWithEd448 - , signDataWithEd448V6 - , signDataWithRSA - , signDataWithRSABuilder - , signDataWithEd25519Builder - , signDataWithEd25519V6Builder - , signDirectKeyWithRSA - , signKeyRevocationWithRSA - , signSubkeyRevocationWithRSA - , SignError(..) - , verifyAgainstKeyring - , verifyAgainstKeys - , verifySigWith - , VerificationError(..) - ) -import Codec.Encryption.OpenPGP.Subpackets - ( addHashedSubs - , addUnhashedSubs - , listToHashedSubs - , listToUnhashedSubs - , sbTextNormMode - , sigBuilderInit - , TextNormalizationMode(..) - ) -import Codec.Encryption.OpenPGP.Types -import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA -import qualified Crypto.PubKey.RSA as RSA -import qualified Crypto.PubKey.Ed25519 as Ed25519 -import Data.Binary (get, put) -import Data.Binary.Get (Get, runGetOrFail) -import Data.Binary.Put (putByteString, putWord16be, putWord32be, putWord8, runPut) -import Data.Bits (xor) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Conduit.OpenPGP.Message (verifyMessage, verifyMessagePackets) -import Data.Conduit.OpenPGP.Verify (VerificationMode(..)) -import Data.Either (isLeft, isRight) -import Data.List (isInfixOf) -import qualified Data.List.NonEmpty as NE -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) -import Tests.Common - ( addTimestampSeconds - , assertSingleFailureContainsTimeline - , assertSingleSignerFingerprint - , encryptMessageDefault - , expectV4PKPayload - , expectV6PKPayload - , extractV4SignatureAlgorithmFields - , fp - , loadAndDecompressPkts - , loadArmor - , loadKeyring - , loadDeterministicEd25519Signer - , loadDeterministicEd25519SignerV6 - , loadDeterministicEd448Signer - , loadDeterministicEd448SignerV6 - , loadUnencryptedRsaSigner - , loadUnencryptedRsaSignerV6 - , messageIssuerSubpacketsAt - , mkTestKeyring - , readFixtureLazy - , setPKAlgorithm - , signBinaryMessageWithRSAAt - , signBinaryMessageWithEd25519At - , signKeyRevocationWithReasonAt - , signKeyRevocationWithReasonAndExtrasAt - , signSubkeyBindingWithRSAAt - , signSubkeyRevocationWithRSAAt - , verifyTimelinePackets - ) - -messageAndArmorTests :: TestTree -messageAndArmorTests = - testGroup - "Message API and armor fixtures" - [ testGroup - "Message API group" - [ testCase "default encrypt/decrypt message" testDefaultedEncryptDecrypt - , testCase "specific encrypt/decrypt message" testExplicitEncryptDecrypt - , testCase - "specific encrypt can expose effective session material" - testExplicitEncryptExposesEffectiveSessionMaterial - , testCase - "default encrypt does not expose session material" - testDefaultEncryptDoesNotExposeSessionMaterial - , testCase "AES-128 EAX encrypt/decrypt message" testExplicitAES128EAXEncryptDecrypt - , testCase "AES-128 GCM encrypt/decrypt message" testExplicitAES128GCMEncryptDecrypt - , testCase - "specific encrypt rejects deprecated S2K hash in modern mode" - testExplicitEncryptRejectsDeprecatedS2KHash - , testCase "legacy fallback encrypt/decrypt message" testLegacyFallbackEncryptDecrypt - , testCase - "RFC4880 encryptMessage SEIPDv1 cleartext parses without trailing junk" - testRFC4880EncryptMessageSEIPDv1ParsesCleanly - , testCase "decryptMessage returns typed parse failures" testDecryptMessageTypedParseFailure - , testCase - "decryptMessage rejects unknown critical packets" - testDecryptMessageRejectsUnknownCriticalPacket - , testCase "decryptMessage returns typed decrypt failures" testDecryptMessageTypedDecryptFailure - , testCase - "decryptMessage rejects SEIPDv1 MDC tampering" - testDecryptMessageSEIPDv1MDCTampering - , testCase "sign message shape" testSignMessageShape - , testCase "sign message shape (RSA SigV6)" testSignMessageRSAV6 - , testCase "sign message shape (Ed25519)" testSignMessageEd25519 - , testCase "sign message shape (Ed25519 SigV6)" testSignMessageEd25519V6 - , testCase "sign message shape (Ed448)" testSignMessageEd448 - , testCase "sign message shape (Ed448 SigV6)" testSignMessageEd448V6 - , testCase - "v4 Ed25519/Ed448 signatures use native fixed-width encoding" - testV4EdSignaturesUseNativeFixedWidthEncoding - , testCase - "v4 Ed25519Legacy key parsing rejects missing 0x40 prefix" - testV4Ed25519LegacyKeyRejectsMissingPrefix - , testCase - "detached v4 Ed25519 verification tolerates missing issuer hints" - testVerifyDetachedEd25519WithoutIssuerHints - , testCase - "detached v4 Ed25519 verification tolerates fake issuer hints" - testVerifyDetachedEd25519WithFakeIssuerHint - , testCase - "detached v4 Ed25519 verifyAgainstKeys tolerates missing issuer hints" - testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys - , testCase - "detached v4 Ed25519 verifyAgainstKeys tolerates fake issuer hints" - testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys - , testCase - "v4 EdDSA signatures verify with Ed25519 key algorithm identifier" - testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm - , testCase "sign message convenience API" testSignMessageConvenience - , testCase "typed verify surface matches legacy results" testTypedVerifySurfaceMatchesLegacy - , testCase "strict typed verify rejects tamper" testVerifyMessageStrictRejectsTamper - , testCase "verifySignedMessage convenience API" testVerifySignedMessageConvenience - , testCase "signature generation primitives" testSignaturePrimitives - , testCase - "typed signature payload coercions" - testSignatureDataKindsCoercions - , testCase - "typed armor payload helpers centralize block selection" - testTypedArmorPayloadHelpers - , testCase - "recommendedArmorType infers canonical armor labels from packets" - testRecommendedArmorType - , testCase - "singleClearSignedBlock validates cleartext signature envelopes" - testSingleClearSignedBlock - , testCase - "canonical text signature payload normalization" - testCanonicalTextSigPayloadNormalization - , testCase - "canonical text signatures normalize during signing" - testCanonicalTextSignatureSigningPaths - , testCase - "text normalization modes (RFC9580Strict vs CleartextCompat)" - testTextNormalizationModes - ] - , testGroup - "ASCII armor fixture group" - [ testCase - "v4-encrypted-secret.pgp.aa decodes as an encrypted v4 secret key" - testV4EncryptedSecretArmor - , testCase - "v4-encrypted.rev.aa decodes as a v4 revocation certificate" - testV4EncryptedRevocationArmor - , testCase - "v4-encrypted.rev.aa SigV4 key-revocation semantics" - testV4RevocationSignatureSemantics - , testCase - "v4-encrypted.rev.aa parses as single revocation TKUnknown" - (testRevocationArmorParsesAsSingleTransferableKey "v4-encrypted.rev.aa" True) - , testCase - "v6.rev.aa decodes as a v6 revocation certificate" - (testV6RevocationArmor "v6.rev.aa") - , testCase - "v6.rev.aa SigV6 salt semantics" - (testV6RevocationSignatureSaltSemantics "v6.rev.aa") - , testCase - "v6.rev.aa forbids legacy Issuer key-id subpackets" - (testV6RevocationSignatureRejectsLegacyIssuerKeyID "v6.rev.aa") - , testCase - "v6.rev.aa parses as single revocation TKUnknown" - (testRevocationArmorParsesAsSingleTransferableKey "v6.rev.aa" True) - , testCase - "v6-encrypted.rev.aa decodes as a v6 revocation certificate" - (testV6RevocationArmor "v6-encrypted.rev.aa") - , testCase - "v6-encrypted.rev.aa SigV6 salt semantics" - (testV6RevocationSignatureSaltSemantics "v6-encrypted.rev.aa") - , testCase - "v6-encrypted.rev.aa forbids legacy Issuer key-id subpackets" - (testV6RevocationSignatureRejectsLegacyIssuerKeyID "v6-encrypted.rev.aa") - , testCase - "v6-encrypted.rev.aa parses as single revocation TKUnknown" - (testRevocationArmorParsesAsSingleTransferableKey "v6-encrypted.rev.aa" True) - , testCase - "msg1.asc decodes as a parseable armored message" - testMsg1ArmorFixture - ] - , testGroup - "timeline-aware group" - [ testCase - "timeline-aware primary soft revocation keeps pre-revocation signatures" - testSignerTimelineSoftPrimaryRevocation - , testCase - "timeline-aware primary hard revocation rejects historical signatures" - testSignerTimelineHardPrimaryRevocation - , testCase - "timeline-aware no-reason primary revocation rejects historical signatures" - testSignerTimelineNoReasonPrimaryRevocation - , testCase - "timeline-aware unknown-reason primary revocation rejects historical signatures" - testSignerTimelineUnknownReasonPrimaryRevocation - , testCase - "timeline-aware non-compromise primary revocation stays historical until effective" - testSignerTimelineNonCompromisePrimaryRevocationIsHistorical - , testCase - "timeline-aware temporary primary revocation expires and restores validity" - testSignerTimelineTemporaryPrimaryRevocationExpires - , testCase - "timeline-aware subkey revocation distinguishes pre/post signatures" - testSignerTimelineSubkeyRevocation - ] - ] - -testV4EncryptedSecretArmor :: Assertion -testV4EncryptedSecretArmor = do - armors <- loadArmor "v4-encrypted-secret.pgp.aa" - armor <- - case armors of - [a] -> pure a - _ -> - assertFailure "v4 encrypted secret fixture should contain one armored payload" >> - fail "expected one armored payload" - (headers, payload) <- - case armor of - Armor ArmorPrivateKeyBlock hs p -> pure (hs, p) - Armor atype _ _ -> - assertFailure - ("v4 encrypted secret fixture should decode as a private key block, got " ++ - show atype) >> - fail "expected private key block" - _ -> - assertFailure "v4 encrypted secret fixture should decode as an armored payload" >> - fail "expected armored payload" - assertEqual - "v4 encrypted secret fixture should keep identifying comments" - [ ("Comment", "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") - , ("Comment", "") - , ("Comment", "v4 Test User") - ] - headers - let packets = parsePkts payload - userIds = [u | UserIdPkt u <- packets] - primarySecretKeys = [(pkp, ska) | SecretKeyPkt pkp ska <- packets] - secretSubkeys = [(pkp, ska) | SecretSubkeyPkt pkp ska <- packets] - assertEqual - "v4 encrypted secret fixture should include expected user IDs" - ["", "v4 Test User"] - userIds - assertEqual - "v4 encrypted secret fixture should contain one primary secret key packet" - 1 - (length primarySecretKeys) - assertEqual - "v4 encrypted secret fixture should contain three encrypted secret subkeys" - 3 - (length secretSubkeys) - case packets of - (SecretKeyPkt pkp ska:_) -> do - assertEqual - "v4 encrypted secret fixture should contain a v4 primary key" - V4 - (_keyVersion pkp) - assertEqual - "v4 encrypted secret fixture should have the expected primary-key fingerprint" - (fp "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") - (fingerprint pkp) - assertEqual - "v4 encrypted secret fixture should use EdDSA for its primary key" - EdDSA - (_pkalgo pkp) - assertEncryptedS2K "primary key" ska - mapM_ (assertEncryptedS2K "subkey" . snd) secretSubkeys - assertEqual - "v4 encrypted secret fixture should contain two EdDSA subkeys and one ECDH subkey" - [EdDSA, EdDSA, ECDH] - (map (_pkalgo . fst) secretSubkeys) - _ -> assertFailure "v4 encrypted secret fixture should start with a secret key packet" - where - assertEncryptedS2K :: String -> SKAddendum -> Assertion - assertEncryptedS2K testLabel ska = - case ska of - SUSSHA1 AES256 (IteratedSalted SHA256 _ iter) _ encryptedPayload -> do - assertEqual - (testLabel ++ " should use expected S2K iteration count") - (IterationCount 65011712) - iter - if BL.null encryptedPayload - then assertFailure (testLabel ++ " should have non-empty encrypted key material") - else pure () - SUUnencrypted _ _ -> - assertFailure (testLabel ++ " should be encrypted, got unencrypted secret material") - _ -> - assertFailure - (testLabel ++ " should be encrypted with SUSSHA1/AES256/IteratedSalted SHA256") - -testV4EncryptedRevocationArmor :: Assertion -testV4EncryptedRevocationArmor = do - armors <- loadArmor "v4-encrypted.rev.aa" - armor <- - case armors of - [a] -> pure a - _ -> - assertFailure "v4 encrypted revocation fixture should contain one armored payload" >> - fail "expected one armored payload" - (headers, payload) <- - case armor of - Armor ArmorPublicKeyBlock hs p -> pure (hs, p) - Armor atype _ _ -> - assertFailure - ("v4 encrypted revocation fixture should decode as a public key block, got " ++ - show atype) >> - fail "expected public key block" - _ -> - assertFailure - "v4 encrypted revocation fixture should decode as an armored payload" >> - fail "expected armored payload" - assertEqual - "v4 encrypted revocation fixture should keep identifying comments" - [ ("Comment", "Revocation certificate for") - , ("Comment", "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") - , ("Comment", "") - , ("Comment", "v4 Test User") - ] - headers - let packets = parsePkts payload - case packets of - [PublicKeyPkt pkp, SignaturePkt _] -> do - assertEqual - "v4 encrypted revocation fixture should contain a v4 public key" - V4 - (_keyVersion pkp) - assertEqual - "v4 encrypted revocation fixture should contain the expected public key fingerprint" - (fp "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") - (fingerprint pkp) - assertEqual - "v4 encrypted revocation fixture should use EdDSA for its public key" - EdDSA - (_pkalgo pkp) - _ -> - assertFailure - ("v4 encrypted revocation fixture should contain [PublicKeyPkt, SignaturePkt], got: " ++ - show packets) - -testV6RevocationArmor :: FilePath -> Assertion -testV6RevocationArmor fixture = do - armors <- loadArmor fixture - armor <- - case armors of - [a] -> pure a - _ -> - assertFailure (fixture ++ " fixture should contain one armored payload") >> - fail "expected one armored payload" - payload <- - case armor of - Armor ArmorPublicKeyBlock _ p -> pure p - Armor atype _ _ -> - assertFailure - (fixture ++ " fixture should decode as a public key block, got " ++ show atype) >> - fail "expected public key block" - _ -> - assertFailure (fixture ++ " fixture should decode as an armored payload") >> - fail "expected armored payload" - let packets = parsePkts payload - case packets of - [PublicKeyPkt pkp, SignaturePkt sig] -> do - assertEqual - (fixture ++ " should contain a v6 public key") - V6 - (_keyVersion pkp) - case sig of - SigV6 KeyRevocationSig _ _ _ hashed unhashed _ _ -> do - let issuerFps = - [ ifp - | SigSubPacket _ (IssuerFingerprint IssuerFingerprintV6 ifp) <- hashed ++ unhashed - ] - if fingerprint pkp `elem` issuerFps - then pure () - else - assertFailure - (fixture ++ " should include an IssuerFingerprint v6 matching the public key") - _ -> - assertFailure - (fixture ++ " should contain a SigV6 key-revocation signature") - _ -> - assertFailure - (fixture ++ " should contain [PublicKeyPkt, SignaturePkt], got: " ++ - show packets) - -testV6RevocationSignatureSaltSemantics :: FilePath -> Assertion -testV6RevocationSignatureSaltSemantics fixture = do - armors <- loadArmor fixture - payload <- - case armors of - [Armor ArmorPublicKeyBlock _ p] -> pure p - _ -> - assertFailure - (fixture ++ " should contain one armored public-key payload") >> - fail "expected one armored payload" - let packets = parsePkts payload - (pkp, sig) <- - case packets of - [PublicKeyPkt pk, SignaturePkt sigV6@(SigV6 _ _ _ _ _ _ _ _)] -> pure (pk, sigV6) - _ -> - assertFailure - (fixture ++ " should parse as [PublicKeyPkt, SignaturePkt SigV6], got " ++ show packets) >> - fail "unexpected revocation fixture packet shape" - case sig of - SigV6 _ _ ha salt _ _ _ _ -> - case expectedV6SaltSizeForTest ha of - Nothing -> - assertFailure - (fixture ++ " uses unsupported v6 signature salt hash algorithm: " ++ show ha) - Just expected -> - assertEqual - (fixture ++ " SigV6 salt size should match hash algorithm") - expected - (fromIntegral (BL.length (unSignatureSalt salt))) - other -> - assertFailure - (fixture ++ " expected SigV6 revocation signature payload, got: " ++ show other) - assertBool - (fixture ++ " should include IssuerFingerprint v6 for the revoked key") - (signatureHasIssuerFingerprintV6 (fingerprint pkp) sig) - -testV4RevocationSignatureSemantics :: Assertion -testV4RevocationSignatureSemantics = do - armors <- loadArmor "v4-encrypted.rev.aa" - payload <- - case armors of - [Armor ArmorPublicKeyBlock _ p] -> pure p - _ -> - assertFailure - "v4-encrypted.rev.aa should contain one armored public-key payload" >> - fail "expected one armored payload" - let packets = parsePkts payload - case packets of - [PublicKeyPkt _, SignaturePkt (SigV4 KeyRevocationSig _ _ hashed unhashed _ _)] -> do - assertBool - "v4-encrypted.rev.aa key-revocation signature should include an Issuer key-id subpacket" - (any isIssuerSubpacket (hashed ++ unhashed)) - _ -> - assertFailure - ("v4-encrypted.rev.aa should parse as [PublicKeyPkt, SignaturePkt SigV4 KeyRevocationSig], got " ++ - show packets) - where - isIssuerSubpacket (SigSubPacket _ Issuer {}) = True - isIssuerSubpacket _ = False - -testV6RevocationSignatureRejectsLegacyIssuerKeyID :: FilePath -> Assertion -testV6RevocationSignatureRejectsLegacyIssuerKeyID fixture = do - armors <- loadArmor fixture - payload <- - case armors of - [Armor ArmorPublicKeyBlock _ p] -> pure p - _ -> - assertFailure - (fixture ++ " should contain one armored public-key payload") >> - fail "expected one armored payload" - let packets = parsePkts payload - case packets of - [PublicKeyPkt _, SignaturePkt (SigV6 KeyRevocationSig _ _ _ hashed unhashed _ _)] -> - assertBool - (fixture ++ " SigV6 key-revocation signature must not include Issuer key-id subpackets") - (all (not . isIssuerSubpacket) (hashed ++ unhashed)) - _ -> - assertFailure - (fixture ++ - " should parse as [PublicKeyPkt, SignaturePkt SigV6 KeyRevocationSig]") - where - isIssuerSubpacket (SigSubPacket _ Issuer {}) = True - isIssuerSubpacket _ = False - -testRevocationArmorParsesAsSingleTransferableKey :: FilePath -> Bool -> Assertion -testRevocationArmorParsesAsSingleTransferableKey fixture expectDirectRevs = do - armors <- loadArmor fixture - payload <- - case armors of - [Armor ArmorPublicKeyBlock _ p] -> pure p - _ -> - assertFailure - (fixture ++ " should contain one armored public-key payload") >> - fail "expected one armored payload" - let tks = parseUnknownTKs True (parsePkts payload) - case tks of - [tk] -> do - if expectDirectRevs - then - assertBool - (fixture ++ " transferable key should contain at least one direct-key revocation signature") - (not (null (_tkuRevs tk))) - else pure () - assertEqual - (fixture ++ " revocation certificate should not carry user IDs") - [] - (_tkuUIDs tk) - assertEqual - (fixture ++ " revocation certificate should not carry user attributes") - [] - (_tkuUAts tk) - assertEqual - (fixture ++ " revocation certificate should not carry subkeys") - [] - (_tkuSubs tk) - _ -> - assertFailure - (fixture ++ " should parse into exactly one transferable key") - -testMsg1ArmorFixture :: Assertion -testMsg1ArmorFixture = do - armors <- loadArmor "msg1.asc" - assertBool "msg1.asc should decode to at least one armor block" (not (null armors)) - let packetBlocks = - [ parsePkts payload - | Armor _ _ payload <- armors - ] - assertBool - "msg1.asc should contain at least one parseable packet block" - (any (not . null) packetBlocks) - -expectedV6SaltSizeForTest :: HashAlgorithm -> Maybe Int -expectedV6SaltSizeForTest = - fmap fromIntegral . signatureV6SaltSizeForHashAlgorithm - -signatureHasIssuerFingerprintV6 :: Fingerprint -> SignaturePayload -> Bool -signatureHasIssuerFingerprintV6 expectedFp (SigV6 _ _ _ _ hashed unhashed _ _) = - expectedFp `elem` - [ ifp - | SigSubPacket _ (IssuerFingerprint IssuerFingerprintV6 ifp) <- hashed ++ unhashed - ] -signatureHasIssuerFingerprintV6 _ _ = False - -testDefaultedEncryptDecrypt :: Assertion -testDefaultedEncryptDecrypt = do - let passphrase = mkPassphrase "roundtrip1" - payload = mkClearPayload "hello from a balloon farm on Mars" - encryptedResult = encryptMessageDefault DoNotExposeSessionMaterial passphrase payload - encrypted <- - case encryptedResult of - Left err -> - assertFailure ("encryptMessageDefault failed: " ++ show err) >> - fail "encryptMessageDefault failed" - Right (bs, _) -> pure bs - case parsePkts (encryptedPayloadBytes encrypted) of - [SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 AES256 OCB _ iv esk tag)), SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 _ _)] -> do - assertBool "default SKESK v6 IV should be present" (not (BL.null iv)) - assertBool "default SKESK v6 wrapped session key should be present" (not (BL.null esk)) - assertEqual "default SKESK v6 tag length" 16 (BL.length tag) - other -> - assertFailure - ("default encryption should emit SKESK v6 + SEIPD v2 packets, got " ++ - show other) - decrypted <- - case decryptMessage passphrase encrypted of - Left err -> - assertFailure ("decryptMessage failed: " ++ show err) >> fail "decryptMessage failed" - Right bs -> pure bs - assertEqual "default encrypt/decrypt payload roundtrip" payload decrypted - -testExplicitEncryptDecrypt :: Assertion -testExplicitEncryptDecrypt = do - let passphrase = mkPassphrase "roundtrip2" - payload = mkClearPayload "hello from nonsenseville" - s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 - iv = IV "1234567890ABCDEF" - encrypted <- - case - encryptMessage - (RFC9580EncryptMessageOptions - { rfc9580EncryptMessageExposure = DoNotExposeSessionMaterial - , rfc9580EncryptMessageSymmetricAlgorithm = AES128 - , rfc9580EncryptMessageS2K = s2k - , rfc9580EncryptMessageIV = iv - }) - passphrase - payload of - Left err -> - assertFailure ("micro-managed encryption failed: " ++ show err) >> - fail "encryptMessage failed" - Right (bs, _) -> pure bs - case parsePkts (encryptedPayloadBytes encrypted) of - [SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 AES128 OCB _ packetIv esk tag)), SymEncIntegrityProtectedDataPkt (SEIPD2 AES128 OCB 6 _ _)] -> do - assertBool "explicit SKESK v6 IV should be present" (not (BL.null packetIv)) - assertBool "explicit SKESK v6 wrapped session key should be present" (not (BL.null esk)) - assertEqual "explicit SKESK v6 tag length" 16 (BL.length tag) - other -> - assertFailure - ("explicit AES encryption should default to SKESK v6 + SEIPD v2 packets, got " ++ - show other) - decrypted <- - case decryptMessage passphrase encrypted of - Left err -> - assertFailure ("decryption failed: " ++ show err) >> fail "decryptMessage failed" - Right bs -> pure bs - assertEqual "specific encrypt/decrypt payload roundtrip" payload decrypted - -testExplicitEncryptExposesEffectiveSessionMaterial :: Assertion -testExplicitEncryptExposesEffectiveSessionMaterial = do - let passphraseBytes = "roundtrip2-session-material" - passphrase = mkPassphrase passphraseBytes - payload = mkClearPayload "hello from session material town" - sa = AES128 - s2k = Argon2 (Salt16 (B.pack [0x40 .. 0x4f])) 1 4 15 - iv = IV "ABCDEF1234567890" - (encrypted, recovered) <- - case - encryptMessage - (RFC9580EncryptMessageOptions - { rfc9580EncryptMessageExposure = ExposeSessionMaterial - , rfc9580EncryptMessageSymmetricAlgorithm = sa - , rfc9580EncryptMessageS2K = s2k - , rfc9580EncryptMessageIV = iv - }) - passphrase - payload of - Left err -> - assertFailure ("explicit encryption with session material failed: " ++ show err) >> - fail "encryptMessage failed" - Right x -> pure x - expectedSessionKey <- - case keySize sa of - Left err -> - assertFailure ("failed to derive expected key size: " ++ show err) >> - fail "keySize failed" - Right keyLen -> - case string2Key s2k keyLen passphraseBytes of - Left err -> - assertFailure ("failed to derive expected session key: " ++ renderS2KError err) >> - fail "string2Key failed" - Right bs -> pure bs - case recovered of - Just recoveredSessionMaterial -> do - assertEqual "recovered session material algorithm" sa (recoveredSessionAlgorithm recoveredSessionMaterial) - assertEqual - "recovered session material key" - (SessionKey expectedSessionKey) - (recoveredSessionKey recoveredSessionMaterial) - Nothing -> - assertFailure "expected exposed session material" - decrypted <- - case decryptMessage passphrase encrypted of - Left err -> - assertFailure ("decryption failed: " ++ show err) >> fail "decryptMessage failed" - Right bs -> pure bs - assertEqual "session-material exposing encrypt/decrypt payload roundtrip" payload decrypted - -testDefaultEncryptDoesNotExposeSessionMaterial :: Assertion -testDefaultEncryptDoesNotExposeSessionMaterial = do - let passphrase = mkPassphrase "roundtrip-default-no-session-material" - payload = mkClearPayload "hello from hidden-session-material town" - (_, recovered) <- - do - let encryptedResult = - encryptMessageDefault DoNotExposeSessionMaterial passphrase payload - case encryptedResult of - Left err -> - assertFailure ("default encryption with exposure mode failed: " ++ show err) >> - fail "encryptMessageDefault failed" - Right x -> pure x - case recovered of - Nothing -> pure () - Just _ -> assertFailure "default exposure mode should not return session material" - -testExplicitAES128AEADEncryptDecrypt :: AEADAlgorithm -> Int -> String -> Assertion -testExplicitAES128AEADEncryptDecrypt aead expectedIvLen label = do - let passphraseBytes = "roundtrip-" <> BL.fromStrict (B.pack (map (fromIntegral . fromEnum) label)) - passphrase = mkPassphrase passphraseBytes - payload = mkClearPayload ("hello from " <> BL.fromStrict (B.pack (map (fromIntegral . fromEnum) label))) - s2k = Argon2 (Salt16 (B.pack [0x10 .. 0x1f])) 1 4 15 - salt = Salt (B.pack [0x20 .. 0x3f]) - block = Block [LiteralDataPkt BinaryData BL.empty 0 (clearPayloadBytes payload)] - packets <- - case encryptSEIPDv2WithSKESKBlock AES128 aead 6 salt s2k passphraseBytes block of - Left err -> - assertFailure ("AES-128 " ++ label ++ " encryption failed: " ++ err) >> - fail "encryptSEIPDv2WithSKESKBlock failed" - Right ps -> pure ps - let encrypted = mkEncryptedPayload (runPut (put (Block packets))) - case parsePkts (encryptedPayloadBytes encrypted) of - [SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 AES128 parsedAead _ iv esk tag)), SymEncIntegrityProtectedDataPkt (SEIPD2 AES128 payloadAead 6 _ _)] -> do - assertEqual ("AES-128 " ++ label ++ " SKESK AEAD") aead parsedAead - assertEqual ("AES-128 " ++ label ++ " payload AEAD") aead payloadAead - assertEqual - ("AES-128 " ++ label ++ " SKESK v6 IV length") - (fromIntegral expectedIvLen) - (BL.length iv) - assertBool ("AES-128 " ++ label ++ " wrapped session key should be present") (not (BL.null esk)) - assertEqual ("AES-128 " ++ label ++ " SKESK tag length") 16 (BL.length tag) - other -> - assertFailure - ("AES-128 " ++ label ++ " encryption should emit matching SKESK v6 + SEIPD v2 packets, got " ++ - show other) - decrypted <- - case decryptMessage passphrase encrypted of - Left err -> - assertFailure ("AES-128 " ++ label ++ " decryption failed: " ++ show err) >> - fail "decryptMessage failed" - Right bs -> pure bs - assertEqual ("AES-128 " ++ label ++ " payload roundtrip") payload decrypted - -testExplicitAES128EAXEncryptDecrypt :: Assertion -testExplicitAES128EAXEncryptDecrypt = do - let passphraseBytes = "roundtrip-EAX" - s2k = Argon2 (Salt16 (B.pack [0x10 .. 0x1f])) 1 4 15 - salt = Salt (B.pack [0x20 .. 0x3f]) - block = Block [LiteralDataPkt BinaryData BL.empty 0 "hello from EAX"] - case encryptSEIPDv2WithSKESKBlock AES128 EAX 6 salt s2k passphraseBytes block of - Left err - | "EAX is currently unsupported by the crypton AEAD backend" `isInfixOf` err -> - pure () - | otherwise -> - assertFailure ("expected explicit EAX backend limitation, got: " ++ err) - Right packets -> - assertFailure - ("expected AES-128 EAX encryption to fail explicitly, got packets: " ++ show packets) - -testExplicitAES128GCMEncryptDecrypt :: Assertion -testExplicitAES128GCMEncryptDecrypt = - testExplicitAES128AEADEncryptDecrypt GCM 12 "GCM" - -testExplicitEncryptRejectsDeprecatedS2KHash :: Assertion -testExplicitEncryptRejectsDeprecatedS2KHash = do - let passphrase = mkPassphrase "roundtrip2b" - payload = mkClearPayload "modern-path deprecated s2k hash rejection" - s2k = Salted SHA1 (Salt8 "12345678") - iv = IV "1234567890ABCDEF" - case - encryptMessage - (RFC9580EncryptMessageOptions - { rfc9580EncryptMessageExposure = DoNotExposeSessionMaterial - , rfc9580EncryptMessageSymmetricAlgorithm = AES128 - , rfc9580EncryptMessageS2K = s2k - , rfc9580EncryptMessageIV = iv - }) - passphrase - payload of - Left (MessageEncryptError err) - | "deprecated hash algorithm disallowed for modern message generation" `isInfixOf` err -> - pure () - | otherwise -> - assertFailure ("Expected deprecated modern S2K hash rejection, got: " ++ err) - Left err -> - assertFailure ("Expected MessageEncryptError for deprecated modern S2K hash, got " ++ show err) - Right _ -> - assertFailure "Expected encryptMessage AES128 to reject deprecated SHA1 S2K" - -testLegacyFallbackEncryptDecrypt :: Assertion -testLegacyFallbackEncryptDecrypt = do - let passphrase = mkPassphrase "roundtrip3" - payload = mkClearPayload "hello from legacy town" - s2k = Salted SHA1 (Salt8 "12345678") - iv = IV mempty - encrypted <- - case - encryptMessage - (RFC4880EncryptMessageOptions - { rfc4880EncryptMessageExposure = DoNotExposeSessionMaterial - , rfc4880EncryptMessageSymmetricAlgorithm = Plaintext - , rfc4880EncryptMessageS2K = s2k - , rfc4880EncryptMessageIV = iv - }) - passphrase - payload of - Left err -> - assertFailure ("legacy fallback encryption failed: " ++ show err) >> - fail "encryptMessage fallback failed" - Right (bs, _) -> pure bs - case parsePkts (encryptedPayloadBytes encrypted) of - [SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 Plaintext _ Nothing)), SymEncIntegrityProtectedDataPkt (SEIPD1 1 _)] -> pure () - other -> - assertFailure - ("non-AES explicit encryption should use RFC4880 SKESKv4 + SEIPDv1 packets, got " ++ - show other) - decrypted <- - case decryptMessage passphrase encrypted of - Left err -> - assertFailure ("legacy fallback decryption failed: " ++ show err) >> - fail "decryptMessage fallback failed" - Right bs -> pure bs - assertEqual "legacy fallback encrypt/decrypt payload roundtrip" payload decrypted - -testRFC4880EncryptMessageSEIPDv1ParsesCleanly :: Assertion -testRFC4880EncryptMessageSEIPDv1ParsesCleanly = do - let passphraseBytes = "legacy-clean-parse" :: BL.ByteString - passphrase = mkPassphrase passphraseBytes - payload = mkClearPayload "hello from clean legacy town" - s2k = IteratedSalted SHA256 (Salt8 "saltxyz!") (IterationCount 65536) - iv = IV "1234567890ABCDEF" - encrypted <- - case - encryptMessage - (RFC4880EncryptMessageOptions - { rfc4880EncryptMessageExposure = DoNotExposeSessionMaterial - , rfc4880EncryptMessageSymmetricAlgorithm = AES128 - , rfc4880EncryptMessageS2K = s2k - , rfc4880EncryptMessageIV = iv - }) - passphrase - payload of - Left err -> - assertFailure ("RFC4880 encryption failed: " ++ show err) >> - fail "encryptMessage failed" - Right (bs, _) -> pure bs - packets <- - case parsePktsEither (encryptedPayloadBytes encrypted) of - Left err -> - assertFailure ("encrypted packet parse failed: " ++ show err) >> - fail "parsePktsEither failed" - Right ps -> pure ps - ciphertext <- - case packets of - [SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 parsedSA parsedS2K Nothing)), SymEncIntegrityProtectedDataPkt (SEIPD1 1 payloadBytes)] -> do - assertEqual "RFC4880 encrypted SKESK algorithm" AES128 parsedSA - assertEqual "RFC4880 encrypted S2K" s2k parsedS2K - pure (BL.toStrict payloadBytes) - other -> - assertFailure - ("RFC4880 encryption should emit SKESKv4 + SEIPDv1 packets, got " ++ - show other) >> - fail "unexpected encrypted packet layout" - keyLen <- - case keySize AES128 of - Left err -> - assertFailure ("keySize failed for AES128: " ++ show err) >> - fail "keySize failed" - Right n -> pure n - sessionKey <- - case string2Key s2k keyLen passphraseBytes of - Left err -> - assertFailure ("string2Key failed: " ++ renderS2KError err) >> - fail "string2Key failed" - Right keyBytes -> pure keyBytes - (nonce, decrypted) <- - case decryptPreservingNonce AES128 ciphertext sessionKey of - Left err -> - assertFailure ("decryptPreservingNonce failed: " ++ show err) >> - fail "decryptPreservingNonce failed" - Right out -> pure out - cleartext <- - case validateSEIPD1MDC nonce decrypted of - Left err -> - assertFailure ("validateSEIPD1MDC failed: " ++ err) >> - fail "validateSEIPD1MDC failed" - Right out -> pure out - case parsePktsEither (BL.fromStrict cleartext) of - Right [LiteralDataPkt BinaryData filename timestamp clearPayload] -> do - assertEqual "RFC4880 decrypted literal filename" BL.empty filename - assertEqual "RFC4880 decrypted literal timestamp" 0 timestamp - assertEqual "RFC4880 decrypted literal payload" (clearPayloadBytes payload) clearPayload - Right other -> - assertFailure - ("RFC4880 decrypted cleartext should contain exactly one literal packet, got " ++ - show other) - Left err -> - assertFailure - ("RFC4880 decrypted cleartext should parse without trailing junk, got " ++ - show err) - -testDecryptMessageTypedParseFailure :: Assertion -testDecryptMessageTypedParseFailure = do - let passphrase = mkPassphrase "unused" - encrypted = mkEncryptedPayload BL.empty - case decryptMessage passphrase encrypted of - Left (MessageParseFailureError MissingEncryptedMessage) -> pure () - Left err -> - assertFailure ("Expected MissingEncryptedMessage parse failure, got " ++ show err) - Right clear -> - assertFailure ("Expected parse failure, got payload " ++ show clear) - -testDecryptMessageRejectsUnknownCriticalPacket :: Assertion -testDecryptMessageRejectsUnknownCriticalPacket = do - let passphrase = mkPassphrase "unused" - encrypted = - mkEncryptedPayload . runPut . put $ - Block [OtherPacketPkt 39 "unknown-critical"] - case decryptMessage passphrase encrypted of - Left (MessageParseFailureError (UnknownCriticalPacketType 39)) -> pure () - Left err -> - assertFailure - ("Expected UnknownCriticalPacketType 39 parse failure, got " ++ show err) - Right clear -> - assertFailure - ("Expected unknown critical packet rejection, got payload " ++ show clear) - -testDecryptMessageTypedDecryptFailure :: Assertion -testDecryptMessageTypedDecryptFailure = do - let correctPassphrase = mkPassphrase "correct passphrase" - wrongPassphrase = mkPassphrase "wrong passphrase" - payload = mkClearPayload "typed decrypt failure payload" - encryptedResult = - encryptMessageDefault DoNotExposeSessionMaterial correctPassphrase payload - encrypted <- - case encryptedResult of - Left err -> - assertFailure ("encryptMessageDefault failed: " ++ show err) >> - fail "encryptMessageDefault failed" - Right (bs, _) -> pure bs - case decryptMessage wrongPassphrase encrypted of - Left (MessageDecryptFailureError (PayloadDecryptFailed _)) -> pure () - Left (MessageDecryptFailureError (SessionMaterialDerivationFailed _)) -> pure () - Left err -> - assertFailure ("Expected typed decrypt failure, got " ++ show err) - Right clear -> - assertFailure ("Expected decrypt failure, got payload " ++ show clear) - -testDecryptMessageSEIPDv1MDCTampering :: Assertion -testDecryptMessageSEIPDv1MDCTampering = do - let passphrase = mkPassphrase "mdc-tamper-test" - payload = mkClearPayload "payload for MDC tampering test" - s2k = IteratedSalted SHA256 (Salt8 "saltxyz!") (IterationCount 65536) - iv = IV "1234567890ABCDEF" - encrypted <- - case encryptMessage - (RFC4880EncryptMessageOptions - { rfc4880EncryptMessageExposure = DoNotExposeSessionMaterial - , rfc4880EncryptMessageSymmetricAlgorithm = AES128 - , rfc4880EncryptMessageS2K = s2k - , rfc4880EncryptMessageIV = iv - }) - passphrase - payload of - Left err -> - assertFailure ("SEIPDv1 encryption failed: " ++ show err) >> - fail "encryptMessage failed" - Right (bs, _) -> pure bs - let raw = encryptedPayloadBytes encrypted - midpoint = BL.length raw `div` 2 - tampered = BL.take midpoint raw <> - BL.cons (BL.head (BL.drop midpoint raw) `xor` 0xFF) - (BL.drop (midpoint + 1) raw) - case decryptMessage passphrase (mkEncryptedPayload tampered) of - Left (MessageDecryptFailureError (PayloadDecryptFailed msg)) - | "MDC" `isInfixOf` msg -> pure () - | otherwise -> - assertFailure - ("Expected MDC-related PayloadDecryptFailed, got: " ++ msg) - Left err -> - assertFailure - ("Expected PayloadDecryptFailed with MDC error, got: " ++ show err) - Right _ -> - assertFailure "Expected MDC tampering rejection, but decryption succeeded" - -testSignMessageShape :: Assertion -testSignMessageShape = do - (signer, signingKey) <- loadUnencryptedRsaSigner - signerV4 <- expectV4PKPayload "RSA v4 signer" signer - signedResult <- signMessageWith (mkRSASignerV4 signerV4 signingKey) (mkClearPayload "message-api signing payload") - signedMessage <- - case signedResult of - Left err -> - assertFailure ("message signing failed: " ++ show err) >> pure mempty - Right bs -> pure bs - case parsePkts signedMessage of - [LiteralDataPkt {}, SignaturePkt _] -> pure () - _ -> assertFailure "signing output should contain literal data and one signature packet" - -testSignMessageRSAV6 :: Assertion -testSignMessageRSAV6 = do - (signer, signingKey) <- loadUnencryptedRsaSignerV6 - signerV6 <- expectV6PKPayload "RSA v6 signer" signer - let payload = "message-api signing payload with RSA SigV6" - signedResult <- signMessageWith (mkRSASignerV6 signerV6 signingKey) (mkClearPayload payload) - signedMessage <- - case signedResult of - Left err -> - assertFailure ("RSA SigV6 message signing failed: " ++ show err) >> pure mempty - Right bs -> pure bs - signaturePkt <- - case parsePkts signedMessage of - [LiteralDataPkt {}, sig@(SignaturePkt (SigV6 BinarySig RSA SHA512 salt _ _ _ _))] -> do - assertEqual "SigV6 RSA salt must be 32 bytes for SHA512" 32 (BL.length (unSignatureSalt salt)) - pure sig - other -> - assertFailure - ("RSA SigV6 signing output should contain [LiteralDataPkt, RSA SigV6], got " ++ - show other) >> - fail "unexpected RSA SigV6 signMessage output shape" - let state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} - keyring = [TKUnknown (signer, Nothing) [] [] [] []] - case verifySigWith (verifyAgainstKeys keyring) signaturePkt state Nothing of - Left err -> - assertFailure - ("RSA SigV6 signed message verification failed: " ++ - renderVerificationError err) - Right _ -> pure () - -testSignMessageEd25519 :: Assertion -testSignMessageEd25519 = do - (signer, signingKey) <- loadDeterministicEd25519Signer - signerV4 <- expectV4PKPayload "Ed25519 v4 signer" signer - let payload = "message-api signing payload with Ed25519" - signedResult <- signMessageWith (mkEd25519SignerV4 signerV4 signingKey) (mkClearPayload payload) - signedMessage <- - case signedResult of - Left err -> - assertFailure ("Ed25519 message signing failed: " ++ show err) >> pure mempty - Right bs -> pure bs - signaturePkt <- - case parsePkts signedMessage of - [LiteralDataPkt {}, sig@(SignaturePkt (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _))] -> - pure sig - other -> - assertFailure - ("Ed25519 signing output should contain [LiteralDataPkt, Ed25519 SigV4], got " ++ - show other) >> - fail "unexpected Ed25519 signMessage output shape" - let state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} - keyring = [TKUnknown (signer, Nothing) [] [] [] []] - case verifySigWith (verifyAgainstKeys keyring) signaturePkt state Nothing of - Left err -> - assertFailure - ("Ed25519 signed message verification failed: " ++ - renderVerificationError err) - Right _ -> pure () - -testSignMessageEd25519V6 :: Assertion -testSignMessageEd25519V6 = do - (signer, signingKey) <- loadDeterministicEd25519SignerV6 - signerV6 <- expectV6PKPayload "Ed25519 v6 signer" signer - let payload = "message-api signing payload with Ed25519 SigV6" - signedResult <- signMessageWith (mkEd25519SignerV6 signerV6 signingKey) (mkClearPayload payload) - signedMessage <- - case signedResult of - Left err -> - assertFailure ("Ed25519 SigV6 message signing failed: " ++ show err) >> pure mempty - Right bs -> pure bs - signaturePkt <- - case parsePkts signedMessage of - [LiteralDataPkt {}, sig@(SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _))] -> do - assertEqual "SigV6 Ed25519 salt must be 32 bytes for SHA512" 32 (BL.length (unSignatureSalt salt)) - pure sig - other -> - assertFailure - ("Ed25519 SigV6 signing output should contain [LiteralDataPkt, Ed25519 SigV6], got " ++ - show other) >> - fail "unexpected Ed25519 SigV6 signMessage output shape" - case signaturePkt of - SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 _ _ _ _ _) -> do - let state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} - keyring = [TKUnknown (signer, Nothing) [] [] [] []] - case verifySigWith (verifyAgainstKeys keyring) signaturePkt state Nothing of - Left err -> - assertFailure - ("Ed25519 SigV6 signed message verification failed: " ++ - renderVerificationError err) - Right _ -> pure () - _ -> assertFailure "expected an Ed25519 SigV6 signature packet" - -testV4Ed25519LegacyKeyRejectsMissingPrefix :: Assertion -testV4Ed25519LegacyKeyRejectsMissingPrefix = do - let legacyEd25519Oid = B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] - rawEd25519Public = B.replicate 32 0x01 - encoded = - runPut $ do - putWord8 4 - putWord32be 0 - putWord8 (fromFVal EdDSA) - putWord8 (fromIntegral (B.length legacyEd25519Oid)) - putByteString legacyEd25519Oid - putWord16be 256 - putByteString rawEd25519Public - case runGetOrFail (get :: Get SomePKPayload) encoded of - Left (_, _, err) -> - assertBool - ("expected invalid-legacy-point parse failure, got: " ++ err) - ("invalid Ed25519Legacy public key" `isInfixOf` err) - Right _ -> - assertFailure "legacy Ed25519 key without 0x40 prefix should be rejected" - -testSignMessageEd448 :: Assertion -testSignMessageEd448 = do - (signer, signingKey) <- loadDeterministicEd448Signer - signerV4 <- expectV4PKPayload "Ed448 v4 signer" signer - let payload = "message-api signing payload with Ed448" - signedResult <- signMessageWith (mkEd448SignerV4 signerV4 signingKey) (mkClearPayload payload) - signedMessage <- - case signedResult of - Left err -> - assertFailure ("Ed448 message signing failed: " ++ show err) >> pure mempty - Right bs -> pure bs - signaturePkt <- - case parsePkts signedMessage of - [LiteralDataPkt {}, sig@(SignaturePkt (SigV4 BinarySig PKA.Ed448 SHA512 _ _ _ _))] -> - pure sig - other -> - assertFailure - ("Ed448 signing output should contain [LiteralDataPkt, Ed448 SigV4], got " ++ - show other) >> - fail "unexpected Ed448 signMessage output shape" - let state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} - keyring = [TKUnknown (signer, Nothing) [] [] [] []] - case verifySigWith (verifyAgainstKeys keyring) signaturePkt state Nothing of - Left err -> - assertFailure - ("Ed448 signed message verification failed: " ++ - renderVerificationError err) - Right _ -> pure () - -testSignMessageEd448V6 :: Assertion -testSignMessageEd448V6 = do - (signer, signingKey) <- loadDeterministicEd448SignerV6 - signerV6 <- expectV6PKPayload "Ed448 v6 signer" signer - let payload = "message-api signing payload with Ed448 SigV6" - signedResult <- signMessageWith (mkEd448SignerV6 signerV6 signingKey) (mkClearPayload payload) - signedMessage <- - case signedResult of - Left err -> - assertFailure ("Ed448 SigV6 message signing failed: " ++ show err) >> pure mempty - Right bs -> pure bs - signaturePkt <- - case parsePkts signedMessage of - [LiteralDataPkt {}, sig@(SignaturePkt (SigV6 BinarySig PKA.Ed448 SHA512 salt _ _ _ _))] -> do - assertEqual "SigV6 Ed448 salt must be 32 bytes for SHA512" 32 (BL.length (unSignatureSalt salt)) - pure sig - other -> - assertFailure - ("Ed448 SigV6 signing output should contain [LiteralDataPkt, Ed448 SigV6], got " ++ - show other) >> - fail "unexpected Ed448 SigV6 signMessage output shape" - case signaturePkt of - SignaturePkt (SigV6 BinarySig PKA.Ed448 SHA512 _ _ _ _ _) -> pure () - _ -> assertFailure "expected an Ed448 SigV6 signature packet" - -testV4EdSignaturesUseNativeFixedWidthEncoding :: Assertion -testV4EdSignaturesUseNativeFixedWidthEncoding = do - (_, ed25519SigningKey) <- loadDeterministicEd25519Signer - ed25519Sig <- - case signDataWithEd25519 BinarySig ed25519SigningKey [] [] "v4 ed25519 encoding" of - Left err -> - assertFailure ("Ed25519 v4 signing failed: " ++ renderSignError err) >> - fail "expected Ed25519 signature" - Right sig -> pure sig - case extractV4SignatureAlgorithmFields (runPut (put ed25519Sig)) of - Left err -> - assertFailure ("failed to decode serialized Ed25519 v4 signature payload: " ++ err) - Right (pka, algorithmFields) -> do - assertEqual "Ed25519 v4 signature packet algorithm id" PKA.Ed25519 pka - assertEqual "Ed25519 v4 algorithm field width" 64 (B.length algorithmFields) - - (_, ed448SigningKey) <- loadDeterministicEd448Signer - ed448Sig <- - case signDataWithEd448 BinarySig ed448SigningKey [] [] "v4 ed448 encoding" of - Left err -> - assertFailure ("Ed448 v4 signing failed: " ++ renderSignError err) >> - fail "expected Ed448 signature" - Right sig -> pure sig - case extractV4SignatureAlgorithmFields (runPut (put ed448Sig)) of - Left err -> - assertFailure ("failed to decode serialized Ed448 v4 signature payload: " ++ err) - Right (pka, algorithmFields) -> do - assertEqual "Ed448 v4 signature packet algorithm id" PKA.Ed448 pka - assertEqual "Ed448 v4 algorithm field width" 114 (B.length algorithmFields) - -testVerifyDetachedEd25519WithoutIssuerHints :: Assertion -testVerifyDetachedEd25519WithoutIssuerHints = do - (signer, signingKey) <- loadDeterministicEd25519Signer - let payload = "detached v4 eddsa payload without issuer hints" - state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} - keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []] - sigPayload <- - case signDataWithEd25519 BinarySig signingKey [] [] payload of - Left err -> - assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err) >> - fail (renderSignError err) - Right sig -> pure sig - case verifySigWith (verifyAgainstKeyring keyring) (SignaturePkt sigPayload) state Nothing of - Left err -> - assertFailure - ("Ed25519 detached verification without issuer hints failed: " ++ - renderVerificationError err) - Right _ -> pure () - -testVerifyDetachedEd25519WithFakeIssuerHint :: Assertion -testVerifyDetachedEd25519WithFakeIssuerHint = do - (signer, signingKey) <- loadDeterministicEd25519Signer - let payload = "detached v4 eddsa payload with fake issuer hint" - state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} - keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []] - fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef" - unhashed = [SigSubPacket False (Issuer fakeIssuer)] - sigPayload <- - case signDataWithEd25519 BinarySig signingKey [] unhashed payload of - Left err -> - assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err) >> - fail (renderSignError err) - Right sig -> pure sig - case verifySigWith (verifyAgainstKeyring keyring) (SignaturePkt sigPayload) state Nothing of - Left err -> - assertFailure - ("Ed25519 detached verification with fake issuer hint failed: " ++ - renderVerificationError err) - Right _ -> pure () - -testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys :: Assertion -testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys = do - (signer, signingKey) <- loadDeterministicEd25519Signer - let payload = "detached v4 eddsa payload without issuer hints (verifyAgainstKeys)" - state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} - keys = [TKUnknown (signer, Nothing) [] [] [] []] - sigPayload <- - case signDataWithEd25519 BinarySig signingKey [] [] payload of - Left err -> - assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err) >> - fail (renderSignError err) - Right sig -> pure sig - case verifySigWith (verifyAgainstKeys keys) (SignaturePkt sigPayload) state Nothing of - Left err -> - assertFailure - ("Ed25519 detached verification against keys without issuer hints failed: " ++ - renderVerificationError err) - Right _ -> pure () - -testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys :: Assertion -testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys = do - (signer, signingKey) <- loadDeterministicEd25519Signer - let payload = "detached v4 eddsa payload with fake issuer hint (verifyAgainstKeys)" - state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} - keys = [TKUnknown (signer, Nothing) [] [] [] []] - fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef" - unhashed = [SigSubPacket False (Issuer fakeIssuer)] - sigPayload <- - case signDataWithEd25519 BinarySig signingKey [] unhashed payload of - Left err -> - assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err) >> - fail (renderSignError err) - Right sig -> pure sig - case verifySigWith (verifyAgainstKeys keys) (SignaturePkt sigPayload) state Nothing of - Left err -> - assertFailure - ("Ed25519 detached verification against keys with fake issuer hint failed: " ++ - renderVerificationError err) - Right _ -> pure () - -testCanonicalTextSigPayloadNormalization :: Assertion -testCanonicalTextSigPayloadNormalization = do - let state = - emptyPSC - { lastLD = - LiteralDataPkt - TextData - BL.empty - (ThirtyTwoBitTimeStamp 0) - "line1 \t\nline2\t \rline3\t \r\nline4 \t" - } - assertEqual - "Binary signatures preserve original line endings" - "line1 \t\nline2\t \rline3\t \r\nline4 \t" - (payloadForSig BinarySig state) - assertEqual - "Canonical text signatures normalize line endings and trim trailing whitespace" - "line1\r\nline2\r\nline3\r\nline4" - (payloadForSig CanonicalTextSig state) - -testTextNormalizationModes :: Assertion -testTextNormalizationModes = do - let state = - emptyPSC - { lastLD = - LiteralDataPkt - TextData - BL.empty - (ThirtyTwoBitTimeStamp 0) - "line1 \t\nline2\t \r\nline3" - } - let cleartextResult = payloadForSigWith CleartextCompat CanonicalTextSig state - strictResult = payloadForSigWith RFC9580Strict CanonicalTextSig state - assertEqual - "CleartextCompat mode strips trailing whitespace per line" - "line1\r\nline2\r\nline3" - cleartextResult - assertEqual - "RFC9580Strict mode preserves trailing whitespace (CRLF-only normalization)" - "line1 \t\r\nline2\t \r\nline3" - strictResult - (signer, signingKey) <- loadUnencryptedRsaSigner - issuerKeyId <- - case eightOctetKeyID signer of - Left err -> - assertFailure ("failed to derive issuer key id: " ++ err) >> - fail "expected issuer key id" - Right i -> pure i - let payload = "line with trailing space \nno trailing space\n" - hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer))] - unhashed = [SigSubPacket False (Issuer issuerKeyId)] - builderCompat = sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512 - builderStrict = (sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512) { sbTextNormMode = RFC9580Strict } - withSubs b = addUnhashedSubs (listToUnhashedSubs unhashed) (addHashedSubs (listToHashedSubs hashed) b) - bc = withSubs builderCompat - bs = withSubs builderStrict - sigCompat <- case signDataWithRSABuilder bc signingKey payload of - Left err -> assertFailure ("CleartextCompat sign failed: " ++ renderSignError err) >> fail "" - Right s -> pure s - sigStrict <- case signDataWithRSABuilder bs signingKey payload of - Left err -> assertFailure ("RFC9580Strict sign failed: " ++ renderSignError err) >> fail "" - Right s -> pure s - assertBool - "CleartextCompat and RFC9580Strict produce different signatures for payloads with trailing whitespace" - (sigCompat /= sigStrict) - -testCanonicalTextSignatureSigningPaths :: Assertion -testCanonicalTextSignatureSigningPaths = do - (signer, signingKey) <- loadUnencryptedRsaSigner - issuerKeyId <- - case eightOctetKeyID signer of - Left err -> - assertFailure ("failed to derive issuer key id: " ++ err) >> - fail "expected issuer key id" - Right i -> pure i - let mixedPayload = "line1 \t\nline2\t \rline3\t \r\nline4 \t" - normalizedPayload = "line1\r\nline2\r\nline3\r\nline4" - hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer))] - unhashed = [SigSubPacket False (Issuer issuerKeyId)] - primitiveMixed <- - case signDataWithRSA CanonicalTextSig signingKey hashed unhashed mixedPayload of - Left err -> - assertFailure ("canonical text primitive signing failed: " ++ renderSignError err) >> - fail (renderSignError err) - Right sig -> pure sig - primitiveNormalized <- - case signDataWithRSA CanonicalTextSig signingKey hashed unhashed normalizedPayload of - Left err -> - assertFailure ("canonical text primitive signing (normalized payload) failed: " ++ renderSignError err) >> - fail (renderSignError err) - Right sig -> pure sig - assertEqual - "primitive canonical text signing should normalize mixed line endings" - primitiveNormalized - primitiveMixed - - let builder = sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512 - withHashed = addHashedSubs (listToHashedSubs hashed) builder - withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed - builderMixed <- - case signDataWithRSABuilder withUnhashed signingKey mixedPayload of - Left err -> - assertFailure ("canonical text builder signing failed: " ++ renderSignError err) >> - fail (renderSignError err) - Right sig -> pure sig - builderNormalized <- - case signDataWithRSABuilder withUnhashed signingKey normalizedPayload of - Left err -> - assertFailure ("canonical text builder signing (normalized payload) failed: " ++ renderSignError err) >> - fail (renderSignError err) - Right sig -> pure sig - assertEqual - "builder canonical text signing should normalize mixed line endings" - builderNormalized - builderMixed - -testSignaturePrimitives :: Assertion -testSignaturePrimitives = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let userId = UserId "primitive-api@example.org" - assertSigType :: - String -> SigType -> Either SignError SignaturePayload -> Assertion - assertSigType testLabel expected result = - case result of - Left err -> assertFailure (testLabel ++ " failed: " ++ renderSignError err) - Right (SigV4 sigType _ _ _ _ _ _) -> - assertEqual (testLabel ++ " uses expected signature type") expected sigType - Right _ -> assertFailure (testLabel ++ " should generate a V4 signature payload") - assertSigType - "certification signature" - GenericCert - (signCertificationWithRSA GenericCert signer userId [] [] signingKey) - assertSigType - "key revocation signature" - KeyRevocationSig - (signKeyRevocationWithRSA signer [] [] signingKey) - assertSigType - "subkey revocation signature" - SubkeyRevocationSig - (signSubkeyRevocationWithRSA signer signer [] [] signingKey) - assertSigType - "certification revocation signature" - CertRevocationSig - (signCertRevocationWithRSA signer userId [] [] signingKey) - let left16Payload = "left16 primitive payload" - left16Keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []] - left16Sig <- - case signDataWithRSA BinarySig signingKey [] [] left16Payload of - Left err -> - assertFailure ("RSA primitive signing for left16 failed: " ++ renderSignError err) >> - fail "expected RSA signature payload" - Right sigPayload -> pure sigPayload - case verifyAgainstKeyring left16Keyring (SignaturePkt left16Sig) Nothing left16Payload of - Right _ -> pure () - Left err -> - assertFailure - ("fresh RSA signature should verify with matching left16, got: " ++ - renderVerificationError err) - let tamperedLeft16Sig = - case left16Sig of - SigV4 st pka ha hs us l16 mpis -> SigV4 st pka ha hs us (l16 + 1) mpis - other -> other - case verifyAgainstKeyring left16Keyring (SignaturePkt tamperedLeft16Sig) Nothing left16Payload of - Left _ -> pure () - Right _ -> - assertFailure "verification unexpectedly succeeded with tampered left16" - if isRight (signCertificationWithRSA KeyRevocationSig signer userId [] [] signingKey) - then - assertFailure - "certification primitive should reject non-certification signature types" - else pure () - (edSigner, edSigningKey) <- loadDeterministicEd25519Signer - edIssuerKeyId <- - case eightOctetKeyID edSigner of - Left err -> - assertFailure ("failed to derive Ed25519 issuer key id: " ++ err) >> - fail "expected Ed25519 issuer key id" - Right i -> pure i - let edPayload = "primitive Ed25519 payload" - edHashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint edSigner))] - edUnhashed = [SigSubPacket False (Issuer edIssuerKeyId)] - case signDataWithEd25519 BinarySig edSigningKey edHashed edUnhashed edPayload of - Left err -> assertFailure ("Ed25519 primitive signing failed: " ++ renderSignError err) - Right (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _) -> pure () - Right other -> - assertFailure ("Ed25519 primitive should generate an Ed25519 SigV4 payload, got " ++ show other) - let v6Salt = SignatureSalt (BL.replicate 32 0x42) - case signDataWithEd25519V6 BinarySig v6Salt edSigningKey edHashed edUnhashed edPayload of - Left err -> assertFailure ("Ed25519 SigV6 primitive signing failed: " ++ renderSignError err) - Right (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _) -> - assertEqual "Ed25519 SigV6 primitive should preserve 32-byte salt" 32 (BL.length (unSignatureSalt salt)) - Right other -> - assertFailure ("Ed25519 SigV6 primitive should generate an Ed25519 SigV6 payload, got " ++ show other) - (ed448Signer, ed448SigningKey) <- loadDeterministicEd448Signer - ed448IssuerKeyId <- - case eightOctetKeyID ed448Signer of - Left err -> - assertFailure ("failed to derive Ed448 issuer key id: " ++ err) >> - fail "expected Ed448 issuer key id" - Right i -> pure i - let ed448Payload = "primitive Ed448 payload" - ed448Hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint ed448Signer))] - ed448Unhashed = [SigSubPacket False (Issuer ed448IssuerKeyId)] - case signDataWithEd448 BinarySig ed448SigningKey ed448Hashed ed448Unhashed ed448Payload of - Left err -> assertFailure ("Ed448 primitive signing failed: " ++ renderSignError err) - Right (SigV4 BinarySig PKA.Ed448 SHA512 _ _ _ _) -> pure () - Right other -> - assertFailure ("Ed448 primitive should generate an Ed448 SigV4 payload, got " ++ show other) - case signDataWithEd448V6 BinarySig v6Salt ed448SigningKey ed448Hashed ed448Unhashed ed448Payload of - Left err -> assertFailure ("Ed448 SigV6 primitive signing failed: " ++ renderSignError err) - Right (SigV6 BinarySig PKA.Ed448 SHA512 salt _ _ _ _) -> - assertEqual "Ed448 SigV6 primitive should preserve 32-byte salt" 32 (BL.length (unSignatureSalt salt)) - Right other -> - assertFailure ("Ed448 SigV6 primitive should generate an Ed448 SigV6 payload, got " ++ show other) - -testSignatureDataKindsCoercions :: Assertion -testSignatureDataKindsCoercions = do - let sigV3 = - SigV3 - BinarySig - (ThirtyTwoBitTimeStamp 1) - (EightOctetKeyId "\x01\x02\x03\x04\x05\x06\x07\x08") - RSA - SHA256 - 0 - (NE.fromList [MPI 1]) - sigV4 = - SigV4 - BinarySig - RSA - SHA256 - [] - [] - 0 - (NE.fromList [MPI 2]) - sigV6 = - SigV6 - BinarySig - PKA.Ed25519 - SHA512 - (SignatureSalt (BL.replicate 32 0x01)) - [] - [] - 0 - (NE.fromList [MPI 3, MPI 4]) - sigOther = SigVOther 77 "opaque-signature-body" - assertPacketRoundTrip label expected pkt = - case fromPktEitherSomeSignatureV pkt of - Left err -> assertFailure (label ++ " packet coercion failed: " ++ err) - Right (SomeSignatureV typedSig) -> - assertEqual - (label ++ " packet coercion preserves payload") - expected - (signaturePayloadFromSignatureV typedSig) - assertBool - "toSomeSignaturePayload should preserve SigV3 witness" - (isRight (asSignaturePayloadV3 sigV3)) - assertBool - "toSomeSignaturePayload should preserve SigV4 witness" - (isRight (asSignaturePayloadV4 sigV4)) - assertBool - "toSomeSignaturePayload should preserve SigV6 witness" - (isRight (asSignaturePayloadV6 sigV6)) - assertBool - "toSomeSignaturePayload should preserve SigVOther witness" - (isRight (asSignaturePayloadOther sigOther)) - case asSignaturePayloadV3 sigV3 of - Left err -> assertFailure ("asSignaturePayloadV3 should accept SigV3: " ++ err) - Right typed -> - assertEqual "asSignaturePayloadV3 round-trips SigV3" sigV3 (toSignaturePayload typed) - case asSignaturePayloadV4 sigV4 of - Left err -> assertFailure ("asSignaturePayloadV4 should accept SigV4: " ++ err) - Right typed -> - assertEqual "asSignaturePayloadV4 round-trips SigV4" sigV4 (toSignaturePayload typed) - case asSignaturePayloadV6 sigV6 of - Left err -> assertFailure ("asSignaturePayloadV6 should accept SigV6: " ++ err) - Right typed -> - assertEqual "asSignaturePayloadV6 round-trips SigV6" sigV6 (toSignaturePayload typed) - case asSignaturePayloadOther sigOther of - Left err -> assertFailure ("asSignaturePayloadOther should accept SigVOther: " ++ err) - Right typed -> - assertEqual "asSignaturePayloadOther round-trips SigVOther" sigOther (toSignaturePayload typed) - assertBool - "asSignaturePayloadV6 rejects SigV4" - (not (isRight (asSignaturePayloadV6 sigV4))) - assertBool - "asSignaturePayloadV4 rejects SigVOther" - (not (isRight (asSignaturePayloadV4 sigOther))) - assertPacketRoundTrip "SigV3" sigV3 (SignaturePkt sigV3) - assertPacketRoundTrip "SigV4" sigV4 (SignaturePkt sigV4) - assertPacketRoundTrip "SigV6" sigV6 (SignaturePkt sigV6) - assertPacketRoundTrip "SigVOther" sigOther (SignaturePkt sigOther) - assertBool - "fromPktEitherSomeSignatureV rejects non-signature packets" - (not (isRight (fromPktEitherSomeSignatureV (LiteralDataPkt BinaryData "" 0 "")))) - -testTypedArmorPayloadHelpers :: Assertion -testTypedArmorPayloadHelpers = do - let armors = - [ Armor ArmorPublicKeyBlock [] "public-one" - , Armor ArmorMessage [] "message-one" - , Armor ArmorPublicKeyBlock [] "public-two" - ] - publicPayloads = map BL.toStrict (armorPayloadsOfType ArmorPublicKeyBlock armors) - assertEqual - "armorPayloadsOfType returns all matching typed blocks in order" - ["public-one", "public-two"] - publicPayloads - assertEqual - "singleArmorPayloadOfType returns the sole matching message payload" - (Right "message-one") - (fmap BL.toStrict (singleArmorPayloadOfType ArmorMessage armors)) - assertBool - "singleArmorPayloadOfType fails when no typed blocks exist" - (isLeft (singleArmorPayloadOfType ArmorPrivateKeyBlock armors)) - assertBool - "singleArmorPayloadOfType fails when multiple typed blocks exist" - (isLeft (singleArmorPayloadOfType ArmorPublicKeyBlock armors)) -testRecommendedArmorType :: Assertion -testRecommendedArmorType = do - secretArmors <- loadArmor "v4-encrypted-secret.pgp.aa" - publicArmors <- loadArmor "v4-encrypted.rev.aa" - secretPayload <- - case singleArmorPayloadOfType ArmorPrivateKeyBlock secretArmors of - Left err -> assertFailure err >> fail err - Right payload -> pure payload - publicPayload <- - case singleArmorPayloadOfType ArmorPublicKeyBlock publicArmors of - Left err -> assertFailure err >> fail err - Right payload -> pure payload - let secretPkts = parsePkts secretPayload - publicPkts = parsePkts publicPayload - firstPkt label pkts = - case pkts of - [] -> assertFailure (label ++ " should contain at least one packet") >> fail "missing packet" - pkt:_ -> pure pkt - firstSecret <- firstPkt "secret armor fixture" secretPkts - firstPublic <- firstPkt "public armor fixture" publicPkts - let sig = SignaturePkt (SigV4 BinarySig RSA SHA256 [] [] 0 (NE.fromList [MPI 1])) - assertEqual "recommendedArmorType rejects empty packet streams" Nothing (recommendedArmorType []) - assertEqual - "recommendedArmorType maps secret-key packets to private key armor" - (Just ArmorPrivateKeyBlock) - (recommendedArmorType [firstSecret]) - assertEqual - "recommendedArmorType maps public-key packets to public key armor" - (Just ArmorPublicKeyBlock) - (recommendedArmorType [firstPublic]) - assertEqual - "recommendedArmorType maps signature packets to signature armor" - (Just ArmorSignature) - (recommendedArmorType [sig]) - assertEqual - "recommendedArmorType defaults non-key/signature packets to message armor" - (Just ArmorMessage) - (recommendedArmorType [LiteralDataPkt BinaryData "" 0 "payload"]) -testSingleClearSignedBlock :: Assertion -testSingleClearSignedBlock = do - let clearSigned = - ClearSigned - [("Hash", "SHA256")] - "signed cleartext payload\n" - (Armor ArmorSignature [("Version", "test-suite")] "detached-signature") - assertEqual - "singleClearSignedBlock extracts cleartext and signature payloads" - (Right ([("Hash", "SHA256")], "signed cleartext payload\n", "detached-signature")) - (singleClearSignedBlock [clearSigned]) - assertBool - "singleClearSignedBlock rejects absent clear-signed blocks" - (isLeft (singleClearSignedBlock [Armor ArmorMessage [] "payload"])) - assertBool - "singleClearSignedBlock rejects multiple clear-signed blocks" - (isLeft (singleClearSignedBlock [clearSigned, clearSigned])) - assertBool - "singleClearSignedBlock rejects non-signature inner armor blocks" - (isLeft (singleClearSignedBlock [ClearSigned [] "payload" (Armor ArmorMessage [] "not-signature")])) -testSignerTimelineSoftPrimaryRevocation :: Assertion -testSignerTimelineSoftPrimaryRevocation = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let payload = "soft primary revocation timeline payload" - keyCreated = _timestamp signer - sigBeforeTime = addTimestampSeconds keyCreated 10 - revocationTime = addTimestampSeconds keyCreated 20 - sigAfterTime = addTimestampSeconds keyCreated 30 - sigBefore <- - signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload - revocation <- - signKeyRevocationWithReasonAt signer signingKey revocationTime KeySuperseded - sigAfter <- - signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload - let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] - assertSingleSignerFingerprint - "soft primary revocation should preserve pre-revocation signatures" - (fingerprint signer) - (verifyTimelinePackets keyring payload sigBefore) - assertSingleFailureContainsTimeline - "soft primary revocation should reject post-revocation signatures" - "signing key is revoked" - (verifyTimelinePackets keyring payload sigAfter) - -testSignerTimelineHardPrimaryRevocation :: Assertion -testSignerTimelineHardPrimaryRevocation = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let payload = "hard primary revocation timeline payload" - keyCreated = _timestamp signer - sigBeforeTime = addTimestampSeconds keyCreated 10 - revocationTime = addTimestampSeconds keyCreated 20 - sigBefore <- - signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload - revocation <- - signKeyRevocationWithReasonAt signer signingKey revocationTime KeyMaterialCompromised - let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] - assertSingleFailureContainsTimeline - "hard primary revocation should reject even pre-revocation signatures" - "signing key is revoked" - (verifyTimelinePackets keyring payload sigBefore) - -testSignerTimelineNoReasonPrimaryRevocation :: Assertion -testSignerTimelineNoReasonPrimaryRevocation = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let payload = "no-reason primary revocation timeline payload" - keyCreated = _timestamp signer - sigBeforeTime = addTimestampSeconds keyCreated 10 - revocationTime = addTimestampSeconds keyCreated 20 - sigBefore <- - signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload - revocation <- - signKeyRevocationWithReasonAt signer signingKey revocationTime NoReason - let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] - assertSingleFailureContainsTimeline - "no-reason primary revocation should reject even pre-revocation signatures" - "signing key is revoked" - (verifyTimelinePackets keyring payload sigBefore) - -testSignerTimelineUnknownReasonPrimaryRevocation :: Assertion -testSignerTimelineUnknownReasonPrimaryRevocation = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let payload = "unknown-reason primary revocation timeline payload" - keyCreated = _timestamp signer - sigBeforeTime = addTimestampSeconds keyCreated 10 - revocationTime = addTimestampSeconds keyCreated 20 - sigBefore <- - signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload - revocation <- - signKeyRevocationWithReasonAt signer signingKey revocationTime (RCoOther 100) - let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] - assertSingleFailureContainsTimeline - "unknown-reason primary revocation should reject even pre-revocation signatures" - "signing key is revoked" - (verifyTimelinePackets keyring payload sigBefore) - -testSignerTimelineNonCompromisePrimaryRevocationIsHistorical :: Assertion -testSignerTimelineNonCompromisePrimaryRevocationIsHistorical = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let payload = "non-compromise primary revocation timeline payload" - keyCreated = _timestamp signer - sigBeforeTime = addTimestampSeconds keyCreated 10 - revocationTime = addTimestampSeconds keyCreated 20 - sigAfterTime = addTimestampSeconds keyCreated 30 - sigBefore <- - signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload - revocation <- - signKeyRevocationWithReasonAt - signer - signingKey - revocationTime - UserIdInfoNoLongerValid - sigAfter <- - signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload - let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] - assertSingleSignerFingerprint - "non-compromise primary revocation should preserve pre-revocation signatures" - (fingerprint signer) - (verifyTimelinePackets keyring payload sigBefore) - assertSingleFailureContainsTimeline - "non-compromise primary revocation should reject post-revocation signatures" - "signing key is revoked" - (verifyTimelinePackets keyring payload sigAfter) - -testSignerTimelineTemporaryPrimaryRevocationExpires :: Assertion -testSignerTimelineTemporaryPrimaryRevocationExpires = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let payload = "temporary primary revocation expiry timeline payload" - keyCreated = _timestamp signer - sigBeforeTime = addTimestampSeconds keyCreated 10 - revocationTime = addTimestampSeconds keyCreated 20 - sigDuringTime = addTimestampSeconds keyCreated 25 - sigAfterTime = addTimestampSeconds keyCreated 35 - sigBefore <- - signBinaryMessageWithRSAAt signer signingKey sigBeforeTime payload - revocation <- - signKeyRevocationWithReasonAndExtrasAt - signer - signingKey - revocationTime - KeySuperseded - [SigSubPacket False (SigExpirationTime 10)] - sigDuring <- - signBinaryMessageWithRSAAt signer signingKey sigDuringTime payload - sigAfter <- - signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload - let keyring = mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] - assertSingleSignerFingerprint - "temporary primary revocation should preserve pre-revocation signatures" - (fingerprint signer) - (verifyTimelinePackets keyring payload sigBefore) - assertSingleFailureContainsTimeline - "temporary primary revocation should reject signatures while revocation is effective" - "signing key is revoked" - (verifyTimelinePackets keyring payload sigDuring) - assertSingleSignerFingerprint - "temporary primary revocation should allow signatures after revocation expiration" - (fingerprint signer) - (verifyTimelinePackets keyring payload sigAfter) - -testSignerTimelineSubkeyRevocation :: Assertion -testSignerTimelineSubkeyRevocation = do - (primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner - (subkeySigner, subkeySigningKey) <- loadDeterministicEd25519Signer - let payload = "subkey revocation timeline payload" - keyCreated = _timestamp primarySigner - bindingTime = addTimestampSeconds keyCreated 10 - sigBeforeTime = addTimestampSeconds keyCreated 20 - revocationTime = addTimestampSeconds keyCreated 30 - sigAfterTime = addTimestampSeconds keyCreated 40 - subkeyPacket = PublicSubkeyPkt subkeySigner - bindingSig <- - signSubkeyBindingWithRSAAt primarySigner subkeySigner primarySigningKey bindingTime - sigBefore <- - signBinaryMessageWithEd25519At subkeySigner subkeySigningKey sigBeforeTime payload - revocationSig <- - signSubkeyRevocationWithRSAAt primarySigner subkeySigner primarySigningKey revocationTime - sigAfter <- - signBinaryMessageWithEd25519At subkeySigner subkeySigningKey sigAfterTime payload - let keyring = - mkTestKeyring - [TKUnknown (primarySigner, Nothing) [] [] [] [(subkeyPacket, [bindingSig, revocationSig])]] - assertSingleSignerFingerprint - "subkey revocation should preserve pre-revocation signatures" - (fingerprint subkeySigner) - (verifyTimelinePackets keyring payload sigBefore) - assertSingleFailureContainsTimeline - "subkey revocation should reject post-revocation signatures" - "signing key was not valid at the signature creation time" - (verifyTimelinePackets keyring payload sigAfter) - -testSignMessageConvenience :: Assertion -testSignMessageConvenience = do - (signer, signingKey) <- loadUnencryptedRsaSigner - signerV4 <- expectV4PKPayload "RSA v4 convenience signer" signer - signedResult <- signMessage (mkRSASignerV4 signerV4 signingKey) "message-api convenience signing payload" - signedMessage <- - case signedResult of - Left err -> - assertFailure ("message signing convenience API failed: " ++ show err) >> pure mempty - Right bs -> pure bs - case parsePkts signedMessage of - [LiteralDataPkt {}, SignaturePkt _] -> pure () - _ -> assertFailure "convenience signing output should contain literal data and one signature packet" - -testTypedVerifySurfaceMatchesLegacy :: Assertion -testTypedVerifySurfaceMatchesLegacy = do - kr <- loadKeyring "pubring.gpg" - signedMessage <- readFixtureLazy "uncompressed-ops-rsa.gpg" - let typedResults = - verifyMessage - defaultVerificationOptions - { verificationPolicy = VerifyInformational - , verificationMode = VerificationStreaming - } - kr - signedMessage - strictResults = - verifyMessage - defaultVerificationOptions - { verificationPolicy = VerifyStrict - , verificationMode = VerificationStreaming - } - kr - signedMessage - normalizeTyped :: Either VerificationError Verification -> Either Bool Fingerprint - normalizeTyped (Left _) = Left False - normalizeTyped (Right v) = Right (fingerprint (_verificationSigner v)) - assertEqual - "strict verification should collapse informational failures" - (map normalizeTyped (either (pure . Left) (Right <$>) (sequence typedResults))) - (map normalizeTyped strictResults) - assertBool - "informational verification should emit at least one result for known-good fixture" - (not (null (map normalizeTyped typedResults))) - -testVerifyMessageStrictRejectsTamper :: Assertion -testVerifyMessageStrictRejectsTamper = do - kr <- loadKeyring "pubring.gpg" - packets <- loadAndDecompressPkts "uncompressed-ops-rsa.gpg" - let tamperedPackets = map tamperLiteral packets - strictOptions = - defaultVerificationOptions - { verificationPolicy = VerifyStrict - , verificationMode = VerificationStreaming - } - case verifyMessagePackets strictOptions kr tamperedPackets of - [Left _] -> pure () - _ -> assertFailure "strict typed verification should fail on tampered payload" - where - tamperLiteral (LiteralDataPkt dt fn ts payload) = - LiteralDataPkt dt fn ts (BL.snoc payload 0) - tamperLiteral pkt = pkt - -testVerifySignedMessageConvenience :: Assertion -testVerifySignedMessageConvenience = do - kr <- loadKeyring "pubring.gpg" - signedMessage <- readFixtureLazy "uncompressed-ops-rsa.gpg" - strictResult <- - pure - (verifySignedMessage - defaultVerificationOptions - { verificationPolicy = VerifyStrict - , verificationMode = VerificationStreaming - } - kr - signedMessage) - case strictResult of - [Left _] -> assertFailure "verifySignedMessage should succeed for known-good fixture" - verifications -> - assertBool "verifySignedMessage should emit at least one verification" (not (null verifications)) - -testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm :: Assertion -testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm = do - (signer, signingKey) <- loadDeterministicEd25519Signer - let signerWithEd25519Pka = setPKAlgorithm PKA.Ed25519 signer - signerV4 <- expectV4PKPayload "Ed25519 v4 signer with Ed25519 key algorithm" signerWithEd25519Pka - let payload = "v4 eddsa signature with Ed25519 key algorithm" - state = emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} - keyring = mkTestKeyring [TKUnknown (signerWithEd25519Pka, Nothing) [] [] [] []] - signedResult <- - signMessageWith - (mkEd25519SignerV4 signerV4 signingKey) - (mkClearPayload payload) - signaturePkt <- - case signedResult of - Left err -> - assertFailure ("Ed25519 message signing failed: " ++ show err) >> - fail "expected signed Ed25519 payload" - Right signedMessage -> - case parsePkts signedMessage of - [LiteralDataPkt {}, sig@(SignaturePkt (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _))] -> - pure sig - other -> - assertFailure - ("Expected [LiteralDataPkt, Ed25519 SigV4] for Ed25519-key-algorithm verification test, got " ++ - show other) >> - fail "unexpected Ed25519-key-algorithm signature shape" - case verifySigWith (verifyAgainstKeyring keyring) signaturePkt state Nothing of - Left err -> - assertFailure - ("Ed25519 SigV4 verification with Ed25519 key algorithm failed: " ++ - renderVerificationError err) - Right _ -> pure () +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.MessageAndArmor (messageAndArmorTests) where + +import Codec.Encryption.OpenPGP.ASCIIArmor.Types + ( Armor (..) + , ArmorType (..) + ) +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.RSA as RSA +import Data.Binary (get, put) +import Data.Binary.Get (Get, runGetOrFail) +import Data.Binary.Put + ( putByteString + , putWord16be + , putWord32be + , putWord8 + , runPut + ) +import Data.Bits (xor) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Either (isLeft, isRight) +import Data.List (isInfixOf) +import qualified Data.List.NonEmpty as NE +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + ( Assertion + , assertBool + , assertEqual + , assertFailure + , testCase + ) + +import Codec.Encryption.OpenPGP.BlockCipher (keySize) +import Codec.Encryption.OpenPGP.CFB + ( decryptPreservingNonce + , validateSEIPD1MDC + ) +import Codec.Encryption.OpenPGP.Encrypt + ( encryptSEIPDv2WithSKESKBlock + ) +import Codec.Encryption.OpenPGP.Fingerprint + ( eightOctetKeyID + , fingerprint + ) +import Codec.Encryption.OpenPGP.Internal (emptyPSC, lastLD) +import Codec.Encryption.OpenPGP.KeyringParser (parseUnknownTKs) +import Codec.Encryption.OpenPGP.Message +import Codec.Encryption.OpenPGP.Policy + ( defaultVerificationPolicy + , signatureV6SaltSizeForHashAlgorithm + ) +import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key) +import Codec.Encryption.OpenPGP.Serialize + ( armorPayloadsOfType + , parsePkts + , parsePktsEither + , recommendedArmorType + , singleArmorPayloadOfType + , singleClearSignedBlock + ) +import Codec.Encryption.OpenPGP.SerializeForSigs + ( payloadForSig + , payloadForSigWith + ) +import Codec.Encryption.OpenPGP.Signatures + ( SignError (..) + , VerificationError (..) + , renderSignError + , renderVerificationError + , signCertRevocationWithRSA + , signCertificationWithRSA + , signDataWithEd25519 + , signDataWithEd25519Builder + , signDataWithEd25519V6 + , signDataWithEd25519V6Builder + , signDataWithEd448 + , signDataWithEd448V6 + , signDataWithRSA + , signDataWithRSABuilder + , signDirectKeyWithRSA + , signKeyRevocationWithRSA + , signSubkeyRevocationWithRSA + , verifyAgainstKeyring + , verifyAgainstKeys + , verifySigWith + ) +import Codec.Encryption.OpenPGP.Subpackets + ( TextNormalizationMode (..) + , addHashedSubs + , addUnhashedSubs + , listToHashedSubs + , listToUnhashedSubs + , sbTextNormMode + , sigBuilderInit + ) +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA +import Data.Conduit.OpenPGP.Message + ( verifyMessage + , verifyMessagePackets + ) +import Data.Conduit.OpenPGP.Verify (VerificationMode (..)) +import Tests.Common + ( addTimestampSeconds + , assertSingleFailureContainsTimeline + , assertSingleSignerFingerprint + , encryptMessageDefault + , expectV4PKPayload + , expectV6PKPayload + , extractV4SignatureAlgorithmFields + , fp + , loadAndDecompressPkts + , loadArmor + , loadDeterministicEd25519Signer + , loadDeterministicEd25519SignerV6 + , loadDeterministicEd448Signer + , loadDeterministicEd448SignerV6 + , loadKeyring + , loadUnencryptedRsaSigner + , loadUnencryptedRsaSignerV6 + , messageIssuerSubpacketsAt + , mkTestKeyring + , readFixtureLazy + , setPKAlgorithm + , signBinaryMessageWithEd25519At + , signBinaryMessageWithRSAAt + , signKeyRevocationWithReasonAndExtrasAt + , signKeyRevocationWithReasonAt + , signSubkeyBindingWithRSAAt + , signSubkeyRevocationWithRSAAt + , verifyTimelinePackets + ) + +messageAndArmorTests :: TestTree +messageAndArmorTests = + testGroup + "Message API and armor fixtures" + [ testGroup + "Message API group" + [ testCase + "default encrypt/decrypt message" + testDefaultedEncryptDecrypt + , testCase + "specific encrypt/decrypt message" + testExplicitEncryptDecrypt + , testCase + "specific encrypt can expose effective session material" + testExplicitEncryptExposesEffectiveSessionMaterial + , testCase + "default encrypt does not expose session material" + testDefaultEncryptDoesNotExposeSessionMaterial + , testCase + "AES-128 EAX encrypt/decrypt message" + testExplicitAES128EAXEncryptDecrypt + , testCase + "AES-128 GCM encrypt/decrypt message" + testExplicitAES128GCMEncryptDecrypt + , testCase + "specific encrypt rejects deprecated S2K hash in modern mode" + testExplicitEncryptRejectsDeprecatedS2KHash + , testCase + "legacy fallback encrypt/decrypt message" + testLegacyFallbackEncryptDecrypt + , testCase + "RFC4880 encryptMessage SEIPDv1 cleartext parses without trailing junk" + testRFC4880EncryptMessageSEIPDv1ParsesCleanly + , testCase + "decryptMessage returns typed parse failures" + testDecryptMessageTypedParseFailure + , testCase + "decryptMessage rejects unknown critical packets" + testDecryptMessageRejectsUnknownCriticalPacket + , testCase + "decryptMessage returns typed decrypt failures" + testDecryptMessageTypedDecryptFailure + , testCase + "decryptMessage rejects SEIPDv1 MDC tampering" + testDecryptMessageSEIPDv1MDCTampering + , testCase "sign message shape" testSignMessageShape + , testCase "sign message shape (RSA SigV6)" testSignMessageRSAV6 + , testCase "sign message shape (Ed25519)" testSignMessageEd25519 + , testCase + "sign message shape (Ed25519 SigV6)" + testSignMessageEd25519V6 + , testCase "sign message shape (Ed448)" testSignMessageEd448 + , testCase + "sign message shape (Ed448 SigV6)" + testSignMessageEd448V6 + , testCase + "v4 Ed25519/Ed448 signatures use native fixed-width encoding" + testV4EdSignaturesUseNativeFixedWidthEncoding + , testCase + "v4 Ed25519Legacy key parsing rejects missing 0x40 prefix" + testV4Ed25519LegacyKeyRejectsMissingPrefix + , testCase + "detached v4 Ed25519 verification tolerates missing issuer hints" + testVerifyDetachedEd25519WithoutIssuerHints + , testCase + "detached v4 Ed25519 verification tolerates fake issuer hints" + testVerifyDetachedEd25519WithFakeIssuerHint + , testCase + "detached v4 Ed25519 verifyAgainstKeys tolerates missing issuer hints" + testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys + , testCase + "detached v4 Ed25519 verifyAgainstKeys tolerates fake issuer hints" + testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys + , testCase + "v4 EdDSA signatures verify with Ed25519 key algorithm identifier" + testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm + , testCase + "sign message convenience API" + testSignMessageConvenience + , testCase + "typed verify surface matches legacy results" + testTypedVerifySurfaceMatchesLegacy + , testCase + "strict typed verify rejects tamper" + testVerifyMessageStrictRejectsTamper + , testCase + "verifySignedMessage convenience API" + testVerifySignedMessageConvenience + , testCase + "signature generation primitives" + testSignaturePrimitives + , testCase + "typed signature payload coercions" + testSignatureDataKindsCoercions + , testCase + "typed armor payload helpers centralize block selection" + testTypedArmorPayloadHelpers + , testCase + "recommendedArmorType infers canonical armor labels from packets" + testRecommendedArmorType + , testCase + "singleClearSignedBlock validates cleartext signature envelopes" + testSingleClearSignedBlock + , testCase + "canonical text signature payload normalization" + testCanonicalTextSigPayloadNormalization + , testCase + "canonical text signatures normalize during signing" + testCanonicalTextSignatureSigningPaths + , testCase + "text normalization modes (RFC9580Strict vs CleartextCompat)" + testTextNormalizationModes + ] + , testGroup + "ASCII armor fixture group" + [ testCase + "v4-encrypted-secret.pgp.aa decodes as an encrypted v4 secret key" + testV4EncryptedSecretArmor + , testCase + "v4-encrypted.rev.aa decodes as a v4 revocation certificate" + testV4EncryptedRevocationArmor + , testCase + "v4-encrypted.rev.aa SigV4 key-revocation semantics" + testV4RevocationSignatureSemantics + , testCase + "v4-encrypted.rev.aa parses as single revocation TKUnknown" + ( testRevocationArmorParsesAsSingleTransferableKey + "v4-encrypted.rev.aa" + True + ) + , testCase + "v6.rev.aa decodes as a v6 revocation certificate" + (testV6RevocationArmor "v6.rev.aa") + , testCase + "v6.rev.aa SigV6 salt semantics" + (testV6RevocationSignatureSaltSemantics "v6.rev.aa") + , testCase + "v6.rev.aa forbids legacy Issuer key-id subpackets" + (testV6RevocationSignatureRejectsLegacyIssuerKeyID "v6.rev.aa") + , testCase + "v6.rev.aa parses as single revocation TKUnknown" + (testRevocationArmorParsesAsSingleTransferableKey "v6.rev.aa" True) + , testCase + "v6-encrypted.rev.aa decodes as a v6 revocation certificate" + (testV6RevocationArmor "v6-encrypted.rev.aa") + , testCase + "v6-encrypted.rev.aa SigV6 salt semantics" + (testV6RevocationSignatureSaltSemantics "v6-encrypted.rev.aa") + , testCase + "v6-encrypted.rev.aa forbids legacy Issuer key-id subpackets" + ( testV6RevocationSignatureRejectsLegacyIssuerKeyID + "v6-encrypted.rev.aa" + ) + , testCase + "v6-encrypted.rev.aa parses as single revocation TKUnknown" + ( testRevocationArmorParsesAsSingleTransferableKey + "v6-encrypted.rev.aa" + True + ) + , testCase + "msg1.asc decodes as a parseable armored message" + testMsg1ArmorFixture + ] + , testGroup + "timeline-aware group" + [ testCase + "timeline-aware primary soft revocation keeps pre-revocation signatures" + testSignerTimelineSoftPrimaryRevocation + , testCase + "timeline-aware primary hard revocation rejects historical signatures" + testSignerTimelineHardPrimaryRevocation + , testCase + "timeline-aware no-reason primary revocation rejects historical signatures" + testSignerTimelineNoReasonPrimaryRevocation + , testCase + "timeline-aware unknown-reason primary revocation rejects historical signatures" + testSignerTimelineUnknownReasonPrimaryRevocation + , testCase + "timeline-aware non-compromise primary revocation stays historical until effective" + testSignerTimelineNonCompromisePrimaryRevocationIsHistorical + , testCase + "timeline-aware temporary primary revocation expires and restores validity" + testSignerTimelineTemporaryPrimaryRevocationExpires + , testCase + "timeline-aware subkey revocation distinguishes pre/post signatures" + testSignerTimelineSubkeyRevocation + ] + ] + +testV4EncryptedSecretArmor :: Assertion +testV4EncryptedSecretArmor = do + armors <- loadArmor "v4-encrypted-secret.pgp.aa" + armor <- + case armors of + [a] -> pure a + _ -> + assertFailure + "v4 encrypted secret fixture should contain one armored payload" + >> fail "expected one armored payload" + (headers, payload) <- + case armor of + Armor ArmorPrivateKeyBlock hs p -> pure (hs, p) + Armor atype _ _ -> + assertFailure + ( "v4 encrypted secret fixture should decode as a private key block, got " + ++ show atype + ) + >> fail "expected private key block" + _ -> + assertFailure + "v4 encrypted secret fixture should decode as an armored payload" + >> fail "expected armored payload" + assertEqual + "v4 encrypted secret fixture should keep identifying comments" + [ ("Comment", "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") + , ("Comment", "") + , ("Comment", "v4 Test User") + ] + headers + let packets = parsePkts payload + userIds = [u | UserIdPkt u <- packets] + primarySecretKeys = [(pkp, ska) | SecretKeyPkt pkp ska <- packets] + secretSubkeys = [(pkp, ska) | SecretSubkeyPkt pkp ska <- packets] + assertEqual + "v4 encrypted secret fixture should include expected user IDs" + ["", "v4 Test User"] + userIds + assertEqual + "v4 encrypted secret fixture should contain one primary secret key packet" + 1 + (length primarySecretKeys) + assertEqual + "v4 encrypted secret fixture should contain three encrypted secret subkeys" + 3 + (length secretSubkeys) + case packets of + (SecretKeyPkt pkp ska : _) -> do + assertEqual + "v4 encrypted secret fixture should contain a v4 primary key" + V4 + (_keyVersion pkp) + assertEqual + "v4 encrypted secret fixture should have the expected primary-key fingerprint" + (fp "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") + (fingerprint pkp) + assertEqual + "v4 encrypted secret fixture should use EdDSA for its primary key" + EdDSA + (_pkalgo pkp) + assertEncryptedS2K "primary key" ska + mapM_ (assertEncryptedS2K "subkey" . snd) secretSubkeys + assertEqual + "v4 encrypted secret fixture should contain two EdDSA subkeys and one ECDH subkey" + [EdDSA, EdDSA, ECDH] + (map (_pkalgo . fst) secretSubkeys) + _ -> + assertFailure + "v4 encrypted secret fixture should start with a secret key packet" + where + assertEncryptedS2K :: String -> SKAddendum -> Assertion + assertEncryptedS2K testLabel ska = + case ska of + SUSSHA1 AES256 (IteratedSalted SHA256 _ iter) _ encryptedPayload -> do + assertEqual + (testLabel ++ " should use expected S2K iteration count") + (IterationCount 65011712) + iter + if BL.null encryptedPayload + then + assertFailure + (testLabel ++ " should have non-empty encrypted key material") + else pure () + SUUnencrypted _ _ -> + assertFailure + ( testLabel + ++ " should be encrypted, got unencrypted secret material" + ) + _ -> + assertFailure + ( testLabel + ++ " should be encrypted with SUSSHA1/AES256/IteratedSalted SHA256" + ) + +testV4EncryptedRevocationArmor :: Assertion +testV4EncryptedRevocationArmor = do + armors <- loadArmor "v4-encrypted.rev.aa" + armor <- + case armors of + [a] -> pure a + _ -> + assertFailure + "v4 encrypted revocation fixture should contain one armored payload" + >> fail "expected one armored payload" + (headers, payload) <- + case armor of + Armor ArmorPublicKeyBlock hs p -> pure (hs, p) + Armor atype _ _ -> + assertFailure + ( "v4 encrypted revocation fixture should decode as a public key block, got " + ++ show atype + ) + >> fail "expected public key block" + _ -> + assertFailure + "v4 encrypted revocation fixture should decode as an armored payload" + >> fail "expected armored payload" + assertEqual + "v4 encrypted revocation fixture should keep identifying comments" + [ ("Comment", "Revocation certificate for") + , ("Comment", "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") + , ("Comment", "") + , ("Comment", "v4 Test User") + ] + headers + let packets = parsePkts payload + case packets of + [PublicKeyPkt pkp, SignaturePkt _] -> do + assertEqual + "v4 encrypted revocation fixture should contain a v4 public key" + V4 + (_keyVersion pkp) + assertEqual + "v4 encrypted revocation fixture should contain the expected public key fingerprint" + (fp "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") + (fingerprint pkp) + assertEqual + "v4 encrypted revocation fixture should use EdDSA for its public key" + EdDSA + (_pkalgo pkp) + _ -> + assertFailure + ( "v4 encrypted revocation fixture should contain [PublicKeyPkt, SignaturePkt], got: " + ++ show packets + ) + +testV6RevocationArmor :: FilePath -> Assertion +testV6RevocationArmor fixture = do + armors <- loadArmor fixture + armor <- + case armors of + [a] -> pure a + _ -> + assertFailure + (fixture ++ " fixture should contain one armored payload") + >> fail "expected one armored payload" + payload <- + case armor of + Armor ArmorPublicKeyBlock _ p -> pure p + Armor atype _ _ -> + assertFailure + ( fixture + ++ " fixture should decode as a public key block, got " + ++ show atype + ) + >> fail "expected public key block" + _ -> + assertFailure + (fixture ++ " fixture should decode as an armored payload") + >> fail "expected armored payload" + let packets = parsePkts payload + case packets of + [PublicKeyPkt pkp, SignaturePkt sig] -> do + assertEqual + (fixture ++ " should contain a v6 public key") + V6 + (_keyVersion pkp) + case sig of + SigV6 KeyRevocationSig _ _ _ hashed unhashed _ _ -> do + let issuerFps = + [ ifp + | SigSubPacket _ (IssuerFingerprint IssuerFingerprintV6 ifp) <- + hashed ++ unhashed + ] + if fingerprint pkp `elem` issuerFps + then pure () + else + assertFailure + ( fixture + ++ " should include an IssuerFingerprint v6 matching the public key" + ) + _ -> + assertFailure + (fixture ++ " should contain a SigV6 key-revocation signature") + _ -> + assertFailure + ( fixture + ++ " should contain [PublicKeyPkt, SignaturePkt], got: " + ++ show packets + ) + +testV6RevocationSignatureSaltSemantics :: FilePath -> Assertion +testV6RevocationSignatureSaltSemantics fixture = do + armors <- loadArmor fixture + payload <- + case armors of + [Armor ArmorPublicKeyBlock _ p] -> pure p + _ -> + assertFailure + (fixture ++ " should contain one armored public-key payload") + >> fail "expected one armored payload" + let packets = parsePkts payload + (pkp, sig) <- + case packets of + [PublicKeyPkt pk, SignaturePkt sigV6@(SigV6 _ _ _ _ _ _ _ _)] -> pure (pk, sigV6) + _ -> + assertFailure + ( fixture + ++ " should parse as [PublicKeyPkt, SignaturePkt SigV6], got " + ++ show packets + ) + >> fail "unexpected revocation fixture packet shape" + case sig of + SigV6 _ _ ha salt _ _ _ _ -> + case expectedV6SaltSizeForTest ha of + Nothing -> + assertFailure + ( fixture + ++ " uses unsupported v6 signature salt hash algorithm: " + ++ show ha + ) + Just expected -> + assertEqual + (fixture ++ " SigV6 salt size should match hash algorithm") + expected + (fromIntegral (BL.length (unSignatureSalt salt))) + other -> + assertFailure + ( fixture + ++ " expected SigV6 revocation signature payload, got: " + ++ show other + ) + assertBool + ( fixture + ++ " should include IssuerFingerprint v6 for the revoked key" + ) + (signatureHasIssuerFingerprintV6 (fingerprint pkp) sig) + +testV4RevocationSignatureSemantics :: Assertion +testV4RevocationSignatureSemantics = do + armors <- loadArmor "v4-encrypted.rev.aa" + payload <- + case armors of + [Armor ArmorPublicKeyBlock _ p] -> pure p + _ -> + assertFailure + "v4-encrypted.rev.aa should contain one armored public-key payload" + >> fail "expected one armored payload" + let packets = parsePkts payload + case packets of + [ PublicKeyPkt _ + , SignaturePkt (SigV4 KeyRevocationSig _ _ hashed unhashed _ _) + ] -> do + assertBool + "v4-encrypted.rev.aa key-revocation signature should include an Issuer key-id subpacket" + (any isIssuerSubpacket (hashed ++ unhashed)) + _ -> + assertFailure + ( "v4-encrypted.rev.aa should parse as [PublicKeyPkt, SignaturePkt SigV4 KeyRevocationSig], got " + ++ show packets + ) + where + isIssuerSubpacket (SigSubPacket _ Issuer {}) = True + isIssuerSubpacket _ = False + +testV6RevocationSignatureRejectsLegacyIssuerKeyID + :: FilePath -> Assertion +testV6RevocationSignatureRejectsLegacyIssuerKeyID fixture = do + armors <- loadArmor fixture + payload <- + case armors of + [Armor ArmorPublicKeyBlock _ p] -> pure p + _ -> + assertFailure + (fixture ++ " should contain one armored public-key payload") + >> fail "expected one armored payload" + let packets = parsePkts payload + case packets of + [ PublicKeyPkt _ + , SignaturePkt (SigV6 KeyRevocationSig _ _ _ hashed unhashed _ _) + ] -> + assertBool + ( fixture + ++ " SigV6 key-revocation signature must not include Issuer key-id subpackets" + ) + (all (not . isIssuerSubpacket) (hashed ++ unhashed)) + _ -> + assertFailure + ( fixture + ++ " should parse as [PublicKeyPkt, SignaturePkt SigV6 KeyRevocationSig]" + ) + where + isIssuerSubpacket (SigSubPacket _ Issuer {}) = True + isIssuerSubpacket _ = False + +testRevocationArmorParsesAsSingleTransferableKey + :: FilePath -> Bool -> Assertion +testRevocationArmorParsesAsSingleTransferableKey fixture expectDirectRevs = do + armors <- loadArmor fixture + payload <- + case armors of + [Armor ArmorPublicKeyBlock _ p] -> pure p + _ -> + assertFailure + (fixture ++ " should contain one armored public-key payload") + >> fail "expected one armored payload" + let tks = parseUnknownTKs True (parsePkts payload) + case tks of + [tk] -> do + if expectDirectRevs + then + assertBool + ( fixture + ++ " transferable key should contain at least one direct-key revocation signature" + ) + (not (null (_tkuRevs tk))) + else pure () + assertEqual + (fixture ++ " revocation certificate should not carry user IDs") + [] + (_tkuUIDs tk) + assertEqual + ( fixture + ++ " revocation certificate should not carry user attributes" + ) + [] + (_tkuUAts tk) + assertEqual + (fixture ++ " revocation certificate should not carry subkeys") + [] + (_tkuSubs tk) + _ -> + assertFailure + (fixture ++ " should parse into exactly one transferable key") + +testMsg1ArmorFixture :: Assertion +testMsg1ArmorFixture = do + armors <- loadArmor "msg1.asc" + assertBool + "msg1.asc should decode to at least one armor block" + (not (null armors)) + let packetBlocks = + [ parsePkts payload + | Armor _ _ payload <- armors + ] + assertBool + "msg1.asc should contain at least one parseable packet block" + (any (not . null) packetBlocks) + +expectedV6SaltSizeForTest :: HashAlgorithm -> Maybe Int +expectedV6SaltSizeForTest = + fmap fromIntegral . signatureV6SaltSizeForHashAlgorithm + +signatureHasIssuerFingerprintV6 + :: Fingerprint -> SignaturePayload -> Bool +signatureHasIssuerFingerprintV6 expectedFp (SigV6 _ _ _ _ hashed unhashed _ _) = + expectedFp + `elem` [ ifp + | SigSubPacket _ (IssuerFingerprint IssuerFingerprintV6 ifp) <- + hashed ++ unhashed + ] +signatureHasIssuerFingerprintV6 _ _ = False + +testDefaultedEncryptDecrypt :: Assertion +testDefaultedEncryptDecrypt = do + let passphrase = mkPassphrase "roundtrip1" + payload = mkClearPayload "hello from a balloon farm on Mars" + encryptedResult = + encryptMessageDefault + DoNotExposeSessionMaterial + passphrase + payload + encrypted <- + case encryptedResult of + Left err -> + assertFailure ("encryptMessageDefault failed: " ++ show err) + >> fail "encryptMessageDefault failed" + Right (bs, _) -> pure bs + case parsePkts (encryptedPayloadBytes encrypted) of + [ SKESKPkt + (SKESKPayloadV6Packet (SKESKPayloadV6 AES256 OCB _ iv esk tag)) + , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 _ _) + ] -> do + assertBool + "default SKESK v6 IV should be present" + (not (BL.null iv)) + assertBool + "default SKESK v6 wrapped session key should be present" + (not (BL.null esk)) + assertEqual "default SKESK v6 tag length" 16 (BL.length tag) + other -> + assertFailure + ( "default encryption should emit SKESK v6 + SEIPD v2 packets, got " + ++ show other + ) + decrypted <- + case decryptMessage passphrase encrypted of + Left err -> + assertFailure ("decryptMessage failed: " ++ show err) + >> fail "decryptMessage failed" + Right bs -> pure bs + assertEqual + "default encrypt/decrypt payload roundtrip" + payload + decrypted + +testExplicitEncryptDecrypt :: Assertion +testExplicitEncryptDecrypt = do + let passphrase = mkPassphrase "roundtrip2" + payload = mkClearPayload "hello from nonsenseville" + s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 + iv = IV "1234567890ABCDEF" + encrypted <- + case encryptMessage + ( RFC9580EncryptMessageOptions + { rfc9580EncryptMessageExposure = DoNotExposeSessionMaterial + , rfc9580EncryptMessageSymmetricAlgorithm = AES128 + , rfc9580EncryptMessageS2K = s2k + , rfc9580EncryptMessageIV = iv + } + ) + passphrase + payload of + Left err -> + assertFailure ("micro-managed encryption failed: " ++ show err) + >> fail "encryptMessage failed" + Right (bs, _) -> pure bs + case parsePkts (encryptedPayloadBytes encrypted) of + [ SKESKPkt + ( SKESKPayloadV6Packet + (SKESKPayloadV6 AES128 OCB _ packetIv esk tag) + ) + , SymEncIntegrityProtectedDataPkt (SEIPD2 AES128 OCB 6 _ _) + ] -> do + assertBool + "explicit SKESK v6 IV should be present" + (not (BL.null packetIv)) + assertBool + "explicit SKESK v6 wrapped session key should be present" + (not (BL.null esk)) + assertEqual "explicit SKESK v6 tag length" 16 (BL.length tag) + other -> + assertFailure + ( "explicit AES encryption should default to SKESK v6 + SEIPD v2 packets, got " + ++ show other + ) + decrypted <- + case decryptMessage passphrase encrypted of + Left err -> + assertFailure ("decryption failed: " ++ show err) + >> fail "decryptMessage failed" + Right bs -> pure bs + assertEqual + "specific encrypt/decrypt payload roundtrip" + payload + decrypted + +testExplicitEncryptExposesEffectiveSessionMaterial :: Assertion +testExplicitEncryptExposesEffectiveSessionMaterial = do + let passphraseBytes = "roundtrip2-session-material" + passphrase = mkPassphrase passphraseBytes + payload = mkClearPayload "hello from session material town" + sa = AES128 + s2k = Argon2 (Salt16 (B.pack [0x40 .. 0x4f])) 1 4 15 + iv = IV "ABCDEF1234567890" + (encrypted, recovered) <- + case encryptMessage + ( RFC9580EncryptMessageOptions + { rfc9580EncryptMessageExposure = ExposeSessionMaterial + , rfc9580EncryptMessageSymmetricAlgorithm = sa + , rfc9580EncryptMessageS2K = s2k + , rfc9580EncryptMessageIV = iv + } + ) + passphrase + payload of + Left err -> + assertFailure + ("explicit encryption with session material failed: " ++ show err) + >> fail "encryptMessage failed" + Right x -> pure x + expectedSessionKey <- + case keySize sa of + Left err -> + assertFailure + ("failed to derive expected key size: " ++ show err) + >> fail "keySize failed" + Right keyLen -> + case string2Key s2k keyLen passphraseBytes of + Left err -> + assertFailure + ("failed to derive expected session key: " ++ renderS2KError err) + >> fail "string2Key failed" + Right bs -> pure bs + case recovered of + Just recoveredSessionMaterial -> do + assertEqual + "recovered session material algorithm" + sa + (recoveredSessionAlgorithm recoveredSessionMaterial) + assertEqual + "recovered session material key" + (SessionKey expectedSessionKey) + (recoveredSessionKey recoveredSessionMaterial) + Nothing -> + assertFailure "expected exposed session material" + decrypted <- + case decryptMessage passphrase encrypted of + Left err -> + assertFailure ("decryption failed: " ++ show err) + >> fail "decryptMessage failed" + Right bs -> pure bs + assertEqual + "session-material exposing encrypt/decrypt payload roundtrip" + payload + decrypted + +testDefaultEncryptDoesNotExposeSessionMaterial :: Assertion +testDefaultEncryptDoesNotExposeSessionMaterial = do + let passphrase = mkPassphrase "roundtrip-default-no-session-material" + payload = mkClearPayload "hello from hidden-session-material town" + (_, recovered) <- + do + let encryptedResult = + encryptMessageDefault + DoNotExposeSessionMaterial + passphrase + payload + case encryptedResult of + Left err -> + assertFailure + ("default encryption with exposure mode failed: " ++ show err) + >> fail "encryptMessageDefault failed" + Right x -> pure x + case recovered of + Nothing -> pure () + Just _ -> + assertFailure + "default exposure mode should not return session material" + +testExplicitAES128AEADEncryptDecrypt + :: AEADAlgorithm -> Int -> String -> Assertion +testExplicitAES128AEADEncryptDecrypt aead expectedIvLen label = do + let passphraseBytes = + "roundtrip-" + <> BL.fromStrict (B.pack (map (fromIntegral . fromEnum) label)) + passphrase = mkPassphrase passphraseBytes + payload = + mkClearPayload + ( "hello from " + <> BL.fromStrict (B.pack (map (fromIntegral . fromEnum) label)) + ) + s2k = Argon2 (Salt16 (B.pack [0x10 .. 0x1f])) 1 4 15 + salt = Salt (B.pack [0x20 .. 0x3f]) + block = + Block + [ LiteralDataPkt BinaryData BL.empty 0 (clearPayloadBytes payload) + ] + packets <- + case encryptSEIPDv2WithSKESKBlock + AES128 + aead + 6 + salt + s2k + passphraseBytes + block of + Left err -> + assertFailure + ("AES-128 " ++ label ++ " encryption failed: " ++ err) + >> fail "encryptSEIPDv2WithSKESKBlock failed" + Right ps -> pure ps + let encrypted = mkEncryptedPayload (runPut (put (Block packets))) + case parsePkts (encryptedPayloadBytes encrypted) of + [ SKESKPkt + ( SKESKPayloadV6Packet + (SKESKPayloadV6 AES128 parsedAead _ iv esk tag) + ) + , SymEncIntegrityProtectedDataPkt (SEIPD2 AES128 payloadAead 6 _ _) + ] -> do + assertEqual + ("AES-128 " ++ label ++ " SKESK AEAD") + aead + parsedAead + assertEqual + ("AES-128 " ++ label ++ " payload AEAD") + aead + payloadAead + assertEqual + ("AES-128 " ++ label ++ " SKESK v6 IV length") + (fromIntegral expectedIvLen) + (BL.length iv) + assertBool + ("AES-128 " ++ label ++ " wrapped session key should be present") + (not (BL.null esk)) + assertEqual + ("AES-128 " ++ label ++ " SKESK tag length") + 16 + (BL.length tag) + other -> + assertFailure + ( "AES-128 " + ++ label + ++ " encryption should emit matching SKESK v6 + SEIPD v2 packets, got " + ++ show other + ) + decrypted <- + case decryptMessage passphrase encrypted of + Left err -> + assertFailure + ("AES-128 " ++ label ++ " decryption failed: " ++ show err) + >> fail "decryptMessage failed" + Right bs -> pure bs + assertEqual + ("AES-128 " ++ label ++ " payload roundtrip") + payload + decrypted + +testExplicitAES128EAXEncryptDecrypt :: Assertion +testExplicitAES128EAXEncryptDecrypt = do + let passphraseBytes = "roundtrip-EAX" + s2k = Argon2 (Salt16 (B.pack [0x10 .. 0x1f])) 1 4 15 + salt = Salt (B.pack [0x20 .. 0x3f]) + block = Block [LiteralDataPkt BinaryData BL.empty 0 "hello from EAX"] + case encryptSEIPDv2WithSKESKBlock + AES128 + EAX + 6 + salt + s2k + passphraseBytes + block of + Left err + | "EAX is currently unsupported by the crypton AEAD backend" + `isInfixOf` err -> + pure () + | otherwise -> + assertFailure + ("expected explicit EAX backend limitation, got: " ++ err) + Right packets -> + assertFailure + ( "expected AES-128 EAX encryption to fail explicitly, got packets: " + ++ show packets + ) + +testExplicitAES128GCMEncryptDecrypt :: Assertion +testExplicitAES128GCMEncryptDecrypt = + testExplicitAES128AEADEncryptDecrypt GCM 12 "GCM" + +testExplicitEncryptRejectsDeprecatedS2KHash :: Assertion +testExplicitEncryptRejectsDeprecatedS2KHash = do + let passphrase = mkPassphrase "roundtrip2b" + payload = mkClearPayload "modern-path deprecated s2k hash rejection" + s2k = Salted SHA1 (Salt8 "12345678") + iv = IV "1234567890ABCDEF" + case encryptMessage + ( RFC9580EncryptMessageOptions + { rfc9580EncryptMessageExposure = DoNotExposeSessionMaterial + , rfc9580EncryptMessageSymmetricAlgorithm = AES128 + , rfc9580EncryptMessageS2K = s2k + , rfc9580EncryptMessageIV = iv + } + ) + passphrase + payload of + Left (MessageEncryptError err) + | "deprecated hash algorithm disallowed for modern message generation" + `isInfixOf` err -> + pure () + | otherwise -> + assertFailure + ("Expected deprecated modern S2K hash rejection, got: " ++ err) + Left err -> + assertFailure + ( "Expected MessageEncryptError for deprecated modern S2K hash, got " + ++ show err + ) + Right _ -> + assertFailure + "Expected encryptMessage AES128 to reject deprecated SHA1 S2K" + +testLegacyFallbackEncryptDecrypt :: Assertion +testLegacyFallbackEncryptDecrypt = do + let passphrase = mkPassphrase "roundtrip3" + payload = mkClearPayload "hello from legacy town" + s2k = Salted SHA1 (Salt8 "12345678") + iv = IV mempty + encrypted <- + case encryptMessage + ( RFC4880EncryptMessageOptions + { rfc4880EncryptMessageExposure = DoNotExposeSessionMaterial + , rfc4880EncryptMessageSymmetricAlgorithm = Plaintext + , rfc4880EncryptMessageS2K = s2k + , rfc4880EncryptMessageIV = iv + } + ) + passphrase + payload of + Left err -> + assertFailure ("legacy fallback encryption failed: " ++ show err) + >> fail "encryptMessage fallback failed" + Right (bs, _) -> pure bs + case parsePkts (encryptedPayloadBytes encrypted) of + [ SKESKPkt + (SKESKPayloadV4Packet (SKESKPayloadV4 Plaintext _ Nothing)) + , SymEncIntegrityProtectedDataPkt (SEIPD1 1 _) + ] -> pure () + other -> + assertFailure + ( "non-AES explicit encryption should use RFC4880 SKESKv4 + SEIPDv1 packets, got " + ++ show other + ) + decrypted <- + case decryptMessage passphrase encrypted of + Left err -> + assertFailure ("legacy fallback decryption failed: " ++ show err) + >> fail "decryptMessage fallback failed" + Right bs -> pure bs + assertEqual + "legacy fallback encrypt/decrypt payload roundtrip" + payload + decrypted + +testRFC4880EncryptMessageSEIPDv1ParsesCleanly :: Assertion +testRFC4880EncryptMessageSEIPDv1ParsesCleanly = do + let passphraseBytes = "legacy-clean-parse" :: BL.ByteString + passphrase = mkPassphrase passphraseBytes + payload = mkClearPayload "hello from clean legacy town" + s2k = + IteratedSalted SHA256 (Salt8 "saltxyz!") (IterationCount 65536) + iv = IV "1234567890ABCDEF" + encrypted <- + case encryptMessage + ( RFC4880EncryptMessageOptions + { rfc4880EncryptMessageExposure = DoNotExposeSessionMaterial + , rfc4880EncryptMessageSymmetricAlgorithm = AES128 + , rfc4880EncryptMessageS2K = s2k + , rfc4880EncryptMessageIV = iv + } + ) + passphrase + payload of + Left err -> + assertFailure ("RFC4880 encryption failed: " ++ show err) + >> fail "encryptMessage failed" + Right (bs, _) -> pure bs + packets <- + case parsePktsEither (encryptedPayloadBytes encrypted) of + Left err -> + assertFailure ("encrypted packet parse failed: " ++ show err) + >> fail "parsePktsEither failed" + Right ps -> pure ps + ciphertext <- + case packets of + [ SKESKPkt + (SKESKPayloadV4Packet (SKESKPayloadV4 parsedSA parsedS2K Nothing)) + , SymEncIntegrityProtectedDataPkt (SEIPD1 1 payloadBytes) + ] -> do + assertEqual "RFC4880 encrypted SKESK algorithm" AES128 parsedSA + assertEqual "RFC4880 encrypted S2K" s2k parsedS2K + pure (BL.toStrict payloadBytes) + other -> + assertFailure + ( "RFC4880 encryption should emit SKESKv4 + SEIPDv1 packets, got " + ++ show other + ) + >> fail "unexpected encrypted packet layout" + keyLen <- + case keySize AES128 of + Left err -> + assertFailure ("keySize failed for AES128: " ++ show err) + >> fail "keySize failed" + Right n -> pure n + sessionKey <- + case string2Key s2k keyLen passphraseBytes of + Left err -> + assertFailure ("string2Key failed: " ++ renderS2KError err) + >> fail "string2Key failed" + Right keyBytes -> pure keyBytes + (nonce, decrypted) <- + case decryptPreservingNonce AES128 ciphertext sessionKey of + Left err -> + assertFailure ("decryptPreservingNonce failed: " ++ show err) + >> fail "decryptPreservingNonce failed" + Right out -> pure out + cleartext <- + case validateSEIPD1MDC nonce decrypted of + Left err -> + assertFailure ("validateSEIPD1MDC failed: " ++ err) + >> fail "validateSEIPD1MDC failed" + Right out -> pure out + case parsePktsEither (BL.fromStrict cleartext) of + Right [LiteralDataPkt BinaryData filename timestamp clearPayload] -> do + assertEqual + "RFC4880 decrypted literal filename" + BL.empty + filename + assertEqual "RFC4880 decrypted literal timestamp" 0 timestamp + assertEqual + "RFC4880 decrypted literal payload" + (clearPayloadBytes payload) + clearPayload + Right other -> + assertFailure + ( "RFC4880 decrypted cleartext should contain exactly one literal packet, got " + ++ show other + ) + Left err -> + assertFailure + ( "RFC4880 decrypted cleartext should parse without trailing junk, got " + ++ show err + ) + +testDecryptMessageTypedParseFailure :: Assertion +testDecryptMessageTypedParseFailure = do + let passphrase = mkPassphrase "unused" + encrypted = mkEncryptedPayload BL.empty + case decryptMessage passphrase encrypted of + Left (MessageParseFailureError MissingEncryptedMessage) -> pure () + Left err -> + assertFailure + ( "Expected MissingEncryptedMessage parse failure, got " + ++ show err + ) + Right clear -> + assertFailure + ("Expected parse failure, got payload " ++ show clear) + +testDecryptMessageRejectsUnknownCriticalPacket :: Assertion +testDecryptMessageRejectsUnknownCriticalPacket = do + let passphrase = mkPassphrase "unused" + encrypted = + mkEncryptedPayload . runPut . put $ + Block [OtherPacketPkt 39 "unknown-critical"] + case decryptMessage passphrase encrypted of + Left (MessageParseFailureError (UnknownCriticalPacketType 39)) -> pure () + Left err -> + assertFailure + ( "Expected UnknownCriticalPacketType 39 parse failure, got " + ++ show err + ) + Right clear -> + assertFailure + ( "Expected unknown critical packet rejection, got payload " + ++ show clear + ) + +testDecryptMessageTypedDecryptFailure :: Assertion +testDecryptMessageTypedDecryptFailure = do + let correctPassphrase = mkPassphrase "correct passphrase" + wrongPassphrase = mkPassphrase "wrong passphrase" + payload = mkClearPayload "typed decrypt failure payload" + encryptedResult = + encryptMessageDefault + DoNotExposeSessionMaterial + correctPassphrase + payload + encrypted <- + case encryptedResult of + Left err -> + assertFailure ("encryptMessageDefault failed: " ++ show err) + >> fail "encryptMessageDefault failed" + Right (bs, _) -> pure bs + case decryptMessage wrongPassphrase encrypted of + Left (MessageDecryptFailureError (PayloadDecryptFailed _)) -> pure () + Left + (MessageDecryptFailureError (SessionMaterialDerivationFailed _)) -> pure () + Left err -> + assertFailure + ("Expected typed decrypt failure, got " ++ show err) + Right clear -> + assertFailure + ("Expected decrypt failure, got payload " ++ show clear) + +testDecryptMessageSEIPDv1MDCTampering :: Assertion +testDecryptMessageSEIPDv1MDCTampering = do + let passphrase = mkPassphrase "mdc-tamper-test" + payload = mkClearPayload "payload for MDC tampering test" + s2k = + IteratedSalted SHA256 (Salt8 "saltxyz!") (IterationCount 65536) + iv = IV "1234567890ABCDEF" + encrypted <- + case encryptMessage + ( RFC4880EncryptMessageOptions + { rfc4880EncryptMessageExposure = + DoNotExposeSessionMaterial + , rfc4880EncryptMessageSymmetricAlgorithm = AES128 + , rfc4880EncryptMessageS2K = s2k + , rfc4880EncryptMessageIV = iv + } + ) + passphrase + payload of + Left err -> + assertFailure ("SEIPDv1 encryption failed: " ++ show err) + >> fail "encryptMessage failed" + Right (bs, _) -> pure bs + let raw = encryptedPayloadBytes encrypted + midpoint = BL.length raw `div` 2 + tampered = + BL.take midpoint raw + <> BL.cons + (BL.head (BL.drop midpoint raw) `xor` 0xFF) + (BL.drop (midpoint + 1) raw) + case decryptMessage passphrase (mkEncryptedPayload tampered) of + Left (MessageDecryptFailureError (PayloadDecryptFailed msg)) + | "MDC" `isInfixOf` msg -> pure () + | otherwise -> + assertFailure + ("Expected MDC-related PayloadDecryptFailed, got: " ++ msg) + Left err -> + assertFailure + ("Expected PayloadDecryptFailed with MDC error, got: " ++ show err) + Right _ -> + assertFailure + "Expected MDC tampering rejection, but decryption succeeded" + +testSignMessageShape :: Assertion +testSignMessageShape = do + (signer, signingKey) <- loadUnencryptedRsaSigner + signerV4 <- expectV4PKPayload "RSA v4 signer" signer + signedResult <- + signMessageWith + (mkRSASignerV4 signerV4 signingKey) + (mkClearPayload "message-api signing payload") + signedMessage <- + case signedResult of + Left err -> + assertFailure ("message signing failed: " ++ show err) + >> pure mempty + Right bs -> pure bs + case parsePkts signedMessage of + [LiteralDataPkt {}, SignaturePkt _] -> pure () + _ -> + assertFailure + "signing output should contain literal data and one signature packet" + +testSignMessageRSAV6 :: Assertion +testSignMessageRSAV6 = do + (signer, signingKey) <- loadUnencryptedRsaSignerV6 + signerV6 <- expectV6PKPayload "RSA v6 signer" signer + let payload = "message-api signing payload with RSA SigV6" + signedResult <- + signMessageWith + (mkRSASignerV6 signerV6 signingKey) + (mkClearPayload payload) + signedMessage <- + case signedResult of + Left err -> + assertFailure ("RSA SigV6 message signing failed: " ++ show err) + >> pure mempty + Right bs -> pure bs + signaturePkt <- + case parsePkts signedMessage of + [ LiteralDataPkt {} + , sig@(SignaturePkt (SigV6 BinarySig RSA SHA512 salt _ _ _ _)) + ] -> do + assertEqual + "SigV6 RSA salt must be 32 bytes for SHA512" + 32 + (BL.length (unSignatureSalt salt)) + pure sig + other -> + assertFailure + ( "RSA SigV6 signing output should contain [LiteralDataPkt, RSA SigV6], got " + ++ show other + ) + >> fail "unexpected RSA SigV6 signMessage output shape" + let state = + emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = [TKUnknown (signer, Nothing) [] [] [] []] + case verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys keyring) + signaturePkt + state + Nothing of + Left err -> + assertFailure + ( "RSA SigV6 signed message verification failed: " + ++ renderVerificationError err + ) + Right _ -> pure () + +testSignMessageEd25519 :: Assertion +testSignMessageEd25519 = do + (signer, signingKey) <- loadDeterministicEd25519Signer + signerV4 <- expectV4PKPayload "Ed25519 v4 signer" signer + let payload = "message-api signing payload with Ed25519" + signedResult <- + signMessageWith + (mkEd25519SignerV4 signerV4 signingKey) + (mkClearPayload payload) + signedMessage <- + case signedResult of + Left err -> + assertFailure ("Ed25519 message signing failed: " ++ show err) + >> pure mempty + Right bs -> pure bs + signaturePkt <- + case parsePkts signedMessage of + [ LiteralDataPkt {} + , sig@(SignaturePkt (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _)) + ] -> + pure sig + other -> + assertFailure + ( "Ed25519 signing output should contain [LiteralDataPkt, Ed25519 SigV4], got " + ++ show other + ) + >> fail "unexpected Ed25519 signMessage output shape" + let state = + emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = [TKUnknown (signer, Nothing) [] [] [] []] + case verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys keyring) + signaturePkt + state + Nothing of + Left err -> + assertFailure + ( "Ed25519 signed message verification failed: " + ++ renderVerificationError err + ) + Right _ -> pure () + +testSignMessageEd25519V6 :: Assertion +testSignMessageEd25519V6 = do + (signer, signingKey) <- loadDeterministicEd25519SignerV6 + signerV6 <- expectV6PKPayload "Ed25519 v6 signer" signer + let payload = "message-api signing payload with Ed25519 SigV6" + signedResult <- + signMessageWith + (mkEd25519SignerV6 signerV6 signingKey) + (mkClearPayload payload) + signedMessage <- + case signedResult of + Left err -> + assertFailure + ("Ed25519 SigV6 message signing failed: " ++ show err) + >> pure mempty + Right bs -> pure bs + signaturePkt <- + case parsePkts signedMessage of + [ LiteralDataPkt {} + , sig@(SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _)) + ] -> do + assertEqual + "SigV6 Ed25519 salt must be 32 bytes for SHA512" + 32 + (BL.length (unSignatureSalt salt)) + pure sig + other -> + assertFailure + ( "Ed25519 SigV6 signing output should contain [LiteralDataPkt, Ed25519 SigV6], got " + ++ show other + ) + >> fail "unexpected Ed25519 SigV6 signMessage output shape" + case signaturePkt of + SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 _ _ _ _ _) -> do + let state = + emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = [TKUnknown (signer, Nothing) [] [] [] []] + case verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys keyring) + signaturePkt + state + Nothing of + Left err -> + assertFailure + ( "Ed25519 SigV6 signed message verification failed: " + ++ renderVerificationError err + ) + Right _ -> pure () + _ -> assertFailure "expected an Ed25519 SigV6 signature packet" + +testV4Ed25519LegacyKeyRejectsMissingPrefix :: Assertion +testV4Ed25519LegacyKeyRejectsMissingPrefix = do + let legacyEd25519Oid = B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] + rawEd25519Public = B.replicate 32 0x01 + encoded = + runPut $ do + putWord8 4 + putWord32be 0 + putWord8 (fromFVal EdDSA) + putWord8 (fromIntegral (B.length legacyEd25519Oid)) + putByteString legacyEd25519Oid + putWord16be 256 + putByteString rawEd25519Public + case runGetOrFail (get :: Get SomePKPayload) encoded of + Left (_, _, err) -> + assertBool + ("expected invalid-legacy-point parse failure, got: " ++ err) + ("invalid Ed25519Legacy public key" `isInfixOf` err) + Right _ -> + assertFailure + "legacy Ed25519 key without 0x40 prefix should be rejected" + +testSignMessageEd448 :: Assertion +testSignMessageEd448 = do + (signer, signingKey) <- loadDeterministicEd448Signer + signerV4 <- expectV4PKPayload "Ed448 v4 signer" signer + let payload = "message-api signing payload with Ed448" + signedResult <- + signMessageWith + (mkEd448SignerV4 signerV4 signingKey) + (mkClearPayload payload) + signedMessage <- + case signedResult of + Left err -> + assertFailure ("Ed448 message signing failed: " ++ show err) + >> pure mempty + Right bs -> pure bs + signaturePkt <- + case parsePkts signedMessage of + [ LiteralDataPkt {} + , sig@(SignaturePkt (SigV4 BinarySig PKA.Ed448 SHA512 _ _ _ _)) + ] -> + pure sig + other -> + assertFailure + ( "Ed448 signing output should contain [LiteralDataPkt, Ed448 SigV4], got " + ++ show other + ) + >> fail "unexpected Ed448 signMessage output shape" + let state = + emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = [TKUnknown (signer, Nothing) [] [] [] []] + case verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys keyring) + signaturePkt + state + Nothing of + Left err -> + assertFailure + ( "Ed448 signed message verification failed: " + ++ renderVerificationError err + ) + Right _ -> pure () + +testSignMessageEd448V6 :: Assertion +testSignMessageEd448V6 = do + (signer, signingKey) <- loadDeterministicEd448SignerV6 + signerV6 <- expectV6PKPayload "Ed448 v6 signer" signer + let payload = "message-api signing payload with Ed448 SigV6" + signedResult <- + signMessageWith + (mkEd448SignerV6 signerV6 signingKey) + (mkClearPayload payload) + signedMessage <- + case signedResult of + Left err -> + assertFailure + ("Ed448 SigV6 message signing failed: " ++ show err) + >> pure mempty + Right bs -> pure bs + signaturePkt <- + case parsePkts signedMessage of + [ LiteralDataPkt {} + , sig@(SignaturePkt (SigV6 BinarySig PKA.Ed448 SHA512 salt _ _ _ _)) + ] -> do + assertEqual + "SigV6 Ed448 salt must be 32 bytes for SHA512" + 32 + (BL.length (unSignatureSalt salt)) + pure sig + other -> + assertFailure + ( "Ed448 SigV6 signing output should contain [LiteralDataPkt, Ed448 SigV6], got " + ++ show other + ) + >> fail "unexpected Ed448 SigV6 signMessage output shape" + case signaturePkt of + SignaturePkt (SigV6 BinarySig PKA.Ed448 SHA512 _ _ _ _ _) -> pure () + _ -> assertFailure "expected an Ed448 SigV6 signature packet" + +testV4EdSignaturesUseNativeFixedWidthEncoding :: Assertion +testV4EdSignaturesUseNativeFixedWidthEncoding = do + (_, ed25519SigningKey) <- loadDeterministicEd25519Signer + ed25519Sig <- + case signDataWithEd25519 + BinarySig + ed25519SigningKey + [] + [] + "v4 ed25519 encoding" of + Left err -> + assertFailure + ("Ed25519 v4 signing failed: " ++ renderSignError err) + >> fail "expected Ed25519 signature" + Right sig -> pure sig + case extractV4SignatureAlgorithmFields (runPut (put ed25519Sig)) of + Left err -> + assertFailure + ( "failed to decode serialized Ed25519 v4 signature payload: " + ++ err + ) + Right (pka, algorithmFields) -> do + assertEqual + "Ed25519 v4 signature packet algorithm id" + PKA.Ed25519 + pka + assertEqual + "Ed25519 v4 algorithm field width" + 64 + (B.length algorithmFields) + + (_, ed448SigningKey) <- loadDeterministicEd448Signer + ed448Sig <- + case signDataWithEd448 + BinarySig + ed448SigningKey + [] + [] + "v4 ed448 encoding" of + Left err -> + assertFailure + ("Ed448 v4 signing failed: " ++ renderSignError err) + >> fail "expected Ed448 signature" + Right sig -> pure sig + case extractV4SignatureAlgorithmFields (runPut (put ed448Sig)) of + Left err -> + assertFailure + ("failed to decode serialized Ed448 v4 signature payload: " ++ err) + Right (pka, algorithmFields) -> do + assertEqual + "Ed448 v4 signature packet algorithm id" + PKA.Ed448 + pka + assertEqual + "Ed448 v4 algorithm field width" + 114 + (B.length algorithmFields) + +testVerifyDetachedEd25519WithoutIssuerHints :: Assertion +testVerifyDetachedEd25519WithoutIssuerHints = do + (signer, signingKey) <- loadDeterministicEd25519Signer + let payload = "detached v4 eddsa payload without issuer hints" + state = + emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []] + sigPayload <- + case signDataWithEd25519 BinarySig signingKey [] [] payload of + Left err -> + assertFailure + ("Ed25519 detached signing failed: " ++ renderSignError err) + >> fail (renderSignError err) + Right sig -> pure sig + case verifySigWith + defaultVerificationPolicy + (verifyAgainstKeyring keyring) + (SignaturePkt sigPayload) + state + Nothing of + Left err -> + assertFailure + ( "Ed25519 detached verification without issuer hints failed: " + ++ renderVerificationError err + ) + Right _ -> pure () + +testVerifyDetachedEd25519WithFakeIssuerHint :: Assertion +testVerifyDetachedEd25519WithFakeIssuerHint = do + (signer, signingKey) <- loadDeterministicEd25519Signer + let payload = "detached v4 eddsa payload with fake issuer hint" + state = + emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []] + fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef" + unhashed = [SigSubPacket False (Issuer fakeIssuer)] + sigPayload <- + case signDataWithEd25519 BinarySig signingKey [] unhashed payload of + Left err -> + assertFailure + ("Ed25519 detached signing failed: " ++ renderSignError err) + >> fail (renderSignError err) + Right sig -> pure sig + case verifySigWith + defaultVerificationPolicy + (verifyAgainstKeyring keyring) + (SignaturePkt sigPayload) + state + Nothing of + Left err -> + assertFailure + ( "Ed25519 detached verification with fake issuer hint failed: " + ++ renderVerificationError err + ) + Right _ -> pure () + +testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys + :: Assertion +testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys = do + (signer, signingKey) <- loadDeterministicEd25519Signer + let payload = + "detached v4 eddsa payload without issuer hints (verifyAgainstKeys)" + state = + emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keys = [TKUnknown (signer, Nothing) [] [] [] []] + sigPayload <- + case signDataWithEd25519 BinarySig signingKey [] [] payload of + Left err -> + assertFailure + ("Ed25519 detached signing failed: " ++ renderSignError err) + >> fail (renderSignError err) + Right sig -> pure sig + case verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys keys) + (SignaturePkt sigPayload) + state + Nothing of + Left err -> + assertFailure + ( "Ed25519 detached verification against keys without issuer hints failed: " + ++ renderVerificationError err + ) + Right _ -> pure () + +testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys + :: Assertion +testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys = do + (signer, signingKey) <- loadDeterministicEd25519Signer + let payload = + "detached v4 eddsa payload with fake issuer hint (verifyAgainstKeys)" + state = + emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keys = [TKUnknown (signer, Nothing) [] [] [] []] + fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef" + unhashed = [SigSubPacket False (Issuer fakeIssuer)] + sigPayload <- + case signDataWithEd25519 BinarySig signingKey [] unhashed payload of + Left err -> + assertFailure + ("Ed25519 detached signing failed: " ++ renderSignError err) + >> fail (renderSignError err) + Right sig -> pure sig + case verifySigWith + defaultVerificationPolicy + (verifyAgainstKeys keys) + (SignaturePkt sigPayload) + state + Nothing of + Left err -> + assertFailure + ( "Ed25519 detached verification against keys with fake issuer hint failed: " + ++ renderVerificationError err + ) + Right _ -> pure () + +testCanonicalTextSigPayloadNormalization :: Assertion +testCanonicalTextSigPayloadNormalization = do + let state = + emptyPSC + { lastLD = + LiteralDataPkt + TextData + BL.empty + (ThirtyTwoBitTimeStamp 0) + "line1 \t\nline2\t \rline3\t \r\nline4 \t" + } + assertEqual + "Binary signatures preserve original line endings" + "line1 \t\nline2\t \rline3\t \r\nline4 \t" + (payloadForSig BinarySig state) + assertEqual + "Canonical text signatures normalize line endings and trim trailing whitespace" + "line1\r\nline2\r\nline3\r\nline4" + (payloadForSig CanonicalTextSig state) + +testTextNormalizationModes :: Assertion +testTextNormalizationModes = do + let state = + emptyPSC + { lastLD = + LiteralDataPkt + TextData + BL.empty + (ThirtyTwoBitTimeStamp 0) + "line1 \t\nline2\t \r\nline3" + } + let cleartextResult = payloadForSigWith CleartextCompat CanonicalTextSig state + strictResult = payloadForSigWith RFC9580Strict CanonicalTextSig state + assertEqual + "CleartextCompat mode strips trailing whitespace per line" + "line1\r\nline2\r\nline3" + cleartextResult + assertEqual + "RFC9580Strict mode preserves trailing whitespace (CRLF-only normalization)" + "line1 \t\r\nline2\t \r\nline3" + strictResult + (signer, signingKey) <- loadUnencryptedRsaSigner + issuerKeyId <- + case eightOctetKeyID signer of + Left err -> + assertFailure ("failed to derive issuer key id: " ++ err) + >> fail "expected issuer key id" + Right i -> pure i + let payload = "line with trailing space \nno trailing space\n" + hashed = + [ SigSubPacket + False + (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer)) + ] + unhashed = [SigSubPacket False (Issuer issuerKeyId)] + builderCompat = sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512 + builderStrict = + (sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512) + { sbTextNormMode = RFC9580Strict + } + withSubs b = + addUnhashedSubs + (listToUnhashedSubs unhashed) + (addHashedSubs (listToHashedSubs hashed) b) + bc = withSubs builderCompat + bs = withSubs builderStrict + sigCompat <- case signDataWithRSABuilder bc signingKey payload of + Left err -> + assertFailure + ("CleartextCompat sign failed: " ++ renderSignError err) + >> fail "" + Right s -> pure s + sigStrict <- case signDataWithRSABuilder bs signingKey payload of + Left err -> + assertFailure + ("RFC9580Strict sign failed: " ++ renderSignError err) + >> fail "" + Right s -> pure s + assertBool + "CleartextCompat and RFC9580Strict produce different signatures for payloads with trailing whitespace" + (sigCompat /= sigStrict) + +testCanonicalTextSignatureSigningPaths :: Assertion +testCanonicalTextSignatureSigningPaths = do + (signer, signingKey) <- loadUnencryptedRsaSigner + issuerKeyId <- + case eightOctetKeyID signer of + Left err -> + assertFailure ("failed to derive issuer key id: " ++ err) + >> fail "expected issuer key id" + Right i -> pure i + let mixedPayload = "line1 \t\nline2\t \rline3\t \r\nline4 \t" + normalizedPayload = "line1\r\nline2\r\nline3\r\nline4" + hashed = + [ SigSubPacket + False + (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer)) + ] + unhashed = [SigSubPacket False (Issuer issuerKeyId)] + primitiveMixed <- + case signDataWithRSA + CanonicalTextSig + signingKey + hashed + unhashed + mixedPayload of + Left err -> + assertFailure + ( "canonical text primitive signing failed: " + ++ renderSignError err + ) + >> fail (renderSignError err) + Right sig -> pure sig + primitiveNormalized <- + case signDataWithRSA + CanonicalTextSig + signingKey + hashed + unhashed + normalizedPayload of + Left err -> + assertFailure + ( "canonical text primitive signing (normalized payload) failed: " + ++ renderSignError err + ) + >> fail (renderSignError err) + Right sig -> pure sig + assertEqual + "primitive canonical text signing should normalize mixed line endings" + primitiveNormalized + primitiveMixed + + let builder = sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512 + withHashed = addHashedSubs (listToHashedSubs hashed) builder + withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed + builderMixed <- + case signDataWithRSABuilder withUnhashed signingKey mixedPayload of + Left err -> + assertFailure + ("canonical text builder signing failed: " ++ renderSignError err) + >> fail (renderSignError err) + Right sig -> pure sig + builderNormalized <- + case signDataWithRSABuilder withUnhashed signingKey normalizedPayload of + Left err -> + assertFailure + ( "canonical text builder signing (normalized payload) failed: " + ++ renderSignError err + ) + >> fail (renderSignError err) + Right sig -> pure sig + assertEqual + "builder canonical text signing should normalize mixed line endings" + builderNormalized + builderMixed + +testSignaturePrimitives :: Assertion +testSignaturePrimitives = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let userId = UserId "primitive-api@example.org" + assertSigType + :: String + -> SigType + -> Either SignError SignaturePayload + -> Assertion + assertSigType testLabel expected result = + case result of + Left err -> + assertFailure (testLabel ++ " failed: " ++ renderSignError err) + Right (SigV4 sigType _ _ _ _ _ _) -> + assertEqual + (testLabel ++ " uses expected signature type") + expected + sigType + Right _ -> + assertFailure + (testLabel ++ " should generate a V4 signature payload") + assertSigType + "certification signature" + GenericCert + ( signCertificationWithRSA + GenericCert + signer + userId + [] + [] + signingKey + ) + assertSigType + "key revocation signature" + KeyRevocationSig + (signKeyRevocationWithRSA signer [] [] signingKey) + assertSigType + "subkey revocation signature" + SubkeyRevocationSig + (signSubkeyRevocationWithRSA signer signer [] [] signingKey) + assertSigType + "certification revocation signature" + CertRevocationSig + (signCertRevocationWithRSA signer userId [] [] signingKey) + let left16Payload = "left16 primitive payload" + left16Keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []] + left16Sig <- + case signDataWithRSA BinarySig signingKey [] [] left16Payload of + Left err -> + assertFailure + ( "RSA primitive signing for left16 failed: " + ++ renderSignError err + ) + >> fail "expected RSA signature payload" + Right sigPayload -> pure sigPayload + case verifyAgainstKeyring + left16Keyring + (SignaturePkt left16Sig) + Nothing + left16Payload of + Right _ -> pure () + Left err -> + assertFailure + ( "fresh RSA signature should verify with matching left16, got: " + ++ renderVerificationError err + ) + let tamperedLeft16Sig = + case left16Sig of + SigV4 st pka ha hs us l16 mpis -> SigV4 st pka ha hs us (l16 + 1) mpis + other -> other + case verifyAgainstKeyring + left16Keyring + (SignaturePkt tamperedLeft16Sig) + Nothing + left16Payload of + Left _ -> pure () + Right _ -> + assertFailure + "verification unexpectedly succeeded with tampered left16" + if isRight + ( signCertificationWithRSA + KeyRevocationSig + signer + userId + [] + [] + signingKey + ) + then + assertFailure + "certification primitive should reject non-certification signature types" + else pure () + (edSigner, edSigningKey) <- loadDeterministicEd25519Signer + edIssuerKeyId <- + case eightOctetKeyID edSigner of + Left err -> + assertFailure ("failed to derive Ed25519 issuer key id: " ++ err) + >> fail "expected Ed25519 issuer key id" + Right i -> pure i + let edPayload = "primitive Ed25519 payload" + edHashed = + [ SigSubPacket + False + (IssuerFingerprint IssuerFingerprintV4 (fingerprint edSigner)) + ] + edUnhashed = [SigSubPacket False (Issuer edIssuerKeyId)] + case signDataWithEd25519 + BinarySig + edSigningKey + edHashed + edUnhashed + edPayload of + Left err -> + assertFailure + ("Ed25519 primitive signing failed: " ++ renderSignError err) + Right (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _) -> pure () + Right other -> + assertFailure + ( "Ed25519 primitive should generate an Ed25519 SigV4 payload, got " + ++ show other + ) + let v6Salt = SignatureSalt (BL.replicate 32 0x42) + case signDataWithEd25519V6 + BinarySig + v6Salt + edSigningKey + edHashed + edUnhashed + edPayload of + Left err -> + assertFailure + ("Ed25519 SigV6 primitive signing failed: " ++ renderSignError err) + Right (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _) -> + assertEqual + "Ed25519 SigV6 primitive should preserve 32-byte salt" + 32 + (BL.length (unSignatureSalt salt)) + Right other -> + assertFailure + ( "Ed25519 SigV6 primitive should generate an Ed25519 SigV6 payload, got " + ++ show other + ) + (ed448Signer, ed448SigningKey) <- loadDeterministicEd448Signer + ed448IssuerKeyId <- + case eightOctetKeyID ed448Signer of + Left err -> + assertFailure ("failed to derive Ed448 issuer key id: " ++ err) + >> fail "expected Ed448 issuer key id" + Right i -> pure i + let ed448Payload = "primitive Ed448 payload" + ed448Hashed = + [ SigSubPacket + False + (IssuerFingerprint IssuerFingerprintV4 (fingerprint ed448Signer)) + ] + ed448Unhashed = [SigSubPacket False (Issuer ed448IssuerKeyId)] + case signDataWithEd448 + BinarySig + ed448SigningKey + ed448Hashed + ed448Unhashed + ed448Payload of + Left err -> + assertFailure + ("Ed448 primitive signing failed: " ++ renderSignError err) + Right (SigV4 BinarySig PKA.Ed448 SHA512 _ _ _ _) -> pure () + Right other -> + assertFailure + ( "Ed448 primitive should generate an Ed448 SigV4 payload, got " + ++ show other + ) + case signDataWithEd448V6 + BinarySig + v6Salt + ed448SigningKey + ed448Hashed + ed448Unhashed + ed448Payload of + Left err -> + assertFailure + ("Ed448 SigV6 primitive signing failed: " ++ renderSignError err) + Right (SigV6 BinarySig PKA.Ed448 SHA512 salt _ _ _ _) -> + assertEqual + "Ed448 SigV6 primitive should preserve 32-byte salt" + 32 + (BL.length (unSignatureSalt salt)) + Right other -> + assertFailure + ( "Ed448 SigV6 primitive should generate an Ed448 SigV6 payload, got " + ++ show other + ) + +testSignatureDataKindsCoercions :: Assertion +testSignatureDataKindsCoercions = do + let sigV3 = + SigV3 + BinarySig + (ThirtyTwoBitTimeStamp 1) + (EightOctetKeyId "\x01\x02\x03\x04\x05\x06\x07\x08") + RSA + SHA256 + 0 + (NE.fromList [MPI 1]) + sigV4 = + SigV4 + BinarySig + RSA + SHA256 + [] + [] + 0 + (NE.fromList [MPI 2]) + sigV6 = + SigV6 + BinarySig + PKA.Ed25519 + SHA512 + (SignatureSalt (BL.replicate 32 0x01)) + [] + [] + 0 + (NE.fromList [MPI 3, MPI 4]) + sigOther = SigVOther 77 "opaque-signature-body" + assertPacketRoundTrip label expected pkt = + case fromPktEitherSomeSignatureV pkt of + Left err -> assertFailure (label ++ " packet coercion failed: " ++ err) + Right (SomeSignatureV typedSig) -> + assertEqual + (label ++ " packet coercion preserves payload") + expected + (signaturePayloadFromSignatureV typedSig) + assertBool + "toSomeSignaturePayload should preserve SigV3 witness" + (isRight (asSignaturePayloadV3 sigV3)) + assertBool + "toSomeSignaturePayload should preserve SigV4 witness" + (isRight (asSignaturePayloadV4 sigV4)) + assertBool + "toSomeSignaturePayload should preserve SigV6 witness" + (isRight (asSignaturePayloadV6 sigV6)) + assertBool + "toSomeSignaturePayload should preserve SigVOther witness" + (isRight (asSignaturePayloadOther sigOther)) + case asSignaturePayloadV3 sigV3 of + Left err -> + assertFailure + ("asSignaturePayloadV3 should accept SigV3: " ++ err) + Right typed -> + assertEqual + "asSignaturePayloadV3 round-trips SigV3" + sigV3 + (toSignaturePayload typed) + case asSignaturePayloadV4 sigV4 of + Left err -> + assertFailure + ("asSignaturePayloadV4 should accept SigV4: " ++ err) + Right typed -> + assertEqual + "asSignaturePayloadV4 round-trips SigV4" + sigV4 + (toSignaturePayload typed) + case asSignaturePayloadV6 sigV6 of + Left err -> + assertFailure + ("asSignaturePayloadV6 should accept SigV6: " ++ err) + Right typed -> + assertEqual + "asSignaturePayloadV6 round-trips SigV6" + sigV6 + (toSignaturePayload typed) + case asSignaturePayloadOther sigOther of + Left err -> + assertFailure + ("asSignaturePayloadOther should accept SigVOther: " ++ err) + Right typed -> + assertEqual + "asSignaturePayloadOther round-trips SigVOther" + sigOther + (toSignaturePayload typed) + assertBool + "asSignaturePayloadV6 rejects SigV4" + (not (isRight (asSignaturePayloadV6 sigV4))) + assertBool + "asSignaturePayloadV4 rejects SigVOther" + (not (isRight (asSignaturePayloadV4 sigOther))) + assertPacketRoundTrip "SigV3" sigV3 (SignaturePkt sigV3) + assertPacketRoundTrip "SigV4" sigV4 (SignaturePkt sigV4) + assertPacketRoundTrip "SigV6" sigV6 (SignaturePkt sigV6) + assertPacketRoundTrip + "SigVOther" + sigOther + (SignaturePkt sigOther) + assertBool + "fromPktEitherSomeSignatureV rejects non-signature packets" + ( not + ( isRight + (fromPktEitherSomeSignatureV (LiteralDataPkt BinaryData "" 0 "")) + ) + ) + +testTypedArmorPayloadHelpers :: Assertion +testTypedArmorPayloadHelpers = do + let armors = + [ Armor ArmorPublicKeyBlock [] "public-one" + , Armor ArmorMessage [] "message-one" + , Armor ArmorPublicKeyBlock [] "public-two" + ] + publicPayloads = + map BL.toStrict (armorPayloadsOfType ArmorPublicKeyBlock armors) + assertEqual + "armorPayloadsOfType returns all matching typed blocks in order" + ["public-one", "public-two"] + publicPayloads + assertEqual + "singleArmorPayloadOfType returns the sole matching message payload" + (Right "message-one") + (fmap BL.toStrict (singleArmorPayloadOfType ArmorMessage armors)) + assertBool + "singleArmorPayloadOfType fails when no typed blocks exist" + (isLeft (singleArmorPayloadOfType ArmorPrivateKeyBlock armors)) + assertBool + "singleArmorPayloadOfType fails when multiple typed blocks exist" + (isLeft (singleArmorPayloadOfType ArmorPublicKeyBlock armors)) +testRecommendedArmorType :: Assertion +testRecommendedArmorType = do + secretArmors <- loadArmor "v4-encrypted-secret.pgp.aa" + publicArmors <- loadArmor "v4-encrypted.rev.aa" + secretPayload <- + case singleArmorPayloadOfType ArmorPrivateKeyBlock secretArmors of + Left err -> assertFailure err >> fail err + Right payload -> pure payload + publicPayload <- + case singleArmorPayloadOfType ArmorPublicKeyBlock publicArmors of + Left err -> assertFailure err >> fail err + Right payload -> pure payload + let secretPkts = parsePkts secretPayload + publicPkts = parsePkts publicPayload + firstPkt label pkts = + case pkts of + [] -> + assertFailure (label ++ " should contain at least one packet") + >> fail "missing packet" + pkt : _ -> pure pkt + firstSecret <- firstPkt "secret armor fixture" secretPkts + firstPublic <- firstPkt "public armor fixture" publicPkts + let sig = + SignaturePkt + (SigV4 BinarySig RSA SHA256 [] [] 0 (NE.fromList [MPI 1])) + assertEqual + "recommendedArmorType rejects empty packet streams" + Nothing + (recommendedArmorType []) + assertEqual + "recommendedArmorType maps secret-key packets to private key armor" + (Just ArmorPrivateKeyBlock) + (recommendedArmorType [firstSecret]) + assertEqual + "recommendedArmorType maps public-key packets to public key armor" + (Just ArmorPublicKeyBlock) + (recommendedArmorType [firstPublic]) + assertEqual + "recommendedArmorType maps signature packets to signature armor" + (Just ArmorSignature) + (recommendedArmorType [sig]) + assertEqual + "recommendedArmorType defaults non-key/signature packets to message armor" + (Just ArmorMessage) + (recommendedArmorType [LiteralDataPkt BinaryData "" 0 "payload"]) +testSingleClearSignedBlock :: Assertion +testSingleClearSignedBlock = do + let clearSigned = + ClearSigned + [("Hash", "SHA256")] + "signed cleartext payload\n" + ( Armor + ArmorSignature + [("Version", "test-suite")] + "detached-signature" + ) + assertEqual + "singleClearSignedBlock extracts cleartext and signature payloads" + ( Right + ( [("Hash", "SHA256")] + , "signed cleartext payload\n" + , "detached-signature" + ) + ) + (singleClearSignedBlock [clearSigned]) + assertBool + "singleClearSignedBlock rejects absent clear-signed blocks" + (isLeft (singleClearSignedBlock [Armor ArmorMessage [] "payload"])) + assertBool + "singleClearSignedBlock rejects multiple clear-signed blocks" + (isLeft (singleClearSignedBlock [clearSigned, clearSigned])) + assertBool + "singleClearSignedBlock rejects non-signature inner armor blocks" + ( isLeft + ( singleClearSignedBlock + [ ClearSigned [] "payload" (Armor ArmorMessage [] "not-signature") + ] + ) + ) +testSignerTimelineSoftPrimaryRevocation :: Assertion +testSignerTimelineSoftPrimaryRevocation = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "soft primary revocation timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigAfterTime = addTimestampSeconds keyCreated 30 + sigBefore <- + signBinaryMessageWithRSAAt + signer + signingKey + sigBeforeTime + payload + revocation <- + signKeyRevocationWithReasonAt + signer + signingKey + revocationTime + KeySuperseded + sigAfter <- + signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload + let keyring = + mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleSignerFingerprint + "soft primary revocation should preserve pre-revocation signatures" + (fingerprint signer) + (verifyTimelinePackets keyring payload sigBefore) + assertSingleFailureContainsTimeline + "soft primary revocation should reject post-revocation signatures" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigAfter) + +testSignerTimelineHardPrimaryRevocation :: Assertion +testSignerTimelineHardPrimaryRevocation = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "hard primary revocation timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigBefore <- + signBinaryMessageWithRSAAt + signer + signingKey + sigBeforeTime + payload + revocation <- + signKeyRevocationWithReasonAt + signer + signingKey + revocationTime + KeyMaterialCompromised + let keyring = + mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleFailureContainsTimeline + "hard primary revocation should reject even pre-revocation signatures" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigBefore) + +testSignerTimelineNoReasonPrimaryRevocation :: Assertion +testSignerTimelineNoReasonPrimaryRevocation = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "no-reason primary revocation timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigBefore <- + signBinaryMessageWithRSAAt + signer + signingKey + sigBeforeTime + payload + revocation <- + signKeyRevocationWithReasonAt + signer + signingKey + revocationTime + NoReason + let keyring = + mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleFailureContainsTimeline + "no-reason primary revocation should reject even pre-revocation signatures" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigBefore) + +testSignerTimelineUnknownReasonPrimaryRevocation :: Assertion +testSignerTimelineUnknownReasonPrimaryRevocation = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "unknown-reason primary revocation timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigBefore <- + signBinaryMessageWithRSAAt + signer + signingKey + sigBeforeTime + payload + revocation <- + signKeyRevocationWithReasonAt + signer + signingKey + revocationTime + (RCoOther 100) + let keyring = + mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleFailureContainsTimeline + "unknown-reason primary revocation should reject even pre-revocation signatures" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigBefore) + +testSignerTimelineNonCompromisePrimaryRevocationIsHistorical + :: Assertion +testSignerTimelineNonCompromisePrimaryRevocationIsHistorical = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "non-compromise primary revocation timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigAfterTime = addTimestampSeconds keyCreated 30 + sigBefore <- + signBinaryMessageWithRSAAt + signer + signingKey + sigBeforeTime + payload + revocation <- + signKeyRevocationWithReasonAt + signer + signingKey + revocationTime + UserIdInfoNoLongerValid + sigAfter <- + signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload + let keyring = + mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleSignerFingerprint + "non-compromise primary revocation should preserve pre-revocation signatures" + (fingerprint signer) + (verifyTimelinePackets keyring payload sigBefore) + assertSingleFailureContainsTimeline + "non-compromise primary revocation should reject post-revocation signatures" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigAfter) + +testSignerTimelineTemporaryPrimaryRevocationExpires :: Assertion +testSignerTimelineTemporaryPrimaryRevocationExpires = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let payload = "temporary primary revocation expiry timeline payload" + keyCreated = _timestamp signer + sigBeforeTime = addTimestampSeconds keyCreated 10 + revocationTime = addTimestampSeconds keyCreated 20 + sigDuringTime = addTimestampSeconds keyCreated 25 + sigAfterTime = addTimestampSeconds keyCreated 35 + sigBefore <- + signBinaryMessageWithRSAAt + signer + signingKey + sigBeforeTime + payload + revocation <- + signKeyRevocationWithReasonAndExtrasAt + signer + signingKey + revocationTime + KeySuperseded + [SigSubPacket False (SigExpirationTime 10)] + sigDuring <- + signBinaryMessageWithRSAAt + signer + signingKey + sigDuringTime + payload + sigAfter <- + signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload + let keyring = + mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []] + assertSingleSignerFingerprint + "temporary primary revocation should preserve pre-revocation signatures" + (fingerprint signer) + (verifyTimelinePackets keyring payload sigBefore) + assertSingleFailureContainsTimeline + "temporary primary revocation should reject signatures while revocation is effective" + "signing key is revoked" + (verifyTimelinePackets keyring payload sigDuring) + assertSingleSignerFingerprint + "temporary primary revocation should allow signatures after revocation expiration" + (fingerprint signer) + (verifyTimelinePackets keyring payload sigAfter) + +testSignerTimelineSubkeyRevocation :: Assertion +testSignerTimelineSubkeyRevocation = do + (primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner + (subkeySigner, subkeySigningKey) <- + loadDeterministicEd25519Signer + let payload = "subkey revocation timeline payload" + keyCreated = _timestamp primarySigner + bindingTime = addTimestampSeconds keyCreated 10 + sigBeforeTime = addTimestampSeconds keyCreated 20 + revocationTime = addTimestampSeconds keyCreated 30 + sigAfterTime = addTimestampSeconds keyCreated 40 + subkeyPacket = PublicSubkeyPkt subkeySigner + bindingSig <- + signSubkeyBindingWithRSAAt + primarySigner + subkeySigner + primarySigningKey + bindingTime + sigBefore <- + signBinaryMessageWithEd25519At + subkeySigner + subkeySigningKey + sigBeforeTime + payload + revocationSig <- + signSubkeyRevocationWithRSAAt + primarySigner + subkeySigner + primarySigningKey + revocationTime + sigAfter <- + signBinaryMessageWithEd25519At + subkeySigner + subkeySigningKey + sigAfterTime + payload + let keyring = + mkTestKeyring + [ TKUnknown + (primarySigner, Nothing) + [] + [] + [] + [(subkeyPacket, [bindingSig, revocationSig])] + ] + assertSingleSignerFingerprint + "subkey revocation should preserve pre-revocation signatures" + (fingerprint subkeySigner) + (verifyTimelinePackets keyring payload sigBefore) + assertSingleFailureContainsTimeline + "subkey revocation should reject post-revocation signatures" + "signing key was not valid at the signature creation time" + (verifyTimelinePackets keyring payload sigAfter) + +testSignMessageConvenience :: Assertion +testSignMessageConvenience = do + (signer, signingKey) <- loadUnencryptedRsaSigner + signerV4 <- expectV4PKPayload "RSA v4 convenience signer" signer + signedResult <- + signMessage + (mkRSASignerV4 signerV4 signingKey) + "message-api convenience signing payload" + signedMessage <- + case signedResult of + Left err -> + assertFailure + ("message signing convenience API failed: " ++ show err) + >> pure mempty + Right bs -> pure bs + case parsePkts signedMessage of + [LiteralDataPkt {}, SignaturePkt _] -> pure () + _ -> + assertFailure + "convenience signing output should contain literal data and one signature packet" + +testTypedVerifySurfaceMatchesLegacy :: Assertion +testTypedVerifySurfaceMatchesLegacy = do + kr <- loadKeyring "pubring.gpg" + signedMessage <- readFixtureLazy "uncompressed-ops-rsa.gpg" + let typedResults = + verifyMessage + defaultVerificationOptions + { verificationPolicy = VerifyInformational + , verificationMode = VerificationStreaming + } + kr + signedMessage + strictResults = + verifyMessage + defaultVerificationOptions + { verificationPolicy = VerifyStrict + , verificationMode = VerificationStreaming + } + kr + signedMessage + normalizeTyped + :: Either VerificationError Verification -> Either Bool Fingerprint + normalizeTyped (Left _) = Left False + normalizeTyped (Right v) = Right (fingerprint (_verificationSigner v)) + assertEqual + "strict verification should collapse informational failures" + ( map + normalizeTyped + (either (pure . Left) (Right <$>) (sequence typedResults)) + ) + (map normalizeTyped strictResults) + assertBool + "informational verification should emit at least one result for known-good fixture" + (not (null (map normalizeTyped typedResults))) + +testVerifyMessageStrictRejectsTamper :: Assertion +testVerifyMessageStrictRejectsTamper = do + kr <- loadKeyring "pubring.gpg" + packets <- loadAndDecompressPkts "uncompressed-ops-rsa.gpg" + let tamperedPackets = map tamperLiteral packets + strictOptions = + defaultVerificationOptions + { verificationPolicy = VerifyStrict + , verificationMode = VerificationStreaming + } + case verifyMessagePackets strictOptions kr tamperedPackets of + [Left _] -> pure () + _ -> + assertFailure + "strict typed verification should fail on tampered payload" + where + tamperLiteral (LiteralDataPkt dt fn ts payload) = + LiteralDataPkt dt fn ts (BL.snoc payload 0) + tamperLiteral pkt = pkt + +testVerifySignedMessageConvenience :: Assertion +testVerifySignedMessageConvenience = do + kr <- loadKeyring "pubring.gpg" + signedMessage <- readFixtureLazy "uncompressed-ops-rsa.gpg" + strictResult <- + pure + ( verifySignedMessage + defaultVerificationOptions + { verificationPolicy = VerifyStrict + , verificationMode = VerificationStreaming + } + kr + signedMessage + ) + case strictResult of + [Left _] -> + assertFailure + "verifySignedMessage should succeed for known-good fixture" + verifications -> + assertBool + "verifySignedMessage should emit at least one verification" + (not (null verifications)) + +testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm :: Assertion +testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm = do + (signer, signingKey) <- loadDeterministicEd25519Signer + let signerWithEd25519Pka = setPKAlgorithm PKA.Ed25519 signer + signerV4 <- + expectV4PKPayload + "Ed25519 v4 signer with Ed25519 key algorithm" + signerWithEd25519Pka + let payload = "v4 eddsa signature with Ed25519 key algorithm" + state = + emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload} + keyring = + mkTestKeyring + [TKUnknown (signerWithEd25519Pka, Nothing) [] [] [] []] + signedResult <- + signMessageWith + (mkEd25519SignerV4 signerV4 signingKey) + (mkClearPayload payload) + signaturePkt <- + case signedResult of + Left err -> + assertFailure ("Ed25519 message signing failed: " ++ show err) + >> fail "expected signed Ed25519 payload" + Right signedMessage -> + case parsePkts signedMessage of + [ LiteralDataPkt {} + , sig@(SignaturePkt (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _)) + ] -> + pure sig + other -> + assertFailure + ( "Expected [LiteralDataPkt, Ed25519 SigV4] for Ed25519-key-algorithm verification test, got " + ++ show other + ) + >> fail "unexpected Ed25519-key-algorithm signature shape" + case verifySigWith + defaultVerificationPolicy + (verifyAgainstKeyring keyring) + signaturePkt + state + Nothing of + Left err -> + assertFailure + ( "Ed25519 SigV4 verification with Ed25519 key algorithm failed: " + ++ renderVerificationError err + ) + Right _ -> pure () diff --git a/tests/Tests/Serialization.hs b/tests/Tests/Serialization.hs --- a/tests/Tests/Serialization.hs +++ b/tests/Tests/Serialization.hs @@ -2,955 +2,1167 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - -{-# LANGUAGE OverloadedStrings #-} - -module Tests.Serialization (serializationTests) where - -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) -import Codec.Encryption.OpenPGP.Internal (emptyPSC, point2MBS) -import Codec.Encryption.OpenPGP.KeyringParser (parseTKsWithWireRep) -import Codec.Encryption.OpenPGP.Policy - ( signatureV6SaltSizeForHashAlgorithm - ) -import Codec.Encryption.OpenPGP.Serialize (parsePkts, parsePktsWithWireRep) -import Codec.Encryption.OpenPGP.Signatures - ( VerificationError(..) - , verifySigWith - ) -import Codec.Encryption.OpenPGP.Types -import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA -import Control.Applicative ((<|>)) -import Control.Monad (forM_) -import Crypto.Number.Serialize (os2ip) -import Data.Binary (Get, get, put) -import Data.Binary.Put (putByteString, putWord16be, putWord32be, putWord8, runPut) -import Data.Bits (xor) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Crypto.PubKey.ECC.Types as ECCT -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import Data.Conduit.Serialization.Binary (conduitGet) -import qualified Data.Conduit as DC -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL -import qualified Data.List.NonEmpty as NE -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (listToMaybe) -import qualified Data.Set as Set -import Data.Word (Word8) -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) -import Tests.Common - ( armorPayload - , loadArmor - , readFixturePayload - , runGet - ) - -serializationTests :: TestTree -serializationTests = - testGroup - "Serialization" - [ testGroup - "Serialization group" - [ testCase - "000001-006.public_key" - (testSerialization "000001-006.public_key") - , testCase - "issuer-fingerprint-rejects-unknown-version" - testIssuerFingerprintRejectsUnknownVersion - , testCase - "v6-ed25519-public-key-serializes-fixed-length" - testV6Ed25519PublicKeySerializesFixedLength - , testCase - "v4-ed25519-public-key-parses-native-fixed-length" - testV4Ed25519PublicKeyParsesNativeFixedLength - , testCase - "v4-x25519-public-subkey-parses-native-fixed-length" - testV4X25519PublicSubkeyParsesNativeFixedLength - , testCase - "v6-signature-issuer-fingerprint-version-mismatch" - testV6SignatureIssuerFingerprintVersionMismatch - , testCase "000002-013.user_id" (testSerialization "000002-013.user_id") - , testCase "000003-002.sig" (testSerialization "000003-002.sig") - , testCase - "000004-012.ring_trust" - (testSerialization "000004-012.ring_trust") - , testCase "000005-002.sig" (testSerialization "000005-002.sig") - , testCase - "000006-012.ring_trust" - (testSerialization "000006-012.ring_trust") - , testCase "000007-002.sig" (testSerialization "000007-002.sig") - , testCase - "000008-012.ring_trust" - (testSerialization "000008-012.ring_trust") - , testCase "000009-002.sig" (testSerialization "000009-002.sig") - , testCase - "000010-012.ring_trust" - (testSerialization "000010-012.ring_trust") - , testCase "000011-002.sig" (testSerialization "000011-002.sig") - , testCase - "000012-012.ring_trust" - (testSerialization "000012-012.ring_trust") - , testCase - "000013-014.public_subkey" - (testSerialization "000013-014.public_subkey") - , testCase "000014-002.sig" (testSerialization "000014-002.sig") - , testCase - "000015-012.ring_trust" - (testSerialization "000015-012.ring_trust") - , testCase - "000016-006.public_key" - (testSerialization "000016-006.public_key") - , testCase "000017-002.sig" (testSerialization "000017-002.sig") - , testCase - "000018-012.ring_trust" - (testSerialization "000018-012.ring_trust") - , testCase "000019-013.user_id" (testSerialization "000019-013.user_id") - , testCase "000020-002.sig" (testSerialization "000020-002.sig") - , testCase - "000021-012.ring_trust" - (testSerialization "000021-012.ring_trust") - , testCase "000022-002.sig" (testSerialization "000022-002.sig") - , testCase - "000023-012.ring_trust" - (testSerialization "000023-012.ring_trust") - , testCase - "000024-014.public_subkey" - (testSerialization "000024-014.public_subkey") - , testCase "000025-002.sig" (testSerialization "000025-002.sig") - , testCase - "000026-012.ring_trust" - (testSerialization "000026-012.ring_trust") - , testCase - "000027-006.public_key" - (testSerialization "000027-006.public_key") - , testCase "000028-002.sig" (testSerialization "000028-002.sig") - , testCase - "000029-012.ring_trust" - (testSerialization "000029-012.ring_trust") - , testCase "000030-013.user_id" (testSerialization "000030-013.user_id") - , testCase "000031-002.sig" (testSerialization "000031-002.sig") - , testCase - "000032-012.ring_trust" - (testSerialization "000032-012.ring_trust") - , testCase "000033-002.sig" (testSerialization "000033-002.sig") - , testCase - "000034-012.ring_trust" - (testSerialization "000034-012.ring_trust") - , testCase - "000035-006.public_key" - (testSerialization "000035-006.public_key") - , testCase "000036-013.user_id" (testSerialization "000036-013.user_id") - , testCase "000037-002.sig" (testSerialization "000037-002.sig") - , testCase - "000038-012.ring_trust" - (testSerialization "000038-012.ring_trust") - , testCase "000039-002.sig" (testSerialization "000039-002.sig") - , testCase - "000040-012.ring_trust" - (testSerialization "000040-012.ring_trust") - , testCase - "000041-017.attribute" - (testSerialization "000041-017.attribute") - , testCase "000042-002.sig" (testSerialization "000042-002.sig") - , testCase - "000043-012.ring_trust" - (testSerialization "000043-012.ring_trust") - , testCase - "000044-014.public_subkey" - (testSerialization "000044-014.public_subkey") - , testCase "000045-002.sig" (testSerialization "000045-002.sig") - , testCase - "000046-012.ring_trust" - (testSerialization "000046-012.ring_trust") - , testCase - "000047-005.secret_key" - (testSerialization "000047-005.secret_key") - , testCase "000048-013.user_id" (testSerialization "000048-013.user_id") - , testCase "000049-002.sig" (testSerialization "000049-002.sig") - , testCase - "000050-012.ring_trust" - (testSerialization "000050-012.ring_trust") - , testCase - "000051-007.secret_subkey" - (testSerialization "000051-007.secret_subkey") - , testCase "000052-002.sig" (testSerialization "000052-002.sig") - , testCase - "000053-012.ring_trust" - (testSerialization "000053-012.ring_trust") - , testCase - "000054-005.secret_key" - (testSerialization "000054-005.secret_key") - , testCase "000055-002.sig" (testSerialization "000055-002.sig") - , testCase - "000056-012.ring_trust" - (testSerialization "000056-012.ring_trust") - , testCase "000057-013.user_id" (testSerialization "000057-013.user_id") - , testCase "000058-002.sig" (testSerialization "000058-002.sig") - , testCase - "000059-012.ring_trust" - (testSerialization "000059-012.ring_trust") - , testCase - "000060-007.secret_subkey" - (testSerialization "000060-007.secret_subkey") - , testCase "000061-002.sig" (testSerialization "000061-002.sig") - , testCase - "000062-012.ring_trust" - (testSerialization "000062-012.ring_trust") - , testCase - "000063-005.secret_key" - (testSerialization "000063-005.secret_key") - , testCase "000064-002.sig" (testSerialization "000064-002.sig") - , testCase - "000065-012.ring_trust" - (testSerialization "000065-012.ring_trust") - , testCase "000066-013.user_id" (testSerialization "000066-013.user_id") - , testCase "000067-002.sig" (testSerialization "000067-002.sig") - , testCase - "000068-012.ring_trust" - (testSerialization "000068-012.ring_trust") - , testCase - "000069-005.secret_key" - (testSerialization "000069-005.secret_key") - , testCase "000070-013.user_id" (testSerialization "000070-013.user_id") - , testCase "000071-002.sig" (testSerialization "000071-002.sig") - , testCase - "000072-012.ring_trust" - (testSerialization "000072-012.ring_trust") - , testCase - "000073-017.attribute" - (testSerialization "000073-017.attribute") - , testCase "000074-002.sig" (testSerialization "000074-002.sig") - , testCase - "000075-012.ring_trust" - (testSerialization "000075-012.ring_trust") - , testCase - "000076-007.secret_subkey" - (testSerialization "000076-007.secret_subkey") - , testCase "000077-002.sig" (testSerialization "000077-002.sig") - , testCase - "000078-012.ring_trust" - (testSerialization "000078-012.ring_trust") - , testCase "pubring.gpg" (testSerialization "pubring.gpg") - , testCase "secring.gpg" (testSerialization "secring.gpg") - , testCase "compressedsig.gpg" (testSerialization "compressedsig.gpg") - , testCase - "compressedsig-zlib.gpg" - (testSerialization "compressedsig-zlib.gpg") - , testCase - "compressedsig-bzip2.gpg" - (testSerialization "compressedsig-bzip2.gpg") - , testCase "onepass_sig" (testSerialization "onepass_sig") - , testCase - "uncompressed-ops-dsa.gpg" - (testSerialization "uncompressed-ops-dsa.gpg") - , testCase - "uncompressed-ops-rsa.gpg" - (testSerialization "uncompressed-ops-rsa.gpg") - , testCase "simple.seckey" (testSerialization "simple.seckey") - , testCase "v3-genericcert.sig" (testSerialization "v3-genericcert.sig") - , testCase "sigs-with-regexes" (testSerialization "sigs-with-regexes") - , testCase - "gnu-dummy-s2k-101-secret-key.gpg" - (testSerialization "gnu-dummy-s2k-101-secret-key.gpg") - , testCase "anibal-ed25519.gpg" (testSerialization "anibal-ed25519.gpg") - , testCase "nist_p-256_key.gpg" (testSerialization "nist_p-256_key.gpg") - , testCase - "nist_p-256_secretkey.gpg" - (testSerialization "nist_p-256_secretkey.gpg") - , testCase "v6-secret.pgp.aa" (testSerialization "v6-secret.pgp.aa") - , testCase - "sample-eddsa.pubkey" - (testSerialization "sample-eddsa.pubkey") - , testCase "should not serialize point at infinity" testPointAtInfinitySerialization - , testCase - "should reject mismatched EC coordinate widths" - testPointSerializationRejectsMismatchedCoordinateWidths - ] - , testGroup - "TKUnknown Serialization group" - [ testCase "pubring.gpg TKUnknown serialization" (testTKSerialization "pubring.gpg") - , testCase "secring.gpg TKUnknown serialization" (testTKSerialization "secring.gpg") - ] - , testGroup - "Argon2 S2K group" - [ testCase "Argon2 SKESK packet roundtrip" testArgon2S2KPacketRoundTrip - ] - , testGroup - "RFC9580 SEIPD v2 group" - [ testCase "SEIPD v2 packet roundtrip" testSEIPDv2PacketRoundTrip - , testCase - "SEIPD v2 rejects invalid chunk size" - testSEIPDv2RejectInvalidChunkSize - , testCase - "PKESKv6 parsing does not fall back to legacy parser" - testPKESKv6ParsesAsV6WithoutLegacyFallback - , testCase - "PKESKv6 rejects invalid recipient key version" - testPKESKv6RejectsInvalidRecipientIdentifierVersion - , testCase - "PKESKv6 rejects recipient length/version mismatches" - testPKESKv6RejectsRecipientIdentifierLengthVersionMismatch - , testCase - "legacy RSA PKESK rejects extra MPIs" - testLegacyPKESKRSARejectsExtraMPI - , testCase - "legacy ECDH PKESK rejects wrong MPI count" - testLegacyPKESKECDHRejectsWrongMPICount - , testCase - "legacy X25519 PKESK rejects wrong MPI count" - testLegacyPKESKX25519RejectsWrongMPICount - , testCase - "legacy unencrypted secret key rejects checksum mismatch" - testLegacyUnencryptedSecretKeyRejectsChecksumMismatch - , testCase - "legacy secret key rejects unsupported symmetric algorithm IV sizing" - testLegacySecretKeyRejectsUnsupportedSymmetricAlgorithmIVSizing - , testCase - "legacy X25519 PKESK parses RFC9580 v3 octet layout" - testLegacyPKESKX25519ParsesRFC9580V3OctetLayout - , testCase "SigV6 rejects invalid salt size" testSigV6RejectsInvalidSaltSize - , testCase "OPS6 rejects invalid salt size" testOPS6RejectsInvalidSaltSize - , testCase "OPS3 rejects invalid nested-flag octet" testOPS3RejectsInvalidNestedFlagOctet - , testCase "OPS6 rejects invalid nested-flag octet" testOPS6RejectsInvalidNestedFlagOctet - , testCase - "ECDH pubkey rejects reserved KDF length 0" - testECDHPubkeyRejectsReservedKDFLengthZero - , testCase - "ECDH pubkey rejects reserved KDF length 255" - testECDHPubkeyRejectsReservedKDFLength255 - , testCase - "ECDH pubkey encodes fixed KDF length trailer" - testECDHPubkeyEncodesFixedKDFLength - , testCase - "empty key-flags subpacket encodes explicit zero octet" - testKeyFlagsSubpacketEncodesEmptySetWithZeroOctet - , testCase - "v6-secret fixture SigV6 semantics" - testV6SecretFixtureSignatureSemantics - , testCase - "v6-secret fixture derives eight-octet key-id from fingerprint prefix" - testV6SecretFixtureDerivesEightOctetKeyID - ] - ] - -testSerialization :: FilePath -> Assertion -testSerialization fpr = do - bs <- readFixturePayload fpr - let firstpass = runGet get bs - case fmap unBlock firstpass of - Left _ -> assertFailure $ "First pass failed on " ++ fpr - Right [] -> - assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." - Right packs -> do - let roundtrip = runPut $ put (Block packs) - let secondpass = runGet (get :: Get (Block Pkt)) roundtrip - if fmap unBlock secondpass == Right [] - then assertFailure $ "Second pass of " ++ fpr ++ " decoded to nothing." - else assertEqual ("for " ++ fpr) firstpass secondpass - -testTKSerialization :: FilePath -> Assertion -testTKSerialization fpr = do - bs <- readFixturePayload fpr - let pkts = parsePktsWithWireRep (wireRepRef bs) bs - tksWithWireRep = parseTKsWithWireRep True pkts - if null tksWithWireRep - then assertFailure $ "TKUnknown serialization test: " ++ fpr ++ " parsed to no TKs" - else forM_ tksWithWireRep (testTKRoundtrip fpr) - -testTKRoundtrip :: FilePath -> TKWithWireRep -> Assertion -testTKRoundtrip fpr tk = do - let packets = _tkPackets tk - encoded = runPut (put (Block (map _pktValue packets))) - case runGet (get :: Get (Block Pkt)) encoded of - Left err -> assertFailure $ "TKUnknown " ++ fpr ++ " packet re-parse failed: " ++ err - Right reparsedBlock -> - assertEqual - ("TKUnknown packet re-serialization roundtrip for " ++ fpr) - (Block (map _pktValue packets)) - reparsedBlock - case toStructuredTKWithWireRep tk of - Left err -> assertFailure $ "TKUnknown structured conversion failed for " ++ fpr ++ ": " ++ show err - Right structured -> - case canonicalizeTKStructuredWithWireRep structured of - Left err -> assertFailure $ "TKUnknown canonical conversion failed for " ++ fpr ++ ": " ++ show err - Right _canonical -> pure () - -testArgon2S2KPacketRoundTrip :: Assertion -testArgon2S2KPacketRoundTrip = do - let s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 - pkt = SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 AES128 s2k Nothing)) - encoded = runPut (put pkt) - assertEqual - "Argon2 S2K SKESK packet roundtrip" - (Right pkt) - (runGet (get :: Get Pkt) encoded) - - -testIssuerFingerprintRejectsUnknownVersion :: Assertion -testIssuerFingerprintRejectsUnknownVersion = do - let encoded = - runPut $ do - putWord8 34 - putWord8 33 - putWord8 5 - putByteString (B.replicate 32 0) - case runGet (get :: Get SigSubPacket) encoded of - Left _ -> pure () - Right _ -> assertFailure "issuer fingerprint subpacket version 5 should be rejected" - -testV6Ed25519PublicKeySerializesFixedLength :: Assertion -testV6Ed25519PublicKeySerializesFixedLength = do - let pkp = - PKPayload - V6 - (ThirtyTwoBitTimeStamp 0) - 0 - EdDSA - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint 1))) - encoded = runPut (put (PublicKeyPkt pkp)) - assertEqual - "v6 Ed25519 public key serialization uses fixed-length octet strings" - 44 - (BL.length encoded) - -testV4Ed25519PublicKeyParsesNativeFixedLength :: Assertion -testV4Ed25519PublicKeyParsesNativeFixedLength = do - let raw = B.pack [0x01 .. 0x20] - encoded = - runPut $ do - putWord8 0xc6 - putWord8 38 - putWord8 4 - putWord32be 0 - putWord8 (fromIntegral (fromFVal PKA.Ed25519)) - putByteString raw - case runGet (get :: Get Pkt) encoded of - Right (PublicKeyPkt (PKPayload V4 (ThirtyTwoBitTimeStamp 0) _ PKA.Ed25519 (EdDSAPubKey Ed25519 (NativeEPoint (EPoint x))))) -> - assertEqual "v4 Ed25519 fixed-length key material parsed as native point" (os2ip raw) x - other -> - assertFailure - ("Expected v4 Ed25519 fixed-length public key parse, got " ++ show other) - -testV4X25519PublicSubkeyParsesNativeFixedLength :: Assertion -testV4X25519PublicSubkeyParsesNativeFixedLength = do - let raw = B.pack [0x01 .. 0x20] - encoded = - runPut $ do - putWord8 0xce - putWord8 38 - putWord8 4 - putWord32be 0 - putWord8 (fromIntegral (fromFVal PKA.X25519)) - putByteString raw - case runGet (get :: Get Pkt) encoded of - Right (PublicSubkeyPkt (PKPayload V4 (ThirtyTwoBitTimeStamp 0) _ PKA.X25519 (EdDSAPubKey Ed25519 (NativeEPoint (EPoint x))))) -> - assertEqual "v4 X25519 fixed-length key material parsed as native point" (os2ip raw) x - other -> - assertFailure - ("Expected v4 X25519 fixed-length public subkey parse, got " ++ show other) - -testV6SignatureIssuerFingerprintVersionMismatch :: Assertion -testV6SignatureIssuerFingerprintVersionMismatch = do - let signer = - PKPayload - V6 - (ThirtyTwoBitTimeStamp 0) - 0 - EdDSA - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint 1))) - sig = - SignaturePkt - (SigV6 - BinarySig - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0)) - [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer))] - [] - 0 - (NE.fromList [MPI 0, MPI 0])) - verifier _ _ _ = Right (Verification signer (case sig of SignaturePkt sp -> sp; _ -> error "impossible") []) - case verifySigWith verifier sig emptyPSC Nothing of - Left IssuerFingerprintSubpacketMismatch -> pure () - Left err -> assertFailure ("unexpected verification error: " ++ show err) - Right _ -> assertFailure "v6 signature with issuer fingerprint version 4 should be rejected" - -testPointAtInfinitySerialization :: Assertion -testPointAtInfinitySerialization = - assertEqual "point at infinity should not serialize" Nothing (point2MBS ECCT.PointO) - -testPointSerializationRejectsMismatchedCoordinateWidths :: Assertion -testPointSerializationRejectsMismatchedCoordinateWidths = - assertEqual - "point serialization should reject mismatched coordinate widths" - Nothing - (point2MBS (ECCT.Point 1 256)) - -testSEIPDv2PacketRoundTrip :: Assertion -testSEIPDv2PacketRoundTrip = do - let salt = Salt (B.pack [0x00 .. 0x1f]) - pkt = SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 16 salt "\x01\x02\x03\x04") - encoded = runPut (put pkt) - assertEqual - "SEIPD v2 packet roundtrip" - (Right pkt) - (runGet (get :: Get Pkt) encoded) - -testSEIPDv2RejectInvalidChunkSize :: Assertion -testSEIPDv2RejectInvalidChunkSize = do - let encoded = - runPut $ do - putWord8 0xd2 - putWord8 37 - putWord8 2 - putWord8 7 - putWord8 2 - putWord8 17 - putByteString (B.replicate 32 0) - putWord8 0 - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> return () - other -> - assertFailure - ("SEIPD v2 parser should reject chunk sizes larger than 16, got " ++ - show other) - -testPKESKv6ParsesAsV6WithoutLegacyFallback :: Assertion -testPKESKv6ParsesAsV6WithoutLegacyFallback = do - let recipientKeyIdentifier = BL.pack (0x04 : replicate 20 0) - esk = "\x00\x00" - encoded = - runPut $ do - putWord8 0xc1 - putWord8 26 - putWord8 6 - putWord8 21 - putByteString (BL.toStrict recipientKeyIdentifier) - putWord8 1 - putByteString (BL.toStrict esk) - case runGet (get :: Get Pkt) encoded of - Right (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka parsedEsk))) -> do - assertEqual "PKESKv6 recipient key identifier" recipientKeyIdentifier rid - assertEqual "PKESKv6 algorithm" RSA pka - assertEqual "PKESKv6 ESK payload" esk parsedEsk - other -> - assertFailure ("Expected PKESKPkt (PKESK6 ...) parse result, got " ++ show other) - -testPKESKv6RejectsInvalidRecipientIdentifierVersion :: Assertion -testPKESKv6RejectsInvalidRecipientIdentifierVersion = do - let recipientKeyIdentifier = BL.pack (0x05 : replicate 20 0) - encoded = - runPut $ do - putWord8 0xc1 - putWord8 24 - putWord8 6 - putWord8 21 - putByteString (BL.toStrict recipientKeyIdentifier) - putWord8 1 - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> pure () - other -> - assertFailure - ("Expected malformed PKESKv6 key version to produce BrokenPacketPkt, got " ++ - show other) - -testPKESKv6RejectsRecipientIdentifierLengthVersionMismatch :: Assertion -testPKESKv6RejectsRecipientIdentifierLengthVersionMismatch = do - let recipientKeyIdentifier = BL.pack (0x04 : replicate 32 0) - encoded = - runPut $ do - putWord8 0xc1 - putWord8 36 - putWord8 6 - putWord8 33 - putByteString (BL.toStrict recipientKeyIdentifier) - putWord8 1 - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> pure () - other -> - assertFailure - ("Expected malformed PKESKv6 recipient length/version mismatch to produce BrokenPacketPkt, got " ++ - show other) - -testLegacyPKESKRSARejectsExtraMPI :: Assertion -testLegacyPKESKRSARejectsExtraMPI = do - let encoded = - runPut $ do - putWord8 0xc1 - putWord8 16 - putWord8 3 - putByteString (B.replicate 8 0) - putWord8 1 - put (MPI 1) - put (MPI 2) - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> pure () - other -> - assertFailure - ("Expected malformed legacy RSA PKESK to produce BrokenPacketPkt, got " ++ - show other) - -testLegacyPKESKECDHRejectsWrongMPICount :: Assertion -testLegacyPKESKECDHRejectsWrongMPICount = do - let encoded = - runPut $ do - putWord8 0xc1 - putWord8 13 - putWord8 3 - putByteString (B.replicate 8 0) - putWord8 18 - put (MPI 1) - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> pure () - other -> - assertFailure - ("Expected malformed legacy ECDH PKESK to produce BrokenPacketPkt, got " ++ - show other) - -testLegacyPKESKX25519RejectsWrongMPICount :: Assertion -testLegacyPKESKX25519RejectsWrongMPICount = do - let encoded = - runPut $ do - putWord8 0xc1 - putWord8 13 - putWord8 3 - putByteString (B.replicate 8 0) - putWord8 (fromIntegral (fromFVal X25519)) - put (MPI 1) - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> pure () - other -> - assertFailure - ("Expected malformed legacy X25519 PKESK to produce BrokenPacketPkt, got " ++ - show other) - -testLegacyUnencryptedSecretKeyRejectsChecksumMismatch :: Assertion -testLegacyUnencryptedSecretKeyRejectsChecksumMismatch = do - secretPackets <- - DC.runConduitRes $ - CB.sourceFile "tests/data/unencrypted.seckey" DC..| conduitGet get DC..| CL.consume - pkt <- - case secretPackets of - (SecretKeyPkt pkp (SUUnencrypted sk checksum):_) -> - pure (SecretKeyPkt pkp (SUUnencrypted sk (checksum `xor` 1))) - (SecretKeyPkt _ _ :_) -> - assertFailure "unencrypted.seckey did not begin with an unencrypted secret key packet" >> - fail "expected unencrypted secret key packet" - _ -> - assertFailure "unencrypted.seckey did not begin with a secret key packet" >> - fail "expected secret key packet" - let encoded = runPut (put pkt) - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> pure () - other -> - assertFailure - ("Expected unencrypted secret key checksum mismatch to produce BrokenPacketPkt, got " ++ - show other) - -testLegacySecretKeyRejectsUnsupportedSymmetricAlgorithmIVSizing :: Assertion -testLegacySecretKeyRejectsUnsupportedSymmetricAlgorithmIVSizing = do - let pkt = - SecretKeyPkt - (PKPayload V4 0 0 RSA (UnknownPKey BL.empty)) - (SUSSHA1 - (OtherSA 0xfe) - (IteratedSalted SHA256 (Salt8 "12345678") (IterationCount 65536)) - (IV (B.replicate 8 0)) - BL.empty) - encoded = runPut (put pkt) - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> pure () - other -> - assertFailure - ("Expected legacy secret key with unsupported symmetric algorithm to produce BrokenPacketPkt, got " ++ - show other) - -testLegacyPKESKX25519ParsesRFC9580V3OctetLayout :: Assertion -testLegacyPKESKX25519ParsesRFC9580V3OctetLayout = do - let ephemeral = B.pack [0x01 .. 0x20] - wrappedWithAlgo = B.singleton (fromIntegral (fromFVal AES128)) <> B.replicate 24 0x5a - encoded = - runPut $ do - putWord8 0xc1 - putWord8 (fromIntegral (1 + 8 + 1 + B.length ephemeral + 1 + B.length wrappedWithAlgo)) - putWord8 3 - putByteString (B.replicate 8 0) - putWord8 (fromIntegral (fromFVal X25519)) - putByteString ephemeral - putWord8 (fromIntegral (B.length wrappedWithAlgo)) - putByteString wrappedWithAlgo - case runGet (get :: Get Pkt) encoded of - Right (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 3 _ X25519 (ephMPI :| [eskMPI])))) -> do - assertEqual "legacy X25519 v3 octet-layout ephemeral parse" (MPI (os2ip ephemeral)) ephMPI - assertEqual - "legacy X25519 v3 octet-layout wrapped parse" - (MPI (os2ip wrappedWithAlgo)) - eskMPI - other -> - assertFailure - ("Expected legacy X25519 PKESK v3 octet-layout parse success, got " ++ show other) - -testSigV6RejectsInvalidSaltSize :: Assertion -testSigV6RejectsInvalidSaltSize = do - let encoded = - runPut $ do - putWord8 0xc2 - putWord8 45 - putWord8 6 - putWord8 0 - putWord8 1 - putWord8 8 - putWord32be 0 - putWord32be 0 - putWord16be 0 - putWord8 32 - putByteString (B.replicate 32 0) - putWord16be 0 - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> return () - other -> - assertFailure - ("Expected invalid SigV6 salt size to produce BrokenPacketPkt, got " ++ - show other) - -testOPS6RejectsInvalidSaltSize :: Assertion -testOPS6RejectsInvalidSaltSize = do - let encoded = - runPut $ do - putWord8 0xc4 - putWord8 69 - putWord8 6 - putWord8 0 - putWord8 10 - putWord8 22 - putWord8 31 - putByteString (B.replicate 31 0) - putByteString (B.replicate 32 0) - putWord8 0 - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> return () - other -> - assertFailure - ("Expected invalid OPS6 salt size to produce BrokenPacketPkt, got " ++ - show other) - -testOPS3RejectsInvalidNestedFlagOctet :: Assertion -testOPS3RejectsInvalidNestedFlagOctet = do - let encoded = - runPut $ do - putWord8 0xc4 - putWord8 13 - putWord8 3 - putWord8 0 - putWord8 8 - putWord8 1 - putByteString (B.replicate 8 0) - putWord8 2 - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> pure () - other -> - assertFailure - ("Expected invalid OPS3 nested-flag octet to produce BrokenPacketPkt, got " ++ - show other) - -testOPS6RejectsInvalidNestedFlagOctet :: Assertion -testOPS6RejectsInvalidNestedFlagOctet = do - let encoded = - runPut $ do - putWord8 0xc4 - putWord8 70 - putWord8 6 - putWord8 0 - putWord8 8 - putWord8 1 - putWord8 32 - putByteString (B.replicate 32 0) - putByteString (B.replicate 32 0) - putWord8 2 - case runGet (get :: Get Pkt) encoded of - Right BrokenPacketPkt {} -> pure () - other -> - assertFailure - ("Expected invalid OPS6 nested-flag octet to produce BrokenPacketPkt, got " ++ - show other) - -mkECDHBoundaryTestPacket :: Pkt -mkECDHBoundaryTestPacket = - PublicKeyPkt - (PKPayload - V4 - 0 - 0 - ECDH - (ECDHPubKey - (ECDSAPubKey - (ECDSA_PublicKey - (ECDSA.PublicKey (ECCT.getCurveByName ECCT.SEC_p256r1) (ECCT.Point 1 2)))) - SHA256 - AES128)) - -setStrictByteAt :: Int -> Word8 -> B.ByteString -> Maybe B.ByteString -setStrictByteAt idx w bs - | idx < 0 || idx >= B.length bs = Nothing - | otherwise = - let (prefix, rest) = B.splitAt idx bs - in case B.uncons rest of - Nothing -> Nothing - Just (_, suffix) -> Just (prefix <> B.singleton w <> suffix) - -testECDHPubkeyRejectsReservedKDFLengthZero :: Assertion -testECDHPubkeyRejectsReservedKDFLengthZero = do - let encoded = BL.toStrict (runPut (put mkECDHBoundaryTestPacket)) - mutated <- - maybe - (assertFailure "failed to locate ECDH KDF length byte for zero-length rejection test" >> fail "unreachable") - pure - (setStrictByteAt (B.length encoded - 4) 0x00 encoded) - case runGet (get :: Get Pkt) (BL.fromStrict mutated) of - Right BrokenPacketPkt {} -> pure () - other -> - assertFailure - ("Expected ECDH KDF length 0 to produce BrokenPacketPkt, got " ++ show other) - -testECDHPubkeyRejectsReservedKDFLength255 :: Assertion -testECDHPubkeyRejectsReservedKDFLength255 = do - let encoded = BL.toStrict (runPut (put mkECDHBoundaryTestPacket)) - mutated <- - maybe - (assertFailure "failed to locate ECDH KDF length byte for 0xff rejection test" >> fail "unreachable") - pure - (setStrictByteAt (B.length encoded - 4) 0xff encoded) - case runGet (get :: Get Pkt) (BL.fromStrict mutated) of - Right BrokenPacketPkt {} -> pure () - other -> - assertFailure - ("Expected ECDH KDF length 255 to produce BrokenPacketPkt, got " ++ show other) - -testECDHPubkeyEncodesFixedKDFLength :: Assertion -testECDHPubkeyEncodesFixedKDFLength = do - let encoded = BL.toStrict (runPut (put mkECDHBoundaryTestPacket)) - trailer = B.drop (B.length encoded - 4) encoded - assertEqual - "ECDH public-key encoding should emit fixed KDF trailer [3,1,hash,sym]" - (B.pack [0x03, 0x01, fromFVal SHA256, fromFVal AES128]) - trailer - -testKeyFlagsSubpacketEncodesEmptySetWithZeroOctet :: Assertion -testKeyFlagsSubpacketEncodesEmptySetWithZeroOctet = do - let encoded = runPut (put (SigSubPacket False (KeyFlags Set.empty))) - assertEqual - "empty key-flags subpacket should encode an explicit zero flags octet" - [2, 27, 0] - (BL.unpack encoded) - case runGet (get :: Get SigSubPacket) encoded of - Right (SigSubPacket False (KeyFlags flags)) -> - assertEqual - "empty key-flags subpacket should decode back to an empty flag set" - Set.empty - flags - other -> - assertFailure - ("Expected empty key-flags subpacket roundtrip, got " ++ show other) - -expectedV6SaltSizeForTest :: HashAlgorithm -> Maybe Int -expectedV6SaltSizeForTest = - fmap fromIntegral . signatureV6SaltSizeForHashAlgorithm - -signatureHasIssuerFingerprintV6 :: Fingerprint -> SignaturePayload -> Bool -signatureHasIssuerFingerprintV6 expectedFp (SigV6 _ _ _ _ hashed unhashed _ _) = - expectedFp `elem` - [ ifp - | SigSubPacket _ (IssuerFingerprint IssuerFingerprintV6 ifp) <- hashed ++ unhashed - ] -signatureHasIssuerFingerprintV6 _ _ = False - -testV6SecretFixtureSignatureSemantics :: Assertion -testV6SecretFixtureSignatureSemantics = do - armors <- loadArmor "v6-secret.pgp.aa" - payload <- - case armors of - (a:_) -> pure (armorPayload a) - [] -> - assertFailure "v6-secret.pgp.aa should contain one armored payload" >> - fail "expected one armored payload" - let packets = parsePkts payload - primaryV6Key = - listToMaybe - [ pkp - | SecretKeyPkt pkp _ <- packets - , _keyVersion pkp == V6 - ] <|> - listToMaybe - [ pkp - | PublicKeyPkt pkp <- packets - , _keyVersion pkp == V6 - ] - signatures = - [ (sig, ha, salt) - | SignaturePkt sig@(SigV6 _ _ ha salt _ _ _ _) <- packets - ] - pkp <- - case primaryV6Key of - Nothing -> - assertFailure "v6-secret.pgp.aa should contain a primary v6 key packet" >> - fail "expected primary v6 key packet" - Just k -> pure k - assertBool - "v6-secret.pgp.aa should contain at least one SigV6 packet" - (not (null signatures)) - mapM_ - (\(_, ha, salt) -> - case expectedV6SaltSizeForTest ha of - Nothing -> - assertFailure ("SigV6 in v6-secret.pgp.aa uses unsupported salt hash algorithm: " ++ show ha) - Just expected -> - assertEqual - "SigV6 salt size in v6-secret.pgp.aa should match hash algorithm" - expected - (fromIntegral (BL.length (unSignatureSalt salt)))) - signatures - assertBool - "v6-secret.pgp.aa should include at least one IssuerFingerprint v6 matching the primary key" - (any (\(sig, _, _) -> signatureHasIssuerFingerprintV6 (fingerprint pkp) sig) signatures) - -testV6SecretFixtureDerivesEightOctetKeyID :: Assertion -testV6SecretFixtureDerivesEightOctetKeyID = do - armors <- loadArmor "v6-secret.pgp.aa" - payload <- - case armors of - (a:_) -> pure (armorPayload a) - [] -> - assertFailure "v6-secret.pgp.aa should contain one armored payload" >> - fail "expected one armored payload" - let packets = parsePkts payload - primaryV6Key = - listToMaybe - [ pkp - | SecretKeyPkt pkp _ <- packets - , _keyVersion pkp == V6 - ] <|> - listToMaybe - [ pkp - | PublicKeyPkt pkp <- packets - , _keyVersion pkp == V6 - ] - pkp <- - case primaryV6Key of - Nothing -> - assertFailure "v6-secret.pgp.aa should contain a primary v6 key packet" >> - fail "expected primary v6 key packet" - Just k -> pure k - derivedKeyId <- - case eightOctetKeyID pkp of - Left err -> - assertFailure ("Expected v6 eight-octet key-id derivation to succeed: " ++ err) >> - fail "expected v6 eight-octet key-id" - Right keyId -> pure keyId - let expectedKeyId = EightOctetKeyId (BL.take 8 (unFingerprint (fingerprint pkp))) - assertEqual - "v6 eight-octet key-id should be the high-order 64 bits of the fingerprint" - expectedKeyId - derivedKeyId +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Serialization (serializationTests) where + +import Control.Applicative ((<|>)) +import Control.Monad (forM_) +import Crypto.Number.Serialize (os2ip) +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Types as ECCT +import Data.Binary (Get, get, put) +import Data.Binary.Put + ( putByteString + , putWord16be + , putWord32be + , putWord8 + , runPut + ) +import Data.Bits (xor) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Conduit as DC +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (listToMaybe) +import qualified Data.Set as Set +import Data.Word (Word8) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + ( Assertion + , assertBool + , assertEqual + , assertFailure + , testCase + ) + +import Codec.Encryption.OpenPGP.Fingerprint + ( eightOctetKeyID + , fingerprint + ) +import Codec.Encryption.OpenPGP.Internal (emptyPSC, point2MBS) +import Codec.Encryption.OpenPGP.KeyringParser + ( parseTKsWithWireRep + ) +import Codec.Encryption.OpenPGP.Policy + ( defaultVerificationPolicy + , signatureV6SaltSizeForHashAlgorithm + ) +import Codec.Encryption.OpenPGP.Serialize + ( parsePkts + , parsePktsWithWireRep + ) +import Codec.Encryption.OpenPGP.Signatures + ( VerificationError (..) + , verifySigWith + ) +import Codec.Encryption.OpenPGP.Types +import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA +import Tests.Common + ( armorPayload + , loadArmor + , readFixturePayload + , runGet + ) + +serializationTests :: TestTree +serializationTests = + testGroup + "Serialization" + [ testGroup + "Serialization group" + [ testCase + "000001-006.public_key" + (testSerialization "000001-006.public_key") + , testCase + "issuer-fingerprint-rejects-unknown-version" + testIssuerFingerprintRejectsUnknownVersion + , testCase + "v6-ed25519-public-key-serializes-fixed-length" + testV6Ed25519PublicKeySerializesFixedLength + , testCase + "v4-ed25519-public-key-parses-native-fixed-length" + testV4Ed25519PublicKeyParsesNativeFixedLength + , testCase + "v4-x25519-public-subkey-parses-native-fixed-length" + testV4X25519PublicSubkeyParsesNativeFixedLength + , testCase + "v6-signature-issuer-fingerprint-version-mismatch" + testV6SignatureIssuerFingerprintVersionMismatch + , testCase + "000002-013.user_id" + (testSerialization "000002-013.user_id") + , testCase "000003-002.sig" (testSerialization "000003-002.sig") + , testCase + "000004-012.ring_trust" + (testSerialization "000004-012.ring_trust") + , testCase "000005-002.sig" (testSerialization "000005-002.sig") + , testCase + "000006-012.ring_trust" + (testSerialization "000006-012.ring_trust") + , testCase "000007-002.sig" (testSerialization "000007-002.sig") + , testCase + "000008-012.ring_trust" + (testSerialization "000008-012.ring_trust") + , testCase "000009-002.sig" (testSerialization "000009-002.sig") + , testCase + "000010-012.ring_trust" + (testSerialization "000010-012.ring_trust") + , testCase "000011-002.sig" (testSerialization "000011-002.sig") + , testCase + "000012-012.ring_trust" + (testSerialization "000012-012.ring_trust") + , testCase + "000013-014.public_subkey" + (testSerialization "000013-014.public_subkey") + , testCase "000014-002.sig" (testSerialization "000014-002.sig") + , testCase + "000015-012.ring_trust" + (testSerialization "000015-012.ring_trust") + , testCase + "000016-006.public_key" + (testSerialization "000016-006.public_key") + , testCase "000017-002.sig" (testSerialization "000017-002.sig") + , testCase + "000018-012.ring_trust" + (testSerialization "000018-012.ring_trust") + , testCase + "000019-013.user_id" + (testSerialization "000019-013.user_id") + , testCase "000020-002.sig" (testSerialization "000020-002.sig") + , testCase + "000021-012.ring_trust" + (testSerialization "000021-012.ring_trust") + , testCase "000022-002.sig" (testSerialization "000022-002.sig") + , testCase + "000023-012.ring_trust" + (testSerialization "000023-012.ring_trust") + , testCase + "000024-014.public_subkey" + (testSerialization "000024-014.public_subkey") + , testCase "000025-002.sig" (testSerialization "000025-002.sig") + , testCase + "000026-012.ring_trust" + (testSerialization "000026-012.ring_trust") + , testCase + "000027-006.public_key" + (testSerialization "000027-006.public_key") + , testCase "000028-002.sig" (testSerialization "000028-002.sig") + , testCase + "000029-012.ring_trust" + (testSerialization "000029-012.ring_trust") + , testCase + "000030-013.user_id" + (testSerialization "000030-013.user_id") + , testCase "000031-002.sig" (testSerialization "000031-002.sig") + , testCase + "000032-012.ring_trust" + (testSerialization "000032-012.ring_trust") + , testCase "000033-002.sig" (testSerialization "000033-002.sig") + , testCase + "000034-012.ring_trust" + (testSerialization "000034-012.ring_trust") + , testCase + "000035-006.public_key" + (testSerialization "000035-006.public_key") + , testCase + "000036-013.user_id" + (testSerialization "000036-013.user_id") + , testCase "000037-002.sig" (testSerialization "000037-002.sig") + , testCase + "000038-012.ring_trust" + (testSerialization "000038-012.ring_trust") + , testCase "000039-002.sig" (testSerialization "000039-002.sig") + , testCase + "000040-012.ring_trust" + (testSerialization "000040-012.ring_trust") + , testCase + "000041-017.attribute" + (testSerialization "000041-017.attribute") + , testCase "000042-002.sig" (testSerialization "000042-002.sig") + , testCase + "000043-012.ring_trust" + (testSerialization "000043-012.ring_trust") + , testCase + "000044-014.public_subkey" + (testSerialization "000044-014.public_subkey") + , testCase "000045-002.sig" (testSerialization "000045-002.sig") + , testCase + "000046-012.ring_trust" + (testSerialization "000046-012.ring_trust") + , testCase + "000047-005.secret_key" + (testSerialization "000047-005.secret_key") + , testCase + "000048-013.user_id" + (testSerialization "000048-013.user_id") + , testCase "000049-002.sig" (testSerialization "000049-002.sig") + , testCase + "000050-012.ring_trust" + (testSerialization "000050-012.ring_trust") + , testCase + "000051-007.secret_subkey" + (testSerialization "000051-007.secret_subkey") + , testCase "000052-002.sig" (testSerialization "000052-002.sig") + , testCase + "000053-012.ring_trust" + (testSerialization "000053-012.ring_trust") + , testCase + "000054-005.secret_key" + (testSerialization "000054-005.secret_key") + , testCase "000055-002.sig" (testSerialization "000055-002.sig") + , testCase + "000056-012.ring_trust" + (testSerialization "000056-012.ring_trust") + , testCase + "000057-013.user_id" + (testSerialization "000057-013.user_id") + , testCase "000058-002.sig" (testSerialization "000058-002.sig") + , testCase + "000059-012.ring_trust" + (testSerialization "000059-012.ring_trust") + , testCase + "000060-007.secret_subkey" + (testSerialization "000060-007.secret_subkey") + , testCase "000061-002.sig" (testSerialization "000061-002.sig") + , testCase + "000062-012.ring_trust" + (testSerialization "000062-012.ring_trust") + , testCase + "000063-005.secret_key" + (testSerialization "000063-005.secret_key") + , testCase "000064-002.sig" (testSerialization "000064-002.sig") + , testCase + "000065-012.ring_trust" + (testSerialization "000065-012.ring_trust") + , testCase + "000066-013.user_id" + (testSerialization "000066-013.user_id") + , testCase "000067-002.sig" (testSerialization "000067-002.sig") + , testCase + "000068-012.ring_trust" + (testSerialization "000068-012.ring_trust") + , testCase + "000069-005.secret_key" + (testSerialization "000069-005.secret_key") + , testCase + "000070-013.user_id" + (testSerialization "000070-013.user_id") + , testCase "000071-002.sig" (testSerialization "000071-002.sig") + , testCase + "000072-012.ring_trust" + (testSerialization "000072-012.ring_trust") + , testCase + "000073-017.attribute" + (testSerialization "000073-017.attribute") + , testCase "000074-002.sig" (testSerialization "000074-002.sig") + , testCase + "000075-012.ring_trust" + (testSerialization "000075-012.ring_trust") + , testCase + "000076-007.secret_subkey" + (testSerialization "000076-007.secret_subkey") + , testCase "000077-002.sig" (testSerialization "000077-002.sig") + , testCase + "000078-012.ring_trust" + (testSerialization "000078-012.ring_trust") + , testCase "pubring.gpg" (testSerialization "pubring.gpg") + , testCase "secring.gpg" (testSerialization "secring.gpg") + , testCase + "compressedsig.gpg" + (testSerialization "compressedsig.gpg") + , testCase + "compressedsig-zlib.gpg" + (testSerialization "compressedsig-zlib.gpg") + , testCase + "compressedsig-bzip2.gpg" + (testSerialization "compressedsig-bzip2.gpg") + , testCase "onepass_sig" (testSerialization "onepass_sig") + , testCase + "uncompressed-ops-dsa.gpg" + (testSerialization "uncompressed-ops-dsa.gpg") + , testCase + "uncompressed-ops-rsa.gpg" + (testSerialization "uncompressed-ops-rsa.gpg") + , testCase "simple.seckey" (testSerialization "simple.seckey") + , testCase + "v3-genericcert.sig" + (testSerialization "v3-genericcert.sig") + , testCase + "sigs-with-regexes" + (testSerialization "sigs-with-regexes") + , testCase + "gnu-dummy-s2k-101-secret-key.gpg" + (testSerialization "gnu-dummy-s2k-101-secret-key.gpg") + , testCase + "anibal-ed25519.gpg" + (testSerialization "anibal-ed25519.gpg") + , testCase + "nist_p-256_key.gpg" + (testSerialization "nist_p-256_key.gpg") + , testCase + "nist_p-256_secretkey.gpg" + (testSerialization "nist_p-256_secretkey.gpg") + , testCase + "v6-secret.pgp.aa" + (testSerialization "v6-secret.pgp.aa") + , testCase + "sample-eddsa.pubkey" + (testSerialization "sample-eddsa.pubkey") + , testCase + "should not serialize point at infinity" + testPointAtInfinitySerialization + , testCase + "should reject mismatched EC coordinate widths" + testPointSerializationRejectsMismatchedCoordinateWidths + ] + , testGroup + "TKUnknown Serialization group" + [ testCase + "pubring.gpg TKUnknown serialization" + (testTKSerialization "pubring.gpg") + , testCase + "secring.gpg TKUnknown serialization" + (testTKSerialization "secring.gpg") + ] + , testGroup + "Argon2 S2K group" + [ testCase + "Argon2 SKESK packet roundtrip" + testArgon2S2KPacketRoundTrip + ] + , testGroup + "RFC9580 SEIPD v2 group" + [ testCase "SEIPD v2 packet roundtrip" testSEIPDv2PacketRoundTrip + , testCase + "SEIPD v2 rejects invalid chunk size" + testSEIPDv2RejectInvalidChunkSize + , testCase + "PKESKv6 parsing does not fall back to legacy parser" + testPKESKv6ParsesAsV6WithoutLegacyFallback + , testCase + "PKESKv6 rejects invalid recipient key version" + testPKESKv6RejectsInvalidRecipientIdentifierVersion + , testCase + "PKESKv6 rejects recipient length/version mismatches" + testPKESKv6RejectsRecipientIdentifierLengthVersionMismatch + , testCase + "legacy RSA PKESK rejects extra MPIs" + testLegacyPKESKRSARejectsExtraMPI + , testCase + "legacy ECDH PKESK rejects wrong MPI count" + testLegacyPKESKECDHRejectsWrongMPICount + , testCase + "legacy X25519 PKESK rejects wrong MPI count" + testLegacyPKESKX25519RejectsWrongMPICount + , testCase + "legacy unencrypted secret key rejects checksum mismatch" + testLegacyUnencryptedSecretKeyRejectsChecksumMismatch + , testCase + "legacy secret key rejects unsupported symmetric algorithm IV sizing" + testLegacySecretKeyRejectsUnsupportedSymmetricAlgorithmIVSizing + , testCase + "legacy X25519 PKESK parses RFC9580 v3 octet layout" + testLegacyPKESKX25519ParsesRFC9580V3OctetLayout + , testCase + "SigV6 rejects invalid salt size" + testSigV6RejectsInvalidSaltSize + , testCase + "OPS6 rejects invalid salt size" + testOPS6RejectsInvalidSaltSize + , testCase + "OPS3 rejects invalid nested-flag octet" + testOPS3RejectsInvalidNestedFlagOctet + , testCase + "OPS6 rejects invalid nested-flag octet" + testOPS6RejectsInvalidNestedFlagOctet + , testCase + "ECDH pubkey rejects reserved KDF length 0" + testECDHPubkeyRejectsReservedKDFLengthZero + , testCase + "ECDH pubkey rejects reserved KDF length 255" + testECDHPubkeyRejectsReservedKDFLength255 + , testCase + "ECDH pubkey encodes fixed KDF length trailer" + testECDHPubkeyEncodesFixedKDFLength + , testCase + "empty key-flags subpacket encodes explicit zero octet" + testKeyFlagsSubpacketEncodesEmptySetWithZeroOctet + , testCase + "v6-secret fixture SigV6 semantics" + testV6SecretFixtureSignatureSemantics + , testCase + "v6-secret fixture derives eight-octet key-id from fingerprint prefix" + testV6SecretFixtureDerivesEightOctetKeyID + ] + ] + +testSerialization :: FilePath -> Assertion +testSerialization fpr = do + bs <- readFixturePayload fpr + let firstpass = runGet get bs + case fmap unBlock firstpass of + Left _ -> assertFailure $ "First pass failed on " ++ fpr + Right [] -> + assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." + Right packs -> do + let roundtrip = runPut $ put (Block packs) + let secondpass = runGet (get :: Get (Block Pkt)) roundtrip + if fmap unBlock secondpass == Right [] + then + assertFailure $ + "Second pass of " ++ fpr ++ " decoded to nothing." + else assertEqual ("for " ++ fpr) firstpass secondpass + +testTKSerialization :: FilePath -> Assertion +testTKSerialization fpr = do + bs <- readFixturePayload fpr + let pkts = parsePktsWithWireRep (wireRepRef bs) bs + tksWithWireRep = parseTKsWithWireRep True pkts + if null tksWithWireRep + then + assertFailure $ + "TKUnknown serialization test: " ++ fpr ++ " parsed to no TKs" + else forM_ tksWithWireRep (testTKRoundtrip fpr) + +testTKRoundtrip :: FilePath -> TKWithWireRep -> Assertion +testTKRoundtrip fpr tk = do + let packets = _tkPackets tk + encoded = runPut (put (Block (map _pktValue packets))) + case runGet (get :: Get (Block Pkt)) encoded of + Left err -> + assertFailure $ + "TKUnknown " ++ fpr ++ " packet re-parse failed: " ++ err + Right reparsedBlock -> + assertEqual + ("TKUnknown packet re-serialization roundtrip for " ++ fpr) + (Block (map _pktValue packets)) + reparsedBlock + case toStructuredTKWithWireRep tk of + Left err -> + assertFailure $ + "TKUnknown structured conversion failed for " + ++ fpr + ++ ": " + ++ show err + Right structured -> + case canonicalizeTKStructuredWithWireRep structured of + Left err -> + assertFailure $ + "TKUnknown canonical conversion failed for " + ++ fpr + ++ ": " + ++ show err + Right _canonical -> pure () + +testArgon2S2KPacketRoundTrip :: Assertion +testArgon2S2KPacketRoundTrip = do + let s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15 + pkt = + SKESKPkt + (SKESKPayloadV4Packet (SKESKPayloadV4 AES128 s2k Nothing)) + encoded = runPut (put pkt) + assertEqual + "Argon2 S2K SKESK packet roundtrip" + (Right pkt) + (runGet (get :: Get Pkt) encoded) + +testIssuerFingerprintRejectsUnknownVersion :: Assertion +testIssuerFingerprintRejectsUnknownVersion = do + let encoded = + runPut $ do + putWord8 34 + putWord8 33 + putWord8 5 + putByteString (B.replicate 32 0) + case runGet (get :: Get SigSubPacket) encoded of + Left _ -> pure () + Right _ -> + assertFailure + "issuer fingerprint subpacket version 5 should be rejected" + +testV6Ed25519PublicKeySerializesFixedLength :: Assertion +testV6Ed25519PublicKeySerializesFixedLength = do + let pkp = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1))) + encoded = runPut (put (PublicKeyPkt pkp)) + assertEqual + "v6 Ed25519 public key serialization uses fixed-length octet strings" + 44 + (BL.length encoded) + +testV4Ed25519PublicKeyParsesNativeFixedLength :: Assertion +testV4Ed25519PublicKeyParsesNativeFixedLength = do + let raw = B.pack [0x01 .. 0x20] + encoded = + runPut $ do + putWord8 0xc6 + putWord8 38 + putWord8 4 + putWord32be 0 + putWord8 (fromIntegral (fromFVal PKA.Ed25519)) + putByteString raw + case runGet (get :: Get Pkt) encoded of + Right + ( PublicKeyPkt + ( PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + _ + PKA.Ed25519 + (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint x))) + ) + ) -> + assertEqual + "v4 Ed25519 fixed-length key material parsed as native point" + (os2ip raw) + x + other -> + assertFailure + ( "Expected v4 Ed25519 fixed-length public key parse, got " + ++ show other + ) + +testV4X25519PublicSubkeyParsesNativeFixedLength :: Assertion +testV4X25519PublicSubkeyParsesNativeFixedLength = do + let raw = B.pack [0x01 .. 0x20] + encoded = + runPut $ do + putWord8 0xce + putWord8 38 + putWord8 4 + putWord32be 0 + putWord8 (fromIntegral (fromFVal PKA.X25519)) + putByteString raw + case runGet (get :: Get Pkt) encoded of + Right + ( PublicSubkeyPkt + ( PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + _ + PKA.X25519 + (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint x))) + ) + ) -> + assertEqual + "v4 X25519 fixed-length key material parsed as native point" + (os2ip raw) + x + other -> + assertFailure + ( "Expected v4 X25519 fixed-length public subkey parse, got " + ++ show other + ) + +testV6SignatureIssuerFingerprintVersionMismatch :: Assertion +testV6SignatureIssuerFingerprintVersionMismatch = do + let signer = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1))) + sig = + SignaturePkt + ( SigV6 + BinarySig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0)) + [ SigSubPacket + False + (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer)) + ] + [] + 0 + (NE.fromList [MPI 0, MPI 0]) + ) + verifier _ _ _ = + Right + ( Verification + signer + (case sig of SignaturePkt sp -> sp; _ -> error "impossible") + [] + ) + case verifySigWith + defaultVerificationPolicy + verifier + sig + emptyPSC + Nothing of + Left IssuerFingerprintSubpacketMismatch -> pure () + Left err -> assertFailure ("unexpected verification error: " ++ show err) + Right _ -> + assertFailure + "v6 signature with issuer fingerprint version 4 should be rejected" + +testPointAtInfinitySerialization :: Assertion +testPointAtInfinitySerialization = + assertEqual + "point at infinity should not serialize" + Nothing + (point2MBS ECCT.PointO) + +testPointSerializationRejectsMismatchedCoordinateWidths + :: Assertion +testPointSerializationRejectsMismatchedCoordinateWidths = + assertEqual + "point serialization should reject mismatched coordinate widths" + Nothing + (point2MBS (ECCT.Point 1 256)) + +testSEIPDv2PacketRoundTrip :: Assertion +testSEIPDv2PacketRoundTrip = do + let salt = Salt (B.pack [0x00 .. 0x1f]) + pkt = + SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 16 salt "\x01\x02\x03\x04") + encoded = runPut (put pkt) + assertEqual + "SEIPD v2 packet roundtrip" + (Right pkt) + (runGet (get :: Get Pkt) encoded) + +testSEIPDv2RejectInvalidChunkSize :: Assertion +testSEIPDv2RejectInvalidChunkSize = do + let encoded = + runPut $ do + putWord8 0xd2 + putWord8 37 + putWord8 2 + putWord8 7 + putWord8 2 + putWord8 17 + putByteString (B.replicate 32 0) + putWord8 0 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> return () + other -> + assertFailure + ( "SEIPD v2 parser should reject chunk sizes larger than 16, got " + ++ show other + ) + +testPKESKv6ParsesAsV6WithoutLegacyFallback :: Assertion +testPKESKv6ParsesAsV6WithoutLegacyFallback = do + let recipientKeyIdentifier = BL.pack (0x04 : replicate 20 0) + esk = "\x00\x00" + encoded = + runPut $ do + putWord8 0xc1 + putWord8 26 + putWord8 6 + putWord8 21 + putByteString (BL.toStrict recipientKeyIdentifier) + putWord8 1 + putByteString (BL.toStrict esk) + case runGet (get :: Get Pkt) encoded of + Right + ( PKESKPkt + (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka parsedEsk)) + ) -> do + assertEqual + "PKESKv6 recipient key identifier" + recipientKeyIdentifier + rid + assertEqual "PKESKv6 algorithm" RSA pka + assertEqual "PKESKv6 ESK payload" esk parsedEsk + other -> + assertFailure + ("Expected PKESKPkt (PKESK6 ...) parse result, got " ++ show other) + +testPKESKv6RejectsInvalidRecipientIdentifierVersion :: Assertion +testPKESKv6RejectsInvalidRecipientIdentifierVersion = do + let recipientKeyIdentifier = BL.pack (0x05 : replicate 20 0) + encoded = + runPut $ do + putWord8 0xc1 + putWord8 24 + putWord8 6 + putWord8 21 + putByteString (BL.toStrict recipientKeyIdentifier) + putWord8 1 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ( "Expected malformed PKESKv6 key version to produce BrokenPacketPkt, got " + ++ show other + ) + +testPKESKv6RejectsRecipientIdentifierLengthVersionMismatch + :: Assertion +testPKESKv6RejectsRecipientIdentifierLengthVersionMismatch = do + let recipientKeyIdentifier = BL.pack (0x04 : replicate 32 0) + encoded = + runPut $ do + putWord8 0xc1 + putWord8 36 + putWord8 6 + putWord8 33 + putByteString (BL.toStrict recipientKeyIdentifier) + putWord8 1 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ( "Expected malformed PKESKv6 recipient length/version mismatch to produce BrokenPacketPkt, got " + ++ show other + ) + +testLegacyPKESKRSARejectsExtraMPI :: Assertion +testLegacyPKESKRSARejectsExtraMPI = do + let encoded = + runPut $ do + putWord8 0xc1 + putWord8 16 + putWord8 3 + putByteString (B.replicate 8 0) + putWord8 1 + put (MPI 1) + put (MPI 2) + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ( "Expected malformed legacy RSA PKESK to produce BrokenPacketPkt, got " + ++ show other + ) + +testLegacyPKESKECDHRejectsWrongMPICount :: Assertion +testLegacyPKESKECDHRejectsWrongMPICount = do + let encoded = + runPut $ do + putWord8 0xc1 + putWord8 13 + putWord8 3 + putByteString (B.replicate 8 0) + putWord8 18 + put (MPI 1) + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ( "Expected malformed legacy ECDH PKESK to produce BrokenPacketPkt, got " + ++ show other + ) + +testLegacyPKESKX25519RejectsWrongMPICount :: Assertion +testLegacyPKESKX25519RejectsWrongMPICount = do + let encoded = + runPut $ do + putWord8 0xc1 + putWord8 13 + putWord8 3 + putByteString (B.replicate 8 0) + putWord8 (fromIntegral (fromFVal X25519)) + put (MPI 1) + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ( "Expected malformed legacy X25519 PKESK to produce BrokenPacketPkt, got " + ++ show other + ) + +testLegacyUnencryptedSecretKeyRejectsChecksumMismatch + :: Assertion +testLegacyUnencryptedSecretKeyRejectsChecksumMismatch = do + secretPackets <- + DC.runConduitRes $ + CB.sourceFile "tests/data/unencrypted.seckey" + DC..| conduitGet get + DC..| CL.consume + pkt <- + case secretPackets of + (SecretKeyPkt pkp (SUUnencrypted sk checksum) : _) -> + pure (SecretKeyPkt pkp (SUUnencrypted sk (checksum `xor` 1))) + (SecretKeyPkt _ _ : _) -> + assertFailure + "unencrypted.seckey did not begin with an unencrypted secret key packet" + >> fail "expected unencrypted secret key packet" + _ -> + assertFailure + "unencrypted.seckey did not begin with a secret key packet" + >> fail "expected secret key packet" + let encoded = runPut (put pkt) + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ( "Expected unencrypted secret key checksum mismatch to produce BrokenPacketPkt, got " + ++ show other + ) + +testLegacySecretKeyRejectsUnsupportedSymmetricAlgorithmIVSizing + :: Assertion +testLegacySecretKeyRejectsUnsupportedSymmetricAlgorithmIVSizing = do + let pkt = + SecretKeyPkt + (PKPayload V4 0 0 RSA (UnknownPKey BL.empty)) + ( SUSSHA1 + (OtherSA 0xfe) + (IteratedSalted SHA256 (Salt8 "12345678") (IterationCount 65536)) + (IV (B.replicate 8 0)) + BL.empty + ) + encoded = runPut (put pkt) + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ( "Expected legacy secret key with unsupported symmetric algorithm to produce BrokenPacketPkt, got " + ++ show other + ) + +testLegacyPKESKX25519ParsesRFC9580V3OctetLayout :: Assertion +testLegacyPKESKX25519ParsesRFC9580V3OctetLayout = do + let ephemeral = B.pack [0x01 .. 0x20] + wrappedWithAlgo = + B.singleton (fromIntegral (fromFVal AES128)) + <> B.replicate 24 0x5a + encoded = + runPut $ do + putWord8 0xc1 + putWord8 + ( fromIntegral + (1 + 8 + 1 + B.length ephemeral + 1 + B.length wrappedWithAlgo) + ) + putWord8 3 + putByteString (B.replicate 8 0) + putWord8 (fromIntegral (fromFVal X25519)) + putByteString ephemeral + putWord8 (fromIntegral (B.length wrappedWithAlgo)) + putByteString wrappedWithAlgo + case runGet (get :: Get Pkt) encoded of + Right + ( PKESKPkt + ( PKESKPayloadV3Packet + (PKESKPayloadV3 3 _ X25519 (ephMPI :| [eskMPI])) + ) + ) -> do + assertEqual + "legacy X25519 v3 octet-layout ephemeral parse" + (MPI (os2ip ephemeral)) + ephMPI + assertEqual + "legacy X25519 v3 octet-layout wrapped parse" + (MPI (os2ip wrappedWithAlgo)) + eskMPI + other -> + assertFailure + ( "Expected legacy X25519 PKESK v3 octet-layout parse success, got " + ++ show other + ) + +testSigV6RejectsInvalidSaltSize :: Assertion +testSigV6RejectsInvalidSaltSize = do + let encoded = + runPut $ do + putWord8 0xc2 + putWord8 45 + putWord8 6 + putWord8 0 + putWord8 1 + putWord8 8 + putWord32be 0 + putWord32be 0 + putWord16be 0 + putWord8 32 + putByteString (B.replicate 32 0) + putWord16be 0 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> return () + other -> + assertFailure + ( "Expected invalid SigV6 salt size to produce BrokenPacketPkt, got " + ++ show other + ) + +testOPS6RejectsInvalidSaltSize :: Assertion +testOPS6RejectsInvalidSaltSize = do + let encoded = + runPut $ do + putWord8 0xc4 + putWord8 69 + putWord8 6 + putWord8 0 + putWord8 10 + putWord8 22 + putWord8 31 + putByteString (B.replicate 31 0) + putByteString (B.replicate 32 0) + putWord8 0 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> return () + other -> + assertFailure + ( "Expected invalid OPS6 salt size to produce BrokenPacketPkt, got " + ++ show other + ) + +testOPS3RejectsInvalidNestedFlagOctet :: Assertion +testOPS3RejectsInvalidNestedFlagOctet = do + let encoded = + runPut $ do + putWord8 0xc4 + putWord8 13 + putWord8 3 + putWord8 0 + putWord8 8 + putWord8 1 + putByteString (B.replicate 8 0) + putWord8 2 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ( "Expected invalid OPS3 nested-flag octet to produce BrokenPacketPkt, got " + ++ show other + ) + +testOPS6RejectsInvalidNestedFlagOctet :: Assertion +testOPS6RejectsInvalidNestedFlagOctet = do + let encoded = + runPut $ do + putWord8 0xc4 + putWord8 70 + putWord8 6 + putWord8 0 + putWord8 8 + putWord8 1 + putWord8 32 + putByteString (B.replicate 32 0) + putByteString (B.replicate 32 0) + putWord8 2 + case runGet (get :: Get Pkt) encoded of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ( "Expected invalid OPS6 nested-flag octet to produce BrokenPacketPkt, got " + ++ show other + ) + +mkECDHBoundaryTestPacket :: Pkt +mkECDHBoundaryTestPacket = + PublicKeyPkt + ( PKPayload + V4 + 0 + 0 + ECDH + ( ECDHPubKey + ( ECDSAPubKey + ( ECDSA_PublicKey + ( ECDSA.PublicKey + (ECCT.getCurveByName ECCT.SEC_p256r1) + (ECCT.Point 1 2) + ) + ) + ) + SHA256 + AES128 + ) + ) + +setStrictByteAt + :: Int -> Word8 -> B.ByteString -> Maybe B.ByteString +setStrictByteAt idx w bs + | idx < 0 || idx >= B.length bs = Nothing + | otherwise = + let (prefix, rest) = B.splitAt idx bs + in case B.uncons rest of + Nothing -> Nothing + Just (_, suffix) -> Just (prefix <> B.singleton w <> suffix) + +testECDHPubkeyRejectsReservedKDFLengthZero :: Assertion +testECDHPubkeyRejectsReservedKDFLengthZero = do + let encoded = BL.toStrict (runPut (put mkECDHBoundaryTestPacket)) + mutated <- + maybe + ( assertFailure + "failed to locate ECDH KDF length byte for zero-length rejection test" + >> fail "unreachable" + ) + pure + (setStrictByteAt (B.length encoded - 4) 0x00 encoded) + case runGet (get :: Get Pkt) (BL.fromStrict mutated) of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ( "Expected ECDH KDF length 0 to produce BrokenPacketPkt, got " + ++ show other + ) + +testECDHPubkeyRejectsReservedKDFLength255 :: Assertion +testECDHPubkeyRejectsReservedKDFLength255 = do + let encoded = BL.toStrict (runPut (put mkECDHBoundaryTestPacket)) + mutated <- + maybe + ( assertFailure + "failed to locate ECDH KDF length byte for 0xff rejection test" + >> fail "unreachable" + ) + pure + (setStrictByteAt (B.length encoded - 4) 0xff encoded) + case runGet (get :: Get Pkt) (BL.fromStrict mutated) of + Right BrokenPacketPkt {} -> pure () + other -> + assertFailure + ( "Expected ECDH KDF length 255 to produce BrokenPacketPkt, got " + ++ show other + ) + +testECDHPubkeyEncodesFixedKDFLength :: Assertion +testECDHPubkeyEncodesFixedKDFLength = do + let encoded = BL.toStrict (runPut (put mkECDHBoundaryTestPacket)) + trailer = B.drop (B.length encoded - 4) encoded + assertEqual + "ECDH public-key encoding should emit fixed KDF trailer [3,1,hash,sym]" + (B.pack [0x03, 0x01, fromFVal SHA256, fromFVal AES128]) + trailer + +testKeyFlagsSubpacketEncodesEmptySetWithZeroOctet :: Assertion +testKeyFlagsSubpacketEncodesEmptySetWithZeroOctet = do + let encoded = runPut (put (SigSubPacket False (KeyFlags Set.empty))) + assertEqual + "empty key-flags subpacket should encode an explicit zero flags octet" + [2, 27, 0] + (BL.unpack encoded) + case runGet (get :: Get SigSubPacket) encoded of + Right (SigSubPacket False (KeyFlags flags)) -> + assertEqual + "empty key-flags subpacket should decode back to an empty flag set" + Set.empty + flags + other -> + assertFailure + ( "Expected empty key-flags subpacket roundtrip, got " + ++ show other + ) + +expectedV6SaltSizeForTest :: HashAlgorithm -> Maybe Int +expectedV6SaltSizeForTest = + fmap fromIntegral . signatureV6SaltSizeForHashAlgorithm + +signatureHasIssuerFingerprintV6 + :: Fingerprint -> SignaturePayload -> Bool +signatureHasIssuerFingerprintV6 expectedFp (SigV6 _ _ _ _ hashed unhashed _ _) = + expectedFp + `elem` [ ifp + | SigSubPacket _ (IssuerFingerprint IssuerFingerprintV6 ifp) <- + hashed ++ unhashed + ] +signatureHasIssuerFingerprintV6 _ _ = False + +testV6SecretFixtureSignatureSemantics :: Assertion +testV6SecretFixtureSignatureSemantics = do + armors <- loadArmor "v6-secret.pgp.aa" + payload <- + case armors of + (a : _) -> pure (armorPayload a) + [] -> + assertFailure + "v6-secret.pgp.aa should contain one armored payload" + >> fail "expected one armored payload" + let packets = parsePkts payload + primaryV6Key = + listToMaybe + [ pkp + | SecretKeyPkt pkp _ <- packets + , _keyVersion pkp == V6 + ] + <|> listToMaybe + [ pkp + | PublicKeyPkt pkp <- packets + , _keyVersion pkp == V6 + ] + signatures = + [ (sig, ha, salt) + | SignaturePkt sig@(SigV6 _ _ ha salt _ _ _ _) <- packets + ] + pkp <- + case primaryV6Key of + Nothing -> + assertFailure + "v6-secret.pgp.aa should contain a primary v6 key packet" + >> fail "expected primary v6 key packet" + Just k -> pure k + assertBool + "v6-secret.pgp.aa should contain at least one SigV6 packet" + (not (null signatures)) + mapM_ + ( \(_, ha, salt) -> + case expectedV6SaltSizeForTest ha of + Nothing -> + assertFailure + ( "SigV6 in v6-secret.pgp.aa uses unsupported salt hash algorithm: " + ++ show ha + ) + Just expected -> + assertEqual + "SigV6 salt size in v6-secret.pgp.aa should match hash algorithm" + expected + (fromIntegral (BL.length (unSignatureSalt salt))) + ) + signatures + assertBool + "v6-secret.pgp.aa should include at least one IssuerFingerprint v6 matching the primary key" + ( any + ( \(sig, _, _) -> signatureHasIssuerFingerprintV6 (fingerprint pkp) sig + ) + signatures + ) + +testV6SecretFixtureDerivesEightOctetKeyID :: Assertion +testV6SecretFixtureDerivesEightOctetKeyID = do + armors <- loadArmor "v6-secret.pgp.aa" + payload <- + case armors of + (a : _) -> pure (armorPayload a) + [] -> + assertFailure + "v6-secret.pgp.aa should contain one armored payload" + >> fail "expected one armored payload" + let packets = parsePkts payload + primaryV6Key = + listToMaybe + [ pkp + | SecretKeyPkt pkp _ <- packets + , _keyVersion pkp == V6 + ] + <|> listToMaybe + [ pkp + | PublicKeyPkt pkp <- packets + , _keyVersion pkp == V6 + ] + pkp <- + case primaryV6Key of + Nothing -> + assertFailure + "v6-secret.pgp.aa should contain a primary v6 key packet" + >> fail "expected primary v6 key packet" + Just k -> pure k + derivedKeyId <- + case eightOctetKeyID pkp of + Left err -> + assertFailure + ("Expected v6 eight-octet key-id derivation to succeed: " ++ err) + >> fail "expected v6 eight-octet key-id" + Right keyId -> pure keyId + let expectedKeyId = EightOctetKeyId (BL.take 8 (unFingerprint (fingerprint pkp))) + assertEqual + "v6 eight-octet key-id should be the high-order 64 bits of the fingerprint" + expectedKeyId + derivedKeyId diff --git a/tests/Tests/Utilities.hs b/tests/Tests/Utilities.hs --- a/tests/Tests/Utilities.hs +++ b/tests/Tests/Utilities.hs @@ -2,1354 +2,1622 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). - -{-# LANGUAGE OverloadedStrings #-} - -module Tests.Utilities (utilityTests) where - -import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) -import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev) -import Codec.Encryption.OpenPGP.KeyringParser - ( parsePublicTKs - , parseSecretTKs - , parseTKsEither - , parseTKs - , parseTKsWithWireRep - , parseUnknownTKs - ) -import Codec.Encryption.OpenPGP.Serialize - ( PktParseError(..) - , WireRepInput(..) - , conduitParsePktsWithWireRep - , dearmorIfAsciiArmored - , dearmorIfAsciiArmoredLenient - , looksLikeAsciiArmor - , parsePkts - , parsePktsEither - , parsePktsWithWireRep - , wireRepRefFromInput - ) -import Codec.Encryption.OpenPGP.Types -import Crypto.Number.Serialize (os2ip) -import Data.Binary (get) -import Data.Binary.Get (Get) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Conduit as DC -import qualified Data.Conduit.Binary as CB -import qualified Data.Conduit.List as CL -import Data.Conduit.OpenPGP.Keyring - ( AuthSecretSubkeyRejectionReason(..) - , AuthSecretSubkeyUID(..) - , AuthSecretSubkeysAtReport(..) - , authSecretSubkeysAt - , authSecretSubkeysAtReport - , authSecretSubkeyPrimaryUID - , authSecretSubkeyRejectedReason - , authSecretSubkeyUIDs - , authSecretSubkeyValue - , conduitToSomeTKsDroppingEither - , conduitToAuthSecretSubkeysAt - , conduitToAuthSecretSubkeysAtReport - , conduitToSomeTKsEither - , conduitToPublicTKs - , conduitToSecretTKs - , conduitToTKs - , conduitToTKsWithWireRep - , conduitToUnknownTKs - ) -import Data.Conduit.Serialization.Binary (conduitGet) -import Data.Either (lefts, rights) -import Data.List (isInfixOf, nub, sortOn) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.Maybe (catMaybes) -import qualified Data.Set as Set -import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase) -import Tests.Common - ( addTimestampSeconds - , loadAndDecompressPkts - , loadUnencryptedRsaSigner - , loadV6UnencryptedSecretKeyFixtureForProperty - , readFixtureLazy - , readFixturePackets - , runGet - , setKeyTimestamp - , signCertificationAt - , signSubkeyBindingWithRSAExtrasAt - , signSubkeyRevocationWithRSAAt - , timestampToUTCTime - ) - - -utilityTests :: TestTree -utilityTests = - testGroup - "Utility function group" - [ testCase "pubring as packets" (testParsePktsUtil "pubring.gpg") - , testCase - "pubring parsePktsEither equals parsePkts on valid input" - (testParsePktsEitherUtil "pubring.gpg") - , testCase - "parsePktsEither reports truncation errors" - (testParsePktsEitherFailureUtil "pubring.gpg") - , testCase - "parseUnknownTKs drops disallowed primary-key signature context (v4)" - testParseTKsDropsDisallowedPrimaryKeySigContextV4 - , testCase - "parseUnknownTKs drops disallowed primary-key signature context (v6)" - testParseTKsDropsDisallowedPrimaryKeySigContextV6 - , testCase - "parseUnknownTKs accepts allowed primary-key signature context (v6)" - testParseTKsAcceptsAllowedPrimaryKeySigContextV6 - , testCase "pubring as TKs" (testParseTKsUtil "pubring.gpg") - , testCase - "pubring as typed TKs" - (testParseTKsTypedUtil "pubring.gpg") - , testCase - "pubring parseTKsEither preserves typed parse outcomes" - (testParseTKsEitherUtil "pubring.gpg") - , testCase - "typed TKUnknown conduit partitioning" - (testConduitToTKsTypedUtil "pubring.gpg") - , testCase - "typed TK conduit either reports values without silent drops on valid input" - (testConduitToSomeTKsEitherUtil "pubring.gpg") - , testCase - "typed TK dropping conduit either preserves valid typed results" - (testConduitToSomeTKsDroppingEitherUtil "pubring.gpg") - , testCase - "auth-capable secret-subkey conduit filters revoked/expired/auth flags" - testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth - , testCase - "auth-capable secret-subkey conduit tracks primary UID over time" - testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime - , testCase - "auth-capable secret-subkey report includes typed rejection reasons" - testAuthSecretSubkeysAtReportIncludesRejectionReasons - , testCase - "pkalgoAbbrev handles RFC9580-era pubkey algorithms" - testPKAlgoAbbrevRFC9580 - , testCase - "EightOctetKeyId Show/Read roundtrip uses hex form" - testEightOctetKeyIdReadShowRoundtrip - , testCase - "PktWithWireRep Ord uses raw bytes for tie-breakers" - testPktWithWireRepOrdUsesRawBytes - , testCase - "pubring as packets with provenance" - (testParsePktsWithWireRepUtil "pubring.gpg") - , testCase - "pubring as TKs with provenance" - (testParseTKsWithWireRepUtil "pubring.gpg") - , testCase - "wire provenance tracks original ASCII armor" - testWireRepRefTracksArmorProvenance - , testCase - "dearmorIfAsciiArmored rejects multi-block armored inputs" - testDearmorRejectsMultipleBlocks - , testCase - "dearmorIfAsciiArmoredLenient accepts BOM-prefixed armor" - testDearmorLenientAcceptsBomPrefixedArmor - , testCase - "looksLikeAsciiArmor centralizes armor prefix detection" - testLooksLikeAsciiArmor - , testCase - "wireRepRefFromInput surfaces malformed armored decode errors" - testWireRepRefRejectsMalformedArmoredInput - , testCase - "tksFromWireRep matches any source in TKUnknown provenance list" - testTksFromWireRepMatchesAnySource - , testCase - "TKWithWireRep Semigroup preserves structured provenance" - testSemigroupTKWithWireRepPreservesStructuredRefs - , testCase - "canonicalizeTKWithWireRep matches manual wire-byte ordering" - testCanonicalizeTKWithWireRepMatchesManualWireOrdering - , testCase - "canonicalizeTKWithWireRep reports missing packet refs" - testCanonicalizeTKWithWireRepReportsMissingRef - , testCase - "KeyPkt wrappers preserve packet kind/role round-trips" - testKeyPktWrappersRoundTrip - , testCase - "TK public/secret conversion and projection round-trip" - testTKTypedRoundTripAndPublicView - , testCase - "uat.gpg embeds expected image data from uat.jpg" - testUatImageFixture - ] - -testPKAlgoAbbrevRFC9580 :: Assertion -testPKAlgoAbbrevRFC9580 = do - assertEqual "X25519 abbreviation" "x25" (pkalgoAbbrev (toFVal 25)) - assertEqual "X448 abbreviation" "x448" (pkalgoAbbrev (toFVal 26)) - assertEqual "Ed25519 abbreviation" "e25" (pkalgoAbbrev (toFVal 27)) - assertEqual "Ed448 abbreviation" "e448" (pkalgoAbbrev (toFVal 28)) - -testEightOctetKeyIdReadShowRoundtrip :: Assertion -testEightOctetKeyIdReadShowRoundtrip = do - let eoki = EightOctetKeyId (BL.pack [0x01, 0x23, 0x45, 0x67, 0x89, 0xab, 0xcd, 0xef]) - assertEqual "show prints canonical uppercase hex" "0123456789ABCDEF" (show eoki) - assertEqual "read . show roundtrip" eoki (read (show eoki)) - -testUatImageFixture :: Assertion -testUatImageFixture = do - expectedImage <- readFixtureLazy "uat.jpg" - packets <- loadAndDecompressPkts "uat.gpg" - let images = - [ imageData - | UserAttributePkt uas <- packets - , ImageAttribute _ imageData <- uas - ] - assertBool "uat.gpg should contain a user-attribute image packet" (not (null images)) - assertBool - "uat.gpg should embed the uat.jpg payload" - (expectedImage `elem` images) - -testParsePktsUtil :: FilePath -> Assertion -testParsePktsUtil fn = do - cp <- readFixturePackets fn - pp <- parsePkts `fmap` readFixtureLazy fn - assertEqual - "parsePkts utility function gives same results as conduit pipeline" - cp - pp - -testParsePktsEitherUtil :: FilePath -> Assertion -testParsePktsEitherUtil fn = do - lbs <- readFixtureLazy fn - assertEqual - "parsePktsEither matches parsePkts on valid input" - (Right (parsePkts lbs)) - (parsePktsEither lbs) - -testParsePktsEitherFailureUtil :: FilePath -> Assertion -testParsePktsEitherFailureUtil fn = do - lbs <- readFixtureLazy fn - let truncated = BL.take (BL.length lbs - 1) lbs - case parsePktsEither truncated of - Left (PktParseError off msg) -> do - assertBool "parsePktsEither reports non-empty parse error messages" (not (null msg)) - assertBool "parsePktsEither reports an in-range failure offset" (off >= 0 && off <= BL.length truncated) - assertBool - "legacy parsePkts still returns a parsed prefix on malformed input" - (length (parsePkts truncated) <= length (parsePkts lbs)) - Right _ -> - assertFailure "parsePktsEither should fail when input is truncated" - -testParseTKsUtil :: FilePath -> Assertion -testParseTKsUtil fn = do - lbs <- readFixtureLazy fn - cp <- - DC.runConduitRes $ - CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToUnknownTKs DC..| CL.consume - let pt = parseUnknownTKs True . parsePkts $ lbs - assertEqual - "parsePkts utility function gives same results as conduit pipeline" - cp - pt - -testParseTKsTypedUtil :: FilePath -> Assertion -testParseTKsTypedUtil fn = do - lbs <- readFixtureLazy fn - let packets = parsePkts lbs - plain = parseUnknownTKs True packets - typed = parseTKs True packets - typedPublic = parsePublicTKs True packets - typedSecret = parseSecretTKs True packets - assertEqual - "parseTKs round-trips to the same untyped TKUnknown semantics" - plain - (map someTKToUnknown typed) - assertEqual - "public + secret typed partitions preserve full typed parse count" - (length typed) - (length typedPublic + length typedSecret) - -testParseTKsEitherUtil :: FilePath -> Assertion -testParseTKsEitherUtil fn = do - lbs <- readFixtureLazy fn - let packets = parsePkts lbs - typed = parseTKs True packets - typedEither = parseTKsEither True packets - assertEqual - "parseTKsEither right results should match parseTKs" - typed - (rights typedEither) - assertBool - "parseTKsEither should have no conversion failures for canonical pubring fixture" - (null (lefts typedEither)) - -testConduitToTKsTypedUtil :: FilePath -> Assertion -testConduitToTKsTypedUtil fn = do - lbs <- readFixtureLazy fn - allTyped <- - DC.runConduitRes $ - CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume - publicTyped <- - DC.runConduitRes $ - CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToPublicTKs DC..| CL.consume - secretTyped <- - DC.runConduitRes $ - CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToSecretTKs DC..| CL.consume - assertEqual - "typed conduit round-trips to parseUnknownTKs semantics" - (parseUnknownTKs True (parsePkts lbs)) - (map someTKToUnknown allTyped) - assertEqual - "typed conduit public + secret partitions preserve full count" - (length allTyped) - (length publicTyped + length secretTyped) - -testConduitToSomeTKsEitherUtil :: FilePath -> Assertion -testConduitToSomeTKsEitherUtil fn = do - lbs <- readFixtureLazy fn - results <- - DC.runConduitRes $ - CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToSomeTKsEither DC..| CL.consume - let typedFromEither = catMaybes (rights results) - assertBool - "conduitToSomeTKsEither should not report failures for canonical pubring fixture" - (null (lefts results)) - assertEqual - "conduitToSomeTKsEither right values should match conduitToTKs semantics" - (parseTKs True (parsePkts lbs)) - typedFromEither - -testConduitToSomeTKsDroppingEitherUtil :: FilePath -> Assertion -testConduitToSomeTKsDroppingEitherUtil fn = do - lbs <- readFixtureLazy fn - results <- - DC.runConduitRes $ - CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToSomeTKsDroppingEither DC..| CL.consume - let typedFromEither = catMaybes (rights results) - assertBool - "conduitToSomeTKsDroppingEither should not report failures for canonical pubring fixture" - (null (lefts results)) - assertEqual - "conduitToSomeTKsDroppingEither right values should match tolerant parseTKs semantics" - (parseTKs False (parsePkts lbs)) - typedFromEither - -testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth :: Assertion -testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let baseTime = _timestamp signer - beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 18) - afterTime = timestampToUTCTime (addTimestampSeconds baseTime 24) - uidText = "auth-subkeys@example.org" - uid = UserId uidText - secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 - authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer - expiringAuthSubkey = setKeyTimestamp (addTimestampSeconds baseTime 2) signer - signingOnlySubkey = setKeyTimestamp (addTimestampSeconds baseTime 3) signer - - uidCertification <- - signCertificationAt - signer - signingKey - uid - (addTimestampSeconds baseTime 8) - [SigSubPacket False (PrimaryUserId True)] - authBinding <- - signSubkeyBindingWithRSAExtrasAt - signer - authSubkey - signingKey - (addTimestampSeconds baseTime 10) - [SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))] - expiringAuthBinding <- - signSubkeyBindingWithRSAExtrasAt - signer - expiringAuthSubkey - signingKey - (addTimestampSeconds baseTime 10) - [ SigSubPacket False (KeyFlags (Set.fromList [AuthKey])) - , SigSubPacket False (KeyExpirationTime 20) - ] - signingOnlyBinding <- - signSubkeyBindingWithRSAExtrasAt - signer - signingOnlySubkey - signingKey - (addTimestampSeconds baseTime 10) - [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] - authRevocation <- - signSubkeyRevocationWithRSAAt - signer - authSubkey - signingKey - (addTimestampSeconds baseTime 22) - - let tk = - TKUnknown - (signer, Just secretAddendum) - [] - [(uidText, [uidCertification])] - [] - [ (SecretSubkeyPkt authSubkey secretAddendum, [authBinding, authRevocation]) - , (SecretSubkeyPkt expiringAuthSubkey secretAddendum, [expiringAuthBinding]) - , (SecretSubkeyPkt signingOnlySubkey secretAddendum, [signingOnlyBinding]) - ] - typedSecret <- - case fromUnknownToTK tk of - Right (SomeSecretTK typed) -> pure typed - Right (SomePublicTK _) -> - assertFailure "expected secret typed TKUnknown for auth subkey test fixture" >> fail "unreachable" - Left err -> - assertFailure ("fromUnknownToTK failed for auth subkey test fixture: " ++ err) >> fail "unreachable" - - selectedBefore <- - DC.runConduitRes $ - CL.sourceList [typedSecret] DC..| conduitToAuthSecretSubkeysAt beforeTime DC..| CL.consume - assertEqual - "pure authSecretSubkeysAt helper and conduit output should match" - (authSecretSubkeysAt beforeTime typedSecret) - selectedBefore - assertEqual - "before revocation/expiry, conduit should keep only auth-capable secret subkeys" - 2 - (length selectedBefore) - let selectedBeforeFps = - Set.fromList - (map (fingerprint . keyPktPKPayload . authSecretSubkeyValue) selectedBefore) - assertEqual - "selected auth-capable subkeys should match expected fingerprints" - (Set.fromList [fingerprint authSubkey, fingerprint expiringAuthSubkey]) - selectedBeforeFps - mapM_ - (\selection -> do - assertEqual "selected auth subkey should retain active primary UID context" (Just uidText) (authSecretSubkeyPrimaryUID selection) - assertEqual - "selected auth subkey should expose UID context with primary marker" - [AuthSecretSubkeyUID uidText True] - (authSecretSubkeyUIDs selection)) - selectedBefore - - selectedAfter <- - DC.runConduitRes $ - CL.sourceList [typedSecret] DC..| conduitToAuthSecretSubkeysAt afterTime DC..| CL.consume - assertEqual - "after revocation/expiry, conduit should drop revoked/expired auth subkeys" - [] - selectedAfter - -testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime :: Assertion -testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let baseTime = _timestamp signer - beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 15) - afterTime = timestampToUTCTime (addTimestampSeconds baseTime 25) - uidA = UserId "uid-a@example.org" - UserId uidAText = uidA - uidB = UserId "uid-b@example.org" - UserId uidBText = uidB - secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 - authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer - - uidACert <- - signCertificationAt - signer - signingKey - uidA - (addTimestampSeconds baseTime 10) - [SigSubPacket False (PrimaryUserId True)] - uidBCert <- - signCertificationAt - signer - signingKey - uidB - (addTimestampSeconds baseTime 20) - [SigSubPacket False (PrimaryUserId True)] - authBinding <- - signSubkeyBindingWithRSAExtrasAt - signer - authSubkey - signingKey - (addTimestampSeconds baseTime 11) - [SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))] - - let tk = - TKUnknown - (signer, Just secretAddendum) - [] - [(uidAText, [uidACert]), (uidBText, [uidBCert])] - [] - [(SecretSubkeyPkt authSubkey secretAddendum, [authBinding])] - typedSecret <- - case fromUnknownToTK tk of - Right (SomeSecretTK typed) -> pure typed - Right (SomePublicTK _) -> - assertFailure "expected secret typed TKUnknown for primary-uid test fixture" >> fail "unreachable" - Left err -> - assertFailure ("fromUnknownToTK failed for primary-uid test fixture: " ++ err) >> fail "unreachable" - - beforeSelections <- - DC.runConduitRes $ - CL.sourceList [typedSecret] DC..| conduitToAuthSecretSubkeysAt beforeTime DC..| CL.consume - beforeSelection <- - case beforeSelections of - [selection] -> pure selection - other -> - assertFailure ("expected one auth-capable subkey selection before primary-uid rollover, got " ++ show (length other)) >> - fail "unreachable" - assertEqual - "earlier primary UID should be selected before newer self-certification" - (Just uidAText) - (authSecretSubkeyPrimaryUID beforeSelection) - assertEqual - "UID context should include only active UIDs before uid-b certification exists" - [(uidAText, True)] - (map (\u -> (authSecretSubkeyUIDValue u, authSecretSubkeyUIDIsPrimary u)) (authSecretSubkeyUIDs beforeSelection)) - - afterSelections <- - DC.runConduitRes $ - CL.sourceList [typedSecret] DC..| conduitToAuthSecretSubkeysAt afterTime DC..| CL.consume - afterSelection <- - case afterSelections of - [selection] -> pure selection - other -> - assertFailure ("expected one auth-capable subkey selection after primary-uid rollover, got " ++ show (length other)) >> - fail "unreachable" - assertEqual - "newer primary UID self-certification should win after rollover" - (Just uidBText) - (authSecretSubkeyPrimaryUID afterSelection) - assertEqual - "UID context should mark uid-b as primary after rollover" - [(uidAText, False), (uidBText, True)] - (map (\u -> (authSecretSubkeyUIDValue u, authSecretSubkeyUIDIsPrimary u)) (authSecretSubkeyUIDs afterSelection)) - -testAuthSecretSubkeysAtReportIncludesRejectionReasons :: Assertion -testAuthSecretSubkeysAtReportIncludesRejectionReasons = do - (signer, signingKey) <- loadUnencryptedRsaSigner - let baseTime = _timestamp signer - beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 18) - afterTime = timestampToUTCTime (addTimestampSeconds baseTime 24) - uidText = "auth-subkeys@example.org" - uid = UserId uidText - secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 - authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer - expiringAuthSubkey = setKeyTimestamp (addTimestampSeconds baseTime 2) signer - signingOnlySubkey = setKeyTimestamp (addTimestampSeconds baseTime 3) signer - - uidCertification <- - signCertificationAt - signer - signingKey - uid - (addTimestampSeconds baseTime 8) - [SigSubPacket False (PrimaryUserId True)] - authBinding <- - signSubkeyBindingWithRSAExtrasAt - signer - authSubkey - signingKey - (addTimestampSeconds baseTime 10) - [SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))] - expiringAuthBinding <- - signSubkeyBindingWithRSAExtrasAt - signer - expiringAuthSubkey - signingKey - (addTimestampSeconds baseTime 10) - [ SigSubPacket False (KeyFlags (Set.fromList [AuthKey])) - , SigSubPacket False (KeyExpirationTime 20) - ] - signingOnlyBinding <- - signSubkeyBindingWithRSAExtrasAt - signer - signingOnlySubkey - signingKey - (addTimestampSeconds baseTime 10) - [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] - authRevocation <- - signSubkeyRevocationWithRSAAt - signer - authSubkey - signingKey - (addTimestampSeconds baseTime 22) - - let tk = - TKUnknown - (signer, Just secretAddendum) - [] - [(uidText, [uidCertification])] - [] - [ (SecretSubkeyPkt authSubkey secretAddendum, [authBinding, authRevocation]) - , (SecretSubkeyPkt expiringAuthSubkey secretAddendum, [expiringAuthBinding]) - , (SecretSubkeyPkt signingOnlySubkey secretAddendum, [signingOnlyBinding]) - ] - typedSecret <- - case fromUnknownToTK tk of - Right (SomeSecretTK typed) -> pure typed - Right (SomePublicTK _) -> - assertFailure "expected secret typed TKUnknown for auth subkey rejection test fixture" >> fail "unreachable" - Left err -> - assertFailure ("fromUnknownToTK failed for auth subkey rejection test fixture: " ++ err) >> fail "unreachable" - - let beforeReport = authSecretSubkeysAtReport beforeTime typedSecret - assertEqual - "report accepted list should match authSecretSubkeysAt before revocation/expiry" - (authSecretSubkeysAt beforeTime typedSecret) - (authSecretSubkeysAccepted beforeReport) - assertEqual - "before revocation/expiry, only signing-only subkey should be rejected" - [AuthSecretSubkeyMissingAuthCapability] - (map authSecretSubkeyRejectedReason (authSecretSubkeysRejected beforeReport)) - - afterReportsViaConduit <- - DC.runConduitRes $ - CL.sourceList [typedSecret] DC..| conduitToAuthSecretSubkeysAtReport afterTime DC..| CL.consume - afterReport <- - case afterReportsViaConduit of - [singleReport] -> pure singleReport - other -> - assertFailure ("expected one report from conduitToAuthSecretSubkeysAtReport, got " ++ show (length other)) >> - fail "unreachable" - assertEqual - "after revocation/expiry, no accepted auth subkeys should remain" - [] - (authSecretSubkeysAccepted afterReport) - assertEqual - "after revocation/expiry, rejected reasons should report invalid-time and missing-auth cases for still-visible candidates" - [ AuthSecretSubkeySubkeyInvalidAtTime - , AuthSecretSubkeyMissingAuthCapability - ] - (map authSecretSubkeyRejectedReason (authSecretSubkeysRejected afterReport)) - -testPktWithWireRepOrdUsesRawBytes :: Assertion -testPktWithWireRepOrdUsesRawBytes = do - let src = wireRepRef "src" - pktA = - PktWithWireRep - src - (ByteRange 0 1) - "a" - 0 - (OtherPacketPkt 42 "a") - pktB = - PktWithWireRep - src - (ByteRange 1 1) - "b" - 1 - (BrokenPacketPkt "broken" 42 "b") - assertEqual - "base packet ordering can tie on tag-only fallback" - EQ - (compare (_pktValue pktA) (_pktValue pktB)) - assertEqual - "PktWithWireRep ordering should break ties using packet bytes" - LT - (compare pktA pktB) - -testParsePktsWithWireRepUtil :: FilePath -> Assertion -testParsePktsWithWireRepUtil fn = do - let fpath = "tests/data/" ++ fn - lbs <- BL.readFile fpath - let WireRepInput - { wireRepInputRef = src - , wireRepInputPayload = srcBytes - } = - either - (const - WireRepInput - { wireRepInputRef = wireRepRef lbs - , wireRepInputPayload = lbs - }) - id - (wireRepRefFromInput Nothing lbs) - parsed = parsePktsWithWireRep src srcBytes - chunkedInput = chunkStrict 7 (BL.toStrict lbs) - conduitParsed <- - DC.runConduitRes $ - CB.sourceLbs lbs DC..| conduitParsePktsWithWireRep Nothing DC..| CL.consume - conduitParsedChunked <- - DC.runConduitRes $ - CL.sourceList chunkedInput DC..| conduitParsePktsWithWireRep Nothing DC..| CL.consume - assertEqual - "provenance-aware parsePkts preserves packet semantics" - (parsePkts lbs) - (map _pktValue parsed) - assertEqual - "conduit and pure provenance-aware packet parsing agree" - parsed - conduitParsed - assertEqual - "conduit parser handles packets split across chunk boundaries" - parsed - conduitParsedChunked - assertEqual - "packetsFromWireRep returns all packets for the originating bytestream" - parsed - (packetsFromWireRep src parsed) - mapM_ (assertPktProvenance src srcBytes) parsed - where - chunkStrict n bs - | B.null bs = [] - | otherwise = - let (prefix, suffix) = B.splitAt n bs - in prefix : chunkStrict n suffix - -testParseTKsWithWireRepUtil :: FilePath -> Assertion -testParseTKsWithWireRepUtil fn = do - let fpath = "tests/data/" ++ fn - lbs <- BL.readFile fpath - let WireRepInput - { wireRepInputRef = src - , wireRepInputPayload = srcBytes - } = - either - (const - WireRepInput - { wireRepInputRef = wireRepRef lbs - , wireRepInputPayload = lbs - }) - id - (wireRepRefFromInput Nothing lbs) - packets = parsePktsWithWireRep src srcBytes - parsed = parseTKsWithWireRep True packets - plain = parseUnknownTKs True (map _pktValue packets) - conduitParsed <- - DC.runConduitRes $ CL.sourceList packets DC..| conduitToTKsWithWireRep DC..| CL.consume - assertEqual - "provenance-aware parseUnknownTKs preserves TKUnknown semantics" - plain - (map _tkValue parsed) - assertEqual - "conduit and pure provenance-aware TKUnknown parsing agree" - parsed - conduitParsed - assertEqual - "tksFromWireRep returns all TKs for the originating bytestream" - parsed - (tksFromWireRep src parsed) - mapM_ (assertTKProvenance src parsed) parsed - -assertPktProvenance :: WireRepRef -> BL.ByteString -> PktWithWireRep -> Assertion -assertPktProvenance src srcBytes pkt = do - assertEqual - "packet raw bytes round-trip back to the same packet" - (Right (_pktValue pkt)) - (runGet (get :: Get Pkt) (_pktRaw pkt)) - assertEqual - "packet source reference is preserved" - src - (wireRepOfPkt pkt) - let ByteRange offset len = _pktRange pkt - assertEqual - "packet raw bytes match the source bytestream slice" - (_pktRaw pkt) - (BL.take len (BL.drop offset srcBytes)) - -assertTKProvenance :: WireRepRef -> [TKWithWireRep] -> TKWithWireRep -> Assertion -assertTKProvenance src allTks tk = do - assertBool "TKUnknown source reference list includes originating source" (src `elem` _tkWireRepRefs tk) - assertEqual "TKUnknown source reference is preserved" src (wireRepOfTK tk) - assertEqual - "TKUnknown packet references reconstruct the semantic TKUnknown packet sequence" - (flattenTK (_tkValue tk)) - (map _pktValue (packetRefsOfTK tk)) - assertEqual - "TKUnknown source span matches the span of its packet references" - (spanByteRanges (map _pktRange (packetRefsOfTK tk))) - (_tkWireRepRange tk) - mapM_ - (\pkt -> - assertBool - "packet backlink resolves to containing TKUnknown" - (tk `elem` tksContainingPacket pkt allTks)) - (packetRefsOfTK tk) - case toStructuredTKWithWireRep tk of - Left err -> - assertFailure ("toStructuredTKWithWireRep failed: " ++ err) - Right structured -> do - assertEqual - "structured provenance retains semantic primary key" - (_tkuKey (_tkValue tk)) - (_tkStructuredPrimaryKey structured) - assertEqual - "structured provenance retains packet source reference list" - (_tkWireRepRefs tk) - (_tkStructuredWireRepRefs structured) - resolved <- resolveStructuredPacketRefs structured - assertEqual - "structured provenance resolves packet refs in TKUnknown packet order" - (map _pktValue (packetRefsOfTK tk)) - (map _pktValue resolved) - assertEqual - "structured provenance keeps stable packet ref ids" - (map packetRefIdOf (packetRefsOfTK tk)) - (map packetRefIdOf resolved) - -resolveStructuredPacketRefs :: TKStructuredWithWireRep -> IO [PktWithWireRep] -resolveStructuredPacketRefs structured = do - let collectSigRefs = map _signatureWithWireRefRef - uidRefs = - concatMap - (\uid -> _uidWithWireRefsRef uid : collectSigRefs (_uidWithWireRefsSignatures uid)) - (_tkStructuredUIDs structured) - uatRefs = - concatMap - (\uat -> _uatWithWireRefsRef uat : collectSigRefs (_uatWithWireRefsSignatures uat)) - (_tkStructuredUAts structured) - subRefs = - concatMap - (\sub -> - _subkeyWithWireRefsRef sub : collectSigRefs (_subkeyWithWireRefsSignatures sub)) - (_tkStructuredSubkeys structured) - refIds = - _tkStructuredPrimaryKeyRef structured : - collectSigRefs (_tkStructuredDirectSignatures structured) ++ uidRefs ++ uatRefs ++ subRefs - mapM - (\refId -> - case lookupPacketRef structured refId of - Nothing -> - assertFailure - ("lookupPacketRef failed for ref id " ++ show refId) - Just pkt -> pure pkt) - refIds - -testCanonicalizeTKWithWireRepMatchesManualWireOrdering :: Assertion -testCanonicalizeTKWithWireRepMatchesManualWireOrdering = do - lbs <- readFixtureLazy "pubring.gpg" - let src = wireRepRef lbs - parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs) - case parsed of - (tk:_) -> - case toStructuredTKWithWireRep tk of - Left err -> - assertFailure ("toStructuredTKWithWireRep failed: " ++ err) - Right structured -> do - let shuffled = - structured - { _tkStructuredDirectSignatures = - reverse (_tkStructuredDirectSignatures structured) - , _tkStructuredUIDs = - reverse - (map - (\uid -> - uid - { _uidWithWireRefsSignatures = - reverse (_uidWithWireRefsSignatures uid) - }) - (_tkStructuredUIDs structured)) - , _tkStructuredUAts = - reverse - (map - (\uat -> - uat - { _uatWithWireRefsSignatures = - reverse (_uatWithWireRefsSignatures uat) - }) - (_tkStructuredUAts structured)) - , _tkStructuredSubkeys = - reverse - (map - (\sub -> - sub - { _subkeyWithWireRefsSignatures = - reverse (_subkeyWithWireRefsSignatures sub) - }) - (_tkStructuredSubkeys structured)) - } - expected <- - case manualCanonicalizeStructured shuffled of - Left err -> - assertFailure ("manual canonicalization failed: " ++ err) >> fail "manual canonicalization failed" - Right x -> pure x - got <- - case canonicalizeTKStructuredWithWireRep shuffled of - Left err -> - assertFailure ("canonicalizeTKStructuredWithWireRep failed: " ++ show err) >> - fail "canonicalizeTKStructuredWithWireRep failed" - Right x -> pure x - assertEqual - "canonicalizeTKStructuredWithWireRep matches manual wire-byte ordering" - expected - got - wrapped <- - case canonicalizeTKWithWireRep tk of - Left err -> - assertFailure ("canonicalizeTKWithWireRep failed: " ++ show err) >> - fail "canonicalizeTKWithWireRep failed" - Right x -> pure x - structuredCanonical <- - case canonicalizeTKStructuredWithWireRep structured of - Left err -> - assertFailure ("canonicalizeTKStructuredWithWireRep failed: " ++ show err) >> - fail "canonicalizeTKStructuredWithWireRep failed" - Right x -> pure x - assertEqual - "canonicalizeTKWithWireRep delegates to structured canonicalization" - structuredCanonical - wrapped - [] -> - assertFailure "pubring.gpg should parse to at least one provenance-aware TKUnknown" - where - manualCanonicalizeStructured :: TKStructuredWithWireRep -> Either String TKUnknown - manualCanonicalizeStructured structured = do - direct <- sortSigs (_tkStructuredDirectSignatures structured) - uids <- - sortByRef _uidWithWireRefsRef =<< - mapM - (\uid -> do - sigs <- sortSigs (_uidWithWireRefsSignatures uid) - Right (uid, sigs)) - (_tkStructuredUIDs structured) - uats <- - sortByRef _uatWithWireRefsRef =<< - mapM - (\uat -> do - sigs <- sortSigs (_uatWithWireRefsSignatures uat) - Right (uat, sigs)) - (_tkStructuredUAts structured) - subs <- - sortByRef _subkeyWithWireRefsRef =<< - mapM - (\sub -> do - sigs <- sortSigs (_subkeyWithWireRefsSignatures sub) - Right (sub, sigs)) - (_tkStructuredSubkeys structured) - Right $ - TKUnknown - { _tkuKey = _tkStructuredPrimaryKey structured - , _tkuRevs = map _signatureWithWireRefValue direct - , _tkuUIDs = - map - (\(uid, sigs) -> - (_uidWithWireRefsValue uid, map _signatureWithWireRefValue sigs)) - uids - , _tkuUAts = - map - (\(uat, sigs) -> - (_uatWithWireRefsValue uat, map _signatureWithWireRefValue sigs)) - uats - , _tkuSubs = - map - (\(sub, sigs) -> - (_subkeyWithWireRefsValue sub, map _signatureWithWireRefValue sigs)) - subs - } - where - wireBytes refId = - maybe - (Left ("lookupPacketRef failed for ref id " ++ show refId)) - (Right . _pktRaw) - (lookupPacketRef structured refId) - - sortSigs sigs = do - keyed <- - mapM - (\sig -> do - raw <- wireBytes (_signatureWithWireRefRef sig) - Right ((raw, _signatureWithWireRefRef sig), sig)) - sigs - Right (map snd (sortOn fst keyed)) - - sortByRef refAccessor items = do - keyed <- - mapM - (\(x, sigs) -> do - raw <- wireBytes (refAccessor x) - Right ((raw, refAccessor x), (x, sigs))) - items - Right (map snd (sortOn fst keyed)) - -testCanonicalizeTKWithWireRepReportsMissingRef :: Assertion -testCanonicalizeTKWithWireRepReportsMissingRef = do - lbs <- readFixtureLazy "pubring.gpg" - let src = wireRepRef lbs - parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs) - case parsed of - (tk:_) -> - case toStructuredTKWithWireRep tk of - Left err -> - assertFailure ("toStructuredTKWithWireRep failed: " ++ err) - Right structured -> do - let badRef = PacketRefId src 999999 - brokenWithBadRef = - case _tkStructuredDirectSignatures structured of - (sig:rest) -> - Just - structured - { _tkStructuredDirectSignatures = - sig {_signatureWithWireRefRef = badRef} : rest - } - [] -> - case _tkStructuredUIDs structured of - (uid:restUIDs) -> - Just - structured - { _tkStructuredUIDs = - uid {_uidWithWireRefsRef = badRef} : restUIDs - } - [] -> - case _tkStructuredUAts structured of - (uat:restUATs) -> - Just - structured - { _tkStructuredUAts = - uat {_uatWithWireRefsRef = badRef} : restUATs - } - [] -> - case _tkStructuredSubkeys structured of - (sub:restSubs) -> - Just - structured - { _tkStructuredSubkeys = - sub {_subkeyWithWireRefsRef = badRef} : restSubs - } - [] -> Nothing - case brokenWithBadRef of - Nothing -> - assertFailure - "pubring.gpg first TKUnknown unexpectedly has no direct signatures, UIDs, UATs, or subkeys" - Just broken -> - case canonicalizeTKStructuredWithWireRep broken of - Left (CanonicalizeMissingPacketRef ref) -> - assertEqual "missing ref error should include unresolved ref id" badRef ref - Left err -> - assertFailure ("Expected CanonicalizeMissingPacketRef, got " ++ show err) - Right _ -> - assertFailure "Expected canonicalization to fail on missing packet ref" - [] -> - assertFailure "pubring.gpg should parse to at least one provenance-aware TKUnknown" - -testWireRepRefTracksArmorProvenance :: Assertion -testWireRepRefTracksArmorProvenance = do - armored <- readFixtureLazy "v6-secret.pgp.aa" - case wireRepRefFromInput Nothing armored of - Left err -> assertFailure ("wireRepRefFromInput failed on armored input: " ++ err) - Right WireRepInput - { wireRepInputRef = src - , wireRepInputPayload = payload - } -> do - assertBool - "wireRepRefFromInput should mark ASCII-armored input as originally armored" - (_wireRepWasOriginallyArmored src) - assertBool - "dearmored payload should parse into packets" - (not (null (parsePktsWithWireRep src payload))) - -testDearmorRejectsMultipleBlocks :: Assertion -testDearmorRejectsMultipleBlocks = do - armored <- readFixtureLazy "v6-secret.pgp.aa" - case dearmorIfAsciiArmored (armored <> "\n" <> armored) of - Left err -> - assertBool - "multi-block rejection error should mention expected single block" - ("expected exactly one" `isInfixOf` err) - Right _ -> - assertFailure "dearmorIfAsciiArmored unexpectedly accepted multi-block armor input" - -testDearmorLenientAcceptsBomPrefixedArmor :: Assertion -testDearmorLenientAcceptsBomPrefixedArmor = do - armored <- readFixtureLazy "v6-secret.pgp.aa" - let bomPrefixed = BL.pack [0xef, 0xbb, 0xbf] <> armored - case dearmorIfAsciiArmored bomPrefixed of - Right (False, _) -> pure () - Right (True, _) -> - assertFailure - "strict dearmorIfAsciiArmored unexpectedly treated BOM-prefixed input as armored" - Left err -> - assertFailure ("strict dearmorIfAsciiArmored failed unexpectedly: " ++ err) - case dearmorIfAsciiArmoredLenient bomPrefixed of - Left err -> - assertFailure ("lenient dearmor should decode BOM-prefixed armor: " ++ err) - Right (wasArmored, payload) -> do - assertBool "lenient dearmor should report armored input" wasArmored - assertBool "lenient dearmor payload should parse as packets" (not (null (parsePkts payload))) - -testLooksLikeAsciiArmor :: Assertion -testLooksLikeAsciiArmor = do - let armoredPrefix = "\n\t -----BEGIN PGP MESSAGE-----\nYWJj\n" - partialPrefix = "-----BEGIN PG" - binaryPrefix = BL.pack [0x99, 0x01, 0x02, 0x03] - assertBool - "looksLikeAsciiArmor accepts canonical armored headers with leading whitespace" - (looksLikeAsciiArmor armoredPrefix) - assertBool - "looksLikeAsciiArmor rejects partial armored headers" - (not (looksLikeAsciiArmor partialPrefix)) - assertBool - "looksLikeAsciiArmor rejects binary packet prefixes" - (not (looksLikeAsciiArmor binaryPrefix)) - -testWireRepRefRejectsMalformedArmoredInput :: Assertion -testWireRepRefRejectsMalformedArmoredInput = do - let malformed = - "-----BEGIN PGP MESSAGE-----\n" <> - "not base64 and no checksum\n" <> - "-----END PGP MESSAGE-----\n" - case wireRepRefFromInput Nothing malformed of - Left _ -> pure () - Right _ -> - assertFailure - "wireRepRefFromInput unexpectedly accepted malformed ASCII-armored input" - -testTksFromWireRepMatchesAnySource :: Assertion -testTksFromWireRepMatchesAnySource = do - lbs <- readFixtureLazy "pubring.gpg" - let srcA = wireRepRef lbs - srcB = namedWireRepRef "synthetic-merge-source" lbs - parsed = parseTKsWithWireRep True (parsePktsWithWireRep srcA lbs) - case parsed of - (tk:_) -> do - let multiSourceTk = tk { _tkWireRepRefs = srcA :| [srcB] } - assertBool - "tksFromWireRep matches TKs whose source list contains the queried source" - (multiSourceTk `elem` tksFromWireRep srcA [multiSourceTk]) - assertBool - "tksFromWireRep can match secondary provenance sources" - (multiSourceTk `elem` tksFromWireRep srcB [multiSourceTk]) - [] -> - assertFailure "pubring.gpg should parse to at least one provenance-aware TKUnknown" - -testSemigroupTKWithWireRepPreservesStructuredRefs :: Assertion -testSemigroupTKWithWireRepPreservesStructuredRefs = do - lbs <- readFixtureLazy "pubring.gpg" - let srcA = wireRepRef lbs - srcB = namedWireRepRef "synthetic-merge-source" lbs - parsed = parseTKsWithWireRep True (parsePktsWithWireRep srcA lbs) - case parsed of - (tk:_) -> do - let remappedPackets = map (\pkt -> pkt { _pktWireRepRef = srcB }) (packetRefsOfTK tk) - tkFromSecondSource = - TKWithWireRep - (srcB :| []) - (spanByteRanges (map _pktRange remappedPackets)) - remappedPackets - (_tkValue tk) - merged = tk <> tkFromSecondSource - mergedRefIds = map packetRefIdOf (packetRefsOfTK merged) - assertEqual - "Semigroup preserves TKUnknown semantic merge behavior" - (_tkValue tk <> _tkValue tkFromSecondSource) - (_tkValue merged) - assertBool - "Semigroup merged provenance references include both sources" - (srcA `elem` wireRepsOfTK merged && srcB `elem` wireRepsOfTK merged) - assertEqual - "Semigroup result packet refs match merged TKUnknown packet sequence" - (flattenTK (_tkValue merged)) - (map _pktValue (packetRefsOfTK merged)) - assertEqual - "Semigroup result keeps packet refs unique by source-aware PacketRefId" - (length mergedRefIds) - (length (nub mergedRefIds)) - case toStructuredTKWithWireRep merged of - Left err -> - assertFailure ("toStructuredTKWithWireRep failed for Semigroup result: " ++ err) - Right structured -> do - resolved <- resolveStructuredPacketRefs structured - assertEqual - "Semigroup result structured refs resolve in packet order" - (map _pktValue (packetRefsOfTK merged)) - (map _pktValue resolved) - [] -> - assertFailure "pubring.gpg should parse to at least one provenance-aware TKUnknown" - -testKeyPktWrappersRoundTrip :: Assertion -testKeyPktWrappersRoundTrip = do - fixture <- loadV6UnencryptedSecretKeyFixtureForProperty - case fixture of - Left err -> - assertFailure err - Right (pkp, ska, _) -> do - let publicPrimaryPkt = PublicKeyPkt pkp - publicSubkeyPkt = PublicSubkeyPkt pkp - secretPrimaryPkt = SecretKeyPkt pkp ska - secretSubkeyPkt = SecretSubkeyPkt pkp ska - assertEqual - "mkPrimaryKeyPkt preserves public primary packets" - publicPrimaryPkt - (someKeyPktToPkt (mkPrimaryKeyPkt pkp Nothing)) - assertEqual - "mkPrimaryKeyPkt preserves secret primary packets" - secretPrimaryPkt - (someKeyPktToPkt (mkPrimaryKeyPkt pkp (Just ska))) - assertEqual - "mkSubkeyKeyPkt preserves public subkey packets" - publicSubkeyPkt - (someKeyPktToPkt (mkSubkeyKeyPkt pkp Nothing)) - assertEqual - "mkSubkeyKeyPkt preserves secret subkey packets" - secretSubkeyPkt - (someKeyPktToPkt (mkSubkeyKeyPkt pkp (Just ska))) - case pktToPublicKeyPkt publicPrimaryPkt of - Nothing -> - assertFailure "pktToPublicKeyPkt should accept PublicKeyPkt" - Just keyPkt -> do - assertEqual "public primary role is preserved" KeyPktPrimary (keyPktRole keyPkt) - assertEqual "public primary TKUnknown key view is preserved" (pkp, Nothing) (keyPktTKKey keyPkt) - assertEqual "public primary round-trips through KeyPkt" publicPrimaryPkt (keyPktToPkt keyPkt) - case pktToPublicKeyPkt publicSubkeyPkt of - Nothing -> - assertFailure "pktToPublicKeyPkt should accept PublicSubkeyPkt" - Just keyPkt -> - assertEqual "public subkey role is preserved" KeyPktSubkey (keyPktRole keyPkt) - case pktToSecretKeyPkt secretPrimaryPkt of - Nothing -> - assertFailure "pktToSecretKeyPkt should accept SecretKeyPkt" - Just keyPkt -> do - assertEqual "secret primary role is preserved" KeyPktPrimary (keyPktRole keyPkt) - assertEqual "secret primary TKUnknown key view is preserved" (pkp, Just ska) (keyPktTKKey keyPkt) - assertEqual "secret primary round-trips through KeyPkt" secretPrimaryPkt (keyPktToPkt keyPkt) - assertEqual - "secret primary public view downgrades to PublicKeyPkt" - publicPrimaryPkt - (keyPktToPkt (keyPktToPublicView keyPkt)) - case pktToSecretKeyPkt secretSubkeyPkt of - Nothing -> - assertFailure "pktToSecretKeyPkt should accept SecretSubkeyPkt" - Just keyPkt -> do - assertEqual "secret subkey role is preserved" KeyPktSubkey (keyPktRole keyPkt) - assertEqual - "secret subkey public view downgrades to PublicSubkeyPkt" - publicSubkeyPkt - (keyPktToPkt (keyPktToPublicView keyPkt)) - case pktToSomeKeyPktEither (UserIdPkt "not a key packet") of - Left (NotAKeyPacket pkt) -> - assertEqual "non-key coercion error reports the original packet" (UserIdPkt "not a key packet") pkt - other -> - assertFailure ("Expected NotAKeyPacket error, got " ++ show other) - -testTKTypedRoundTripAndPublicView :: Assertion -testTKTypedRoundTripAndPublicView = do - pubringBytes <- readFixtureLazy "pubring.gpg" - let publicParsed = parseUnknownTKs True (parsePkts pubringBytes) - publicTk <- - case publicParsed of - (tk:_) -> pure tk - [] -> assertFailure "pubring.gpg should parse to at least one TKUnknown" >> fail "unreachable" - publicTyped <- - case fromUnknownToTK publicTk of - Left err -> assertFailure ("fromUnknownToTK failed for public TKUnknown: " ++ err) >> fail "unreachable" - Right typed@(SomePublicTK _) -> pure typed - Right (SomeSecretTK _) -> - assertFailure "fromUnknownToTK should classify pubring primary key as public" >> fail "unreachable" - assertEqual - "public typed TKUnknown round-trips back to untyped TKUnknown" - publicTk - (someTKToUnknown publicTyped) - - armored <- readFixtureLazy "v6-secret.pgp.aa" - secretTk <- do - payload <- - case dearmorIfAsciiArmored armored of - Left err -> - assertFailure ("failed to decode v6-secret fixture: " ++ err) >> fail "unreachable" - Right (_, bs) -> pure bs - case parseUnknownTKs True (parsePkts payload) of - (tk:_) -> pure tk - [] -> assertFailure "v6-secret.pgp.aa should parse to at least one TKUnknown" >> fail "unreachable" - secretTyped <- - case fromUnknownToTK secretTk of - Left err -> assertFailure ("fromUnknownToTK failed for secret TKUnknown: " ++ err) >> fail "unreachable" - Right (SomeSecretTK typed) -> pure typed - Right (SomePublicTK _) -> - assertFailure "fromUnknownToTK should classify v6 secret primary key as secret" >> fail "unreachable" - let secretRoundTrip = tkToUnknown secretTyped - assertEqual - "secret typed TKUnknown round-trips back to untyped TKUnknown" - secretTk - secretRoundTrip - let projectedPublic = tkToUnknown (publicViewTK secretTyped) - expectedPublic = - secretTk - { _tkuKey = (\(pkp, _) -> (pkp, Nothing)) (_tkuKey secretTk) - , _tkuSubs = map (\(pkt, sigs) -> (publicKeyPacketOf pkt, sigs)) (_tkuSubs secretTk) - } - assertEqual - "publicViewTK drops secret material from primary/subkeys" - expectedPublic - projectedPublic - -flattenTK :: TKUnknown -> [Pkt] -flattenTK tk = - [someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)] ++ - map SignaturePkt (_tkuRevs tk) ++ concatMap flattenUID (_tkuUIDs tk) ++ - concatMap flattenUAt (_tkuUAts tk) ++ concatMap flattenSub (_tkuSubs tk) - where - (pkp, mska) = _tkuKey tk - flattenUID (uid, sigs) = UserIdPkt uid : map SignaturePkt sigs - flattenUAt (uat, sigs) = UserAttributePkt uat : map SignaturePkt sigs - flattenSub (pkt, sigs) = pkt : map SignaturePkt sigs - -testParseTKsDropsDisallowedPrimaryKeySigContextV4 :: Assertion -testParseTKsDropsDisallowedPrimaryKeySigContextV4 = do - let pkp = - PKPayload - V4 - (ThirtyTwoBitTimeStamp 0) - 0 - EdDSA - (EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01)))))) - invalidSig = SigV4 GenericCert RSA SHA512 [] [] 0 (MPI 0 :| []) - case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig] of - [tk] -> - assertEqual - "parseUnknownTKs True should drop GenericCert as a primary-key signature in v4" - [] - (_tkuRevs tk) - other -> - assertFailure ("Expected one TKUnknown when dropping invalid v4 signature context, got " ++ show other) - -testParseTKsDropsDisallowedPrimaryKeySigContextV6 :: Assertion -testParseTKsDropsDisallowedPrimaryKeySigContextV6 = do - let pkp = - PKPayload - V6 - (ThirtyTwoBitTimeStamp 0) - 0 - EdDSA - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint 1))) - invalidSig = - SigV6 - GenericCert - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x01)) - [] - [] - 0 - (MPI 0 :| []) - case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig] of - [tk] -> - assertEqual - "parseUnknownTKs True should drop GenericCert as a primary-key signature in v6" - [] - (_tkuRevs tk) - other -> - assertFailure ("Expected one TKUnknown when dropping invalid v6 signature context, got " ++ show other) - -testParseTKsAcceptsAllowedPrimaryKeySigContextV6 :: Assertion -testParseTKsAcceptsAllowedPrimaryKeySigContextV6 = do - let pkp = - PKPayload - V6 - (ThirtyTwoBitTimeStamp 0) - 0 - EdDSA - (EdDSAPubKey Ed25519 (NativeEPoint (EPoint 1))) - allowedSig = - SigV6 - KeyRevocationSig - EdDSA - SHA512 - (SignatureSalt (BL.replicate 32 0x02)) - [] - [] - 0 - (MPI 0 :| []) - case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt allowedSig] of - [tk] -> - assertBool - "parseUnknownTKs True should keep allowed v6 key-revocation signatures on primary keys" - (not (null (_tkuRevs tk))) - other -> - assertFailure - ("Expected one TKUnknown with a retained v6 revocation signature, got " ++ show other) +{-# LANGUAGE OverloadedStrings #-} + +module Tests.Utilities (utilityTests) where + +import Control.Error.Util (hush) +import Control.Monad (join) +import Crypto.Number.Serialize (os2ip) +import Data.Binary (get) +import Data.Binary.Get (Get) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Conduit as DC +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.Serialization.Binary (conduitGet) +import Data.Either (lefts, rights) +import Data.List (isInfixOf, nub, sortOn) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe (catMaybes) +import qualified Data.Set as Set +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit + ( Assertion + , assertBool + , assertEqual + , assertFailure + , testCase + ) + +import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) +import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev) +import Codec.Encryption.OpenPGP.KeyringParser + ( parsePublicTKs + , parseSecretTKs + , parseTKs + , parseTKsEither + , parseTKsWithWireRep + , parseUnknownTKs + ) +import Codec.Encryption.OpenPGP.Serialize + ( PktParseError (..) + , WireRepInput (..) + , conduitParsePktsWithWireRep + , dearmorIfAsciiArmored + , dearmorIfAsciiArmoredLenient + , looksLikeAsciiArmor + , parsePkts + , parsePktsEither + , parsePktsWithWireRep + , wireRepRefFromInput + ) +import Codec.Encryption.OpenPGP.Types +import Data.Conduit.OpenPGP.Keyring + ( AuthSecretSubkeyRejectionReason (..) + , AuthSecretSubkeyUID (..) + , AuthSecretSubkeysAtReport (..) + , authSecretSubkeyPrimaryUID + , authSecretSubkeyRejectedReason + , authSecretSubkeyUIDs + , authSecretSubkeyValue + , authSecretSubkeysAt + , authSecretSubkeysAtReport + , conduitDropErrorsAndNothings + , conduitToAuthSecretSubkeysAt + , conduitToAuthSecretSubkeysAtReport + , conduitToSomeTKsDroppingEither + , conduitToSomeTKsEither + , conduitToTKsEither + , conduitToTKsWithWireRepEither + ) +import Tests.Common + ( addTimestampSeconds + , loadAndDecompressPkts + , loadUnencryptedRsaSigner + , loadV6UnencryptedSecretKeyFixtureForProperty + , readFixtureLazy + , readFixturePackets + , runGet + , setKeyTimestamp + , signCertificationAt + , signSubkeyBindingWithRSAExtrasAt + , signSubkeyRevocationWithRSAAt + , timestampToUTCTime + ) + +utilityTests :: TestTree +utilityTests = + testGroup + "Utility function group" + [ testCase "pubring as packets" (testParsePktsUtil "pubring.gpg") + , testCase + "pubring parsePktsEither equals parsePkts on valid input" + (testParsePktsEitherUtil "pubring.gpg") + , testCase + "parsePktsEither reports truncation errors" + (testParsePktsEitherFailureUtil "pubring.gpg") + , testCase + "parseUnknownTKs drops disallowed primary-key signature context (v4)" + testParseTKsDropsDisallowedPrimaryKeySigContextV4 + , testCase + "parseUnknownTKs drops disallowed primary-key signature context (v6)" + testParseTKsDropsDisallowedPrimaryKeySigContextV6 + , testCase + "parseUnknownTKs accepts allowed primary-key signature context (v6)" + testParseTKsAcceptsAllowedPrimaryKeySigContextV6 + , testCase "pubring as TKs" (testParseTKsUtil "pubring.gpg") + , testCase + "pubring as typed TKs" + (testParseTKsTypedUtil "pubring.gpg") + , testCase + "pubring parseTKsEither preserves typed parse outcomes" + (testParseTKsEitherUtil "pubring.gpg") + , testCase + "typed TKUnknown conduit partitioning" + (testConduitToTKsTypedUtil "pubring.gpg") + , testCase + "typed TK conduit either reports values without silent drops on valid input" + (testConduitToSomeTKsEitherUtil "pubring.gpg") + , testCase + "typed TK dropping conduit either preserves valid typed results" + (testConduitToSomeTKsDroppingEitherUtil "pubring.gpg") + , testCase + "auth-capable secret-subkey conduit filters revoked/expired/auth flags" + testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth + , testCase + "auth-capable secret-subkey conduit tracks primary UID over time" + testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime + , testCase + "auth-capable secret-subkey report includes typed rejection reasons" + testAuthSecretSubkeysAtReportIncludesRejectionReasons + , testCase + "pkalgoAbbrev handles RFC9580-era pubkey algorithms" + testPKAlgoAbbrevRFC9580 + , testCase + "EightOctetKeyId Show/Read roundtrip uses hex form" + testEightOctetKeyIdReadShowRoundtrip + , testCase + "PktWithWireRep Ord uses raw bytes for tie-breakers" + testPktWithWireRepOrdUsesRawBytes + , testCase + "pubring as packets with provenance" + (testParsePktsWithWireRepUtil "pubring.gpg") + , testCase + "pubring as TKs with provenance" + (testParseTKsWithWireRepUtil "pubring.gpg") + , testCase + "wire provenance tracks original ASCII armor" + testWireRepRefTracksArmorProvenance + , testCase + "dearmorIfAsciiArmored rejects multi-block armored inputs" + testDearmorRejectsMultipleBlocks + , testCase + "dearmorIfAsciiArmoredLenient accepts BOM-prefixed armor" + testDearmorLenientAcceptsBomPrefixedArmor + , testCase + "looksLikeAsciiArmor centralizes armor prefix detection" + testLooksLikeAsciiArmor + , testCase + "wireRepRefFromInput surfaces malformed armored decode errors" + testWireRepRefRejectsMalformedArmoredInput + , testCase + "tksFromWireRep matches any source in TKUnknown provenance list" + testTksFromWireRepMatchesAnySource + , testCase + "TKWithWireRep Semigroup preserves structured provenance" + testSemigroupTKWithWireRepPreservesStructuredRefs + , testCase + "canonicalizeTKWithWireRep matches manual wire-byte ordering" + testCanonicalizeTKWithWireRepMatchesManualWireOrdering + , testCase + "canonicalizeTKWithWireRep reports missing packet refs" + testCanonicalizeTKWithWireRepReportsMissingRef + , testCase + "KeyPkt wrappers preserve packet kind/role round-trips" + testKeyPktWrappersRoundTrip + , testCase + "TK public/secret conversion and projection round-trip" + testTKTypedRoundTripAndPublicView + , testCase + "uat.gpg embeds expected image data from uat.jpg" + testUatImageFixture + ] + +testPKAlgoAbbrevRFC9580 :: Assertion +testPKAlgoAbbrevRFC9580 = do + assertEqual + "X25519 abbreviation" + "x25" + (pkalgoAbbrev (toFVal 25)) + assertEqual "X448 abbreviation" "x448" (pkalgoAbbrev (toFVal 26)) + assertEqual + "Ed25519 abbreviation" + "e25" + (pkalgoAbbrev (toFVal 27)) + assertEqual + "Ed448 abbreviation" + "e448" + (pkalgoAbbrev (toFVal 28)) + +testEightOctetKeyIdReadShowRoundtrip :: Assertion +testEightOctetKeyIdReadShowRoundtrip = do + let eoki = + EightOctetKeyId + (BL.pack [0x01, 0x23, 0x45, 0x67, 0x89, 0xab, 0xcd, 0xef]) + assertEqual + "show prints canonical uppercase hex" + "0123456789ABCDEF" + (show eoki) + assertEqual "read . show roundtrip" eoki (read (show eoki)) + +testUatImageFixture :: Assertion +testUatImageFixture = do + expectedImage <- readFixtureLazy "uat.jpg" + packets <- loadAndDecompressPkts "uat.gpg" + let images = + [ imageData + | UserAttributePkt uas <- packets + , ImageAttribute _ imageData <- uas + ] + assertBool + "uat.gpg should contain a user-attribute image packet" + (not (null images)) + assertBool + "uat.gpg should embed the uat.jpg payload" + (expectedImage `elem` images) + +testParsePktsUtil :: FilePath -> Assertion +testParsePktsUtil fn = do + cp <- readFixturePackets fn + pp <- parsePkts `fmap` readFixtureLazy fn + assertEqual + "parsePkts utility function gives same results as conduit pipeline" + cp + pp + +testParsePktsEitherUtil :: FilePath -> Assertion +testParsePktsEitherUtil fn = do + lbs <- readFixtureLazy fn + assertEqual + "parsePktsEither matches parsePkts on valid input" + (Right (parsePkts lbs)) + (parsePktsEither lbs) + +testParsePktsEitherFailureUtil :: FilePath -> Assertion +testParsePktsEitherFailureUtil fn = do + lbs <- readFixtureLazy fn + let truncated = BL.take (BL.length lbs - 1) lbs + case parsePktsEither truncated of + Left (PktParseError off msg) -> do + assertBool + "parsePktsEither reports non-empty parse error messages" + (not (null msg)) + assertBool + "parsePktsEither reports an in-range failure offset" + (off >= 0 && off <= BL.length truncated) + assertBool + "legacy parsePkts still returns a parsed prefix on malformed input" + (length (parsePkts truncated) <= length (parsePkts lbs)) + Right _ -> + assertFailure + "parsePktsEither should fail when input is truncated" + +testParseTKsUtil :: FilePath -> Assertion +testParseTKsUtil fn = do + lbs <- readFixtureLazy fn + cp <- + DC.runConduitRes $ + CB.sourceLbs lbs + DC..| conduitGet get + DC..| conduitToTKsEither + DC..| conduitDropErrorsAndNothings + DC..| CL.consume + let pt = parseUnknownTKs True . parsePkts $ lbs + assertEqual + "parsePkts utility function gives same results as conduit pipeline" + cp + pt + +testParseTKsTypedUtil :: FilePath -> Assertion +testParseTKsTypedUtil fn = do + lbs <- readFixtureLazy fn + let packets = parsePkts lbs + plain = parseUnknownTKs True packets + typed = parseTKs True packets + typedPublic = parsePublicTKs True packets + typedSecret = parseSecretTKs True packets + assertEqual + "parseTKs round-trips to the same untyped TKUnknown semantics" + plain + (map someTKToUnknown typed) + assertEqual + "public + secret typed partitions preserve full typed parse count" + (length typed) + (length typedPublic + length typedSecret) + +testParseTKsEitherUtil :: FilePath -> Assertion +testParseTKsEitherUtil fn = do + lbs <- readFixtureLazy fn + let packets = parsePkts lbs + typed = parseTKs True packets + typedEither = parseTKsEither True packets + assertEqual + "parseTKsEither right results should match parseTKs" + typed + (rights typedEither) + assertBool + "parseTKsEither should have no conversion failures for canonical pubring fixture" + (null (lefts typedEither)) + +testConduitToTKsTypedUtil :: FilePath -> Assertion +testConduitToTKsTypedUtil fn = do + lbs <- readFixtureLazy fn + allTyped <- + DC.runConduitRes $ + CB.sourceLbs lbs + DC..| conduitGet get + DC..| conduitToSomeTKsEither + DC..| CL.map (join . hush) + DC..| CL.catMaybes + DC..| CL.consume + publicTyped <- + DC.runConduitRes $ + CB.sourceLbs lbs + DC..| conduitGet get + DC..| conduitToSomeTKsEither + DC..| CL.map (join . hush) + DC..| CL.map (join . fmap someTKToPublicTK) + DC..| CL.catMaybes + DC..| CL.consume + secretTyped <- + DC.runConduitRes $ + CB.sourceLbs lbs + DC..| conduitGet get + DC..| conduitToSomeTKsEither + DC..| CL.map (join . hush) + DC..| CL.map (join . fmap someTKToSecretTK) + DC..| CL.catMaybes + DC..| CL.consume + assertEqual + "typed conduit round-trips to parseUnknownTKs semantics" + (parseUnknownTKs True (parsePkts lbs)) + (map someTKToUnknown allTyped) + assertEqual + "typed conduit public + secret partitions preserve full count" + (length allTyped) + (length publicTyped + length secretTyped) + +testConduitToSomeTKsEitherUtil :: FilePath -> Assertion +testConduitToSomeTKsEitherUtil fn = do + lbs <- readFixtureLazy fn + results <- + DC.runConduitRes $ + CB.sourceLbs lbs + DC..| conduitGet get + DC..| conduitToSomeTKsEither + DC..| CL.consume + let typedFromEither = catMaybes (rights results) + assertBool + "conduitToSomeTKsEither should not report failures for canonical pubring fixture" + (null (lefts results)) + assertEqual + "conduitToSomeTKsEither right values should match conduitToTKs semantics" + (parseTKs True (parsePkts lbs)) + typedFromEither + +testConduitToSomeTKsDroppingEitherUtil :: FilePath -> Assertion +testConduitToSomeTKsDroppingEitherUtil fn = do + lbs <- readFixtureLazy fn + results <- + DC.runConduitRes $ + CB.sourceLbs lbs + DC..| conduitGet get + DC..| conduitToSomeTKsDroppingEither + DC..| CL.consume + let typedFromEither = catMaybes (rights results) + assertBool + "conduitToSomeTKsDroppingEither should not report failures for canonical pubring fixture" + (null (lefts results)) + assertEqual + "conduitToSomeTKsDroppingEither right values should match tolerant parseTKs semantics" + (parseTKs False (parsePkts lbs)) + typedFromEither + +testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth + :: Assertion +testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let baseTime = _timestamp signer + beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 18) + afterTime = timestampToUTCTime (addTimestampSeconds baseTime 24) + uidText = "auth-subkeys@example.org" + uid = UserId uidText + secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 + authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer + expiringAuthSubkey = setKeyTimestamp (addTimestampSeconds baseTime 2) signer + signingOnlySubkey = setKeyTimestamp (addTimestampSeconds baseTime 3) signer + + uidCertification <- + signCertificationAt + signer + signingKey + uid + (addTimestampSeconds baseTime 8) + [SigSubPacket False (PrimaryUserId True)] + authBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + authSubkey + signingKey + (addTimestampSeconds baseTime 10) + [SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))] + expiringAuthBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + expiringAuthSubkey + signingKey + (addTimestampSeconds baseTime 10) + [ SigSubPacket False (KeyFlags (Set.fromList [AuthKey])) + , SigSubPacket False (KeyExpirationTime 20) + ] + signingOnlyBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + signingOnlySubkey + signingKey + (addTimestampSeconds baseTime 10) + [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] + authRevocation <- + signSubkeyRevocationWithRSAAt + signer + authSubkey + signingKey + (addTimestampSeconds baseTime 22) + + let tk = + TKUnknown + (signer, Just secretAddendum) + [] + [(uidText, [uidCertification])] + [] + [ + ( SecretSubkeyPkt authSubkey secretAddendum + , [authBinding, authRevocation] + ) + , + ( SecretSubkeyPkt expiringAuthSubkey secretAddendum + , [expiringAuthBinding] + ) + , + ( SecretSubkeyPkt signingOnlySubkey secretAddendum + , [signingOnlyBinding] + ) + ] + typedSecret <- + case fromUnknownToTK tk of + Right (SomeSecretTK typed) -> pure typed + Right (SomePublicTK _) -> + assertFailure + "expected secret typed TKUnknown for auth subkey test fixture" + >> fail "unreachable" + Left err -> + assertFailure + ("fromUnknownToTK failed for auth subkey test fixture: " ++ err) + >> fail "unreachable" + + selectedBefore <- + DC.runConduitRes $ + CL.sourceList [typedSecret] + DC..| conduitToAuthSecretSubkeysAt beforeTime + DC..| CL.consume + assertEqual + "pure authSecretSubkeysAt helper and conduit output should match" + (authSecretSubkeysAt beforeTime typedSecret) + selectedBefore + assertEqual + "before revocation/expiry, conduit should keep only auth-capable secret subkeys" + 2 + (length selectedBefore) + let selectedBeforeFps = + Set.fromList + ( map + (fingerprint . keyPktPKPayload . authSecretSubkeyValue) + selectedBefore + ) + assertEqual + "selected auth-capable subkeys should match expected fingerprints" + ( Set.fromList + [fingerprint authSubkey, fingerprint expiringAuthSubkey] + ) + selectedBeforeFps + mapM_ + ( \selection -> do + assertEqual + "selected auth subkey should retain active primary UID context" + (Just uidText) + (authSecretSubkeyPrimaryUID selection) + assertEqual + "selected auth subkey should expose UID context with primary marker" + [AuthSecretSubkeyUID uidText True] + (authSecretSubkeyUIDs selection) + ) + selectedBefore + + selectedAfter <- + DC.runConduitRes $ + CL.sourceList [typedSecret] + DC..| conduitToAuthSecretSubkeysAt afterTime + DC..| CL.consume + assertEqual + "after revocation/expiry, conduit should drop revoked/expired auth subkeys" + [] + selectedAfter + +testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime + :: Assertion +testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let baseTime = _timestamp signer + beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 15) + afterTime = timestampToUTCTime (addTimestampSeconds baseTime 25) + uidA = UserId "uid-a@example.org" + UserId uidAText = uidA + uidB = UserId "uid-b@example.org" + UserId uidBText = uidB + secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 + authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer + + uidACert <- + signCertificationAt + signer + signingKey + uidA + (addTimestampSeconds baseTime 10) + [SigSubPacket False (PrimaryUserId True)] + uidBCert <- + signCertificationAt + signer + signingKey + uidB + (addTimestampSeconds baseTime 20) + [SigSubPacket False (PrimaryUserId True)] + authBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + authSubkey + signingKey + (addTimestampSeconds baseTime 11) + [SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))] + + let tk = + TKUnknown + (signer, Just secretAddendum) + [] + [(uidAText, [uidACert]), (uidBText, [uidBCert])] + [] + [(SecretSubkeyPkt authSubkey secretAddendum, [authBinding])] + typedSecret <- + case fromUnknownToTK tk of + Right (SomeSecretTK typed) -> pure typed + Right (SomePublicTK _) -> + assertFailure + "expected secret typed TKUnknown for primary-uid test fixture" + >> fail "unreachable" + Left err -> + assertFailure + ("fromUnknownToTK failed for primary-uid test fixture: " ++ err) + >> fail "unreachable" + + beforeSelections <- + DC.runConduitRes $ + CL.sourceList [typedSecret] + DC..| conduitToAuthSecretSubkeysAt beforeTime + DC..| CL.consume + beforeSelection <- + case beforeSelections of + [selection] -> pure selection + other -> + assertFailure + ( "expected one auth-capable subkey selection before primary-uid rollover, got " + ++ show (length other) + ) + >> fail "unreachable" + assertEqual + "earlier primary UID should be selected before newer self-certification" + (Just uidAText) + (authSecretSubkeyPrimaryUID beforeSelection) + assertEqual + "UID context should include only active UIDs before uid-b certification exists" + [(uidAText, True)] + ( map + ( \u -> (authSecretSubkeyUIDValue u, authSecretSubkeyUIDIsPrimary u) + ) + (authSecretSubkeyUIDs beforeSelection) + ) + + afterSelections <- + DC.runConduitRes $ + CL.sourceList [typedSecret] + DC..| conduitToAuthSecretSubkeysAt afterTime + DC..| CL.consume + afterSelection <- + case afterSelections of + [selection] -> pure selection + other -> + assertFailure + ( "expected one auth-capable subkey selection after primary-uid rollover, got " + ++ show (length other) + ) + >> fail "unreachable" + assertEqual + "newer primary UID self-certification should win after rollover" + (Just uidBText) + (authSecretSubkeyPrimaryUID afterSelection) + assertEqual + "UID context should mark uid-b as primary after rollover" + [(uidAText, False), (uidBText, True)] + ( map + ( \u -> (authSecretSubkeyUIDValue u, authSecretSubkeyUIDIsPrimary u) + ) + (authSecretSubkeyUIDs afterSelection) + ) + +testAuthSecretSubkeysAtReportIncludesRejectionReasons + :: Assertion +testAuthSecretSubkeysAtReportIncludesRejectionReasons = do + (signer, signingKey) <- loadUnencryptedRsaSigner + let baseTime = _timestamp signer + beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 18) + afterTime = timestampToUTCTime (addTimestampSeconds baseTime 24) + uidText = "auth-subkeys@example.org" + uid = UserId uidText + secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 + authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer + expiringAuthSubkey = setKeyTimestamp (addTimestampSeconds baseTime 2) signer + signingOnlySubkey = setKeyTimestamp (addTimestampSeconds baseTime 3) signer + + uidCertification <- + signCertificationAt + signer + signingKey + uid + (addTimestampSeconds baseTime 8) + [SigSubPacket False (PrimaryUserId True)] + authBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + authSubkey + signingKey + (addTimestampSeconds baseTime 10) + [SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))] + expiringAuthBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + expiringAuthSubkey + signingKey + (addTimestampSeconds baseTime 10) + [ SigSubPacket False (KeyFlags (Set.fromList [AuthKey])) + , SigSubPacket False (KeyExpirationTime 20) + ] + signingOnlyBinding <- + signSubkeyBindingWithRSAExtrasAt + signer + signingOnlySubkey + signingKey + (addTimestampSeconds baseTime 10) + [SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))] + authRevocation <- + signSubkeyRevocationWithRSAAt + signer + authSubkey + signingKey + (addTimestampSeconds baseTime 22) + + let tk = + TKUnknown + (signer, Just secretAddendum) + [] + [(uidText, [uidCertification])] + [] + [ + ( SecretSubkeyPkt authSubkey secretAddendum + , [authBinding, authRevocation] + ) + , + ( SecretSubkeyPkt expiringAuthSubkey secretAddendum + , [expiringAuthBinding] + ) + , + ( SecretSubkeyPkt signingOnlySubkey secretAddendum + , [signingOnlyBinding] + ) + ] + typedSecret <- + case fromUnknownToTK tk of + Right (SomeSecretTK typed) -> pure typed + Right (SomePublicTK _) -> + assertFailure + "expected secret typed TKUnknown for auth subkey rejection test fixture" + >> fail "unreachable" + Left err -> + assertFailure + ( "fromUnknownToTK failed for auth subkey rejection test fixture: " + ++ err + ) + >> fail "unreachable" + + let beforeReport = authSecretSubkeysAtReport beforeTime typedSecret + assertEqual + "report accepted list should match authSecretSubkeysAt before revocation/expiry" + (authSecretSubkeysAt beforeTime typedSecret) + (authSecretSubkeysAccepted beforeReport) + assertEqual + "before revocation/expiry, only signing-only subkey should be rejected" + [AuthSecretSubkeyMissingAuthCapability] + ( map + authSecretSubkeyRejectedReason + (authSecretSubkeysRejected beforeReport) + ) + + afterReportsViaConduit <- + DC.runConduitRes $ + CL.sourceList [typedSecret] + DC..| conduitToAuthSecretSubkeysAtReport afterTime + DC..| CL.consume + afterReport <- + case afterReportsViaConduit of + [singleReport] -> pure singleReport + other -> + assertFailure + ( "expected one report from conduitToAuthSecretSubkeysAtReport, got " + ++ show (length other) + ) + >> fail "unreachable" + assertEqual + "after revocation/expiry, no accepted auth subkeys should remain" + [] + (authSecretSubkeysAccepted afterReport) + assertEqual + "after revocation/expiry, rejected reasons should report invalid-time and missing-auth cases for still-visible candidates" + [ AuthSecretSubkeySubkeyInvalidAtTime + , AuthSecretSubkeyMissingAuthCapability + ] + ( map + authSecretSubkeyRejectedReason + (authSecretSubkeysRejected afterReport) + ) + +testPktWithWireRepOrdUsesRawBytes :: Assertion +testPktWithWireRepOrdUsesRawBytes = do + let src = wireRepRef "src" + pktA = + PktWithWireRep + src + (ByteRange 0 1) + "a" + 0 + (OtherPacketPkt 42 "a") + pktB = + PktWithWireRep + src + (ByteRange 1 1) + "b" + 1 + (BrokenPacketPkt "broken" 42 "b") + assertEqual + "base packet ordering can tie on tag-only fallback" + EQ + (compare (_pktValue pktA) (_pktValue pktB)) + assertEqual + "PktWithWireRep ordering should break ties using packet bytes" + LT + (compare pktA pktB) + +testParsePktsWithWireRepUtil :: FilePath -> Assertion +testParsePktsWithWireRepUtil fn = do + let fpath = "tests/data/" ++ fn + lbs <- BL.readFile fpath + let WireRepInput + { wireRepInputRef = src + , wireRepInputPayload = srcBytes + } = + either + ( const + WireRepInput + { wireRepInputRef = wireRepRef lbs + , wireRepInputPayload = lbs + } + ) + id + (wireRepRefFromInput Nothing lbs) + parsed = parsePktsWithWireRep src srcBytes + chunkedInput = chunkStrict 7 (BL.toStrict lbs) + conduitParsed <- + DC.runConduitRes $ + CB.sourceLbs lbs + DC..| conduitParsePktsWithWireRep Nothing + DC..| CL.consume + conduitParsedChunked <- + DC.runConduitRes $ + CL.sourceList chunkedInput + DC..| conduitParsePktsWithWireRep Nothing + DC..| CL.consume + assertEqual + "provenance-aware parsePkts preserves packet semantics" + (parsePkts lbs) + (map _pktValue parsed) + assertEqual + "conduit and pure provenance-aware packet parsing agree" + parsed + conduitParsed + assertEqual + "conduit parser handles packets split across chunk boundaries" + parsed + conduitParsedChunked + assertEqual + "packetsFromWireRep returns all packets for the originating bytestream" + parsed + (packetsFromWireRep src parsed) + mapM_ (assertPktProvenance src srcBytes) parsed + where + chunkStrict n bs + | B.null bs = [] + | otherwise = + let (prefix, suffix) = B.splitAt n bs + in prefix : chunkStrict n suffix + +testParseTKsWithWireRepUtil :: FilePath -> Assertion +testParseTKsWithWireRepUtil fn = do + let fpath = "tests/data/" ++ fn + lbs <- BL.readFile fpath + let WireRepInput + { wireRepInputRef = src + , wireRepInputPayload = srcBytes + } = + either + ( const + WireRepInput + { wireRepInputRef = wireRepRef lbs + , wireRepInputPayload = lbs + } + ) + id + (wireRepRefFromInput Nothing lbs) + packets = parsePktsWithWireRep src srcBytes + parsed = parseTKsWithWireRep True packets + plain = parseUnknownTKs True (map _pktValue packets) + conduitParsed <- + DC.runConduitRes $ + CL.sourceList packets + DC..| conduitToTKsWithWireRepEither + DC..| CL.map (join . hush) + DC..| CL.catMaybes + DC..| CL.consume + assertEqual + "provenance-aware parseUnknownTKs preserves TKUnknown semantics" + plain + (map _tkValue parsed) + assertEqual + "conduit and pure provenance-aware TKUnknown parsing agree" + parsed + conduitParsed + assertEqual + "tksFromWireRep returns all TKs for the originating bytestream" + parsed + (tksFromWireRep src parsed) + mapM_ (assertTKProvenance src parsed) parsed + +assertPktProvenance + :: WireRepRef -> BL.ByteString -> PktWithWireRep -> Assertion +assertPktProvenance src srcBytes pkt = do + assertEqual + "packet raw bytes round-trip back to the same packet" + (Right (_pktValue pkt)) + (runGet (get :: Get Pkt) (_pktRaw pkt)) + assertEqual + "packet source reference is preserved" + src + (wireRepOfPkt pkt) + let ByteRange offset len = _pktRange pkt + assertEqual + "packet raw bytes match the source bytestream slice" + (_pktRaw pkt) + (BL.take len (BL.drop offset srcBytes)) + +assertTKProvenance + :: WireRepRef -> [TKWithWireRep] -> TKWithWireRep -> Assertion +assertTKProvenance src allTks tk = do + assertBool + "TKUnknown source reference list includes originating source" + (src `elem` _tkWireRepRefs tk) + assertEqual + "TKUnknown source reference is preserved" + src + (wireRepOfTK tk) + assertEqual + "TKUnknown packet references reconstruct the semantic TKUnknown packet sequence" + (flattenTK (_tkValue tk)) + (map _pktValue (packetRefsOfTK tk)) + assertEqual + "TKUnknown source span matches the span of its packet references" + (spanByteRanges (map _pktRange (packetRefsOfTK tk))) + (_tkWireRepRange tk) + mapM_ + ( \pkt -> + assertBool + "packet backlink resolves to containing TKUnknown" + (tk `elem` tksContainingPacket pkt allTks) + ) + (packetRefsOfTK tk) + case toStructuredTKWithWireRep tk of + Left err -> + assertFailure ("toStructuredTKWithWireRep failed: " ++ err) + Right structured -> do + assertEqual + "structured provenance retains semantic primary key" + (_tkuKey (_tkValue tk)) + (_tkStructuredPrimaryKey structured) + assertEqual + "structured provenance retains packet source reference list" + (_tkWireRepRefs tk) + (_tkStructuredWireRepRefs structured) + resolved <- resolveStructuredPacketRefs structured + assertEqual + "structured provenance resolves packet refs in TKUnknown packet order" + (map _pktValue (packetRefsOfTK tk)) + (map _pktValue resolved) + assertEqual + "structured provenance keeps stable packet ref ids" + (map packetRefIdOf (packetRefsOfTK tk)) + (map packetRefIdOf resolved) + +resolveStructuredPacketRefs + :: TKStructuredWithWireRep -> IO [PktWithWireRep] +resolveStructuredPacketRefs structured = do + let collectSigRefs = map _signatureWithWireRefRef + uidRefs = + concatMap + ( \uid -> + _uidWithWireRefsRef uid + : collectSigRefs (_uidWithWireRefsSignatures uid) + ) + (_tkStructuredUIDs structured) + uatRefs = + concatMap + ( \uat -> + _uatWithWireRefsRef uat + : collectSigRefs (_uatWithWireRefsSignatures uat) + ) + (_tkStructuredUAts structured) + subRefs = + concatMap + ( \sub -> + _subkeyWithWireRefsRef sub + : collectSigRefs (_subkeyWithWireRefsSignatures sub) + ) + (_tkStructuredSubkeys structured) + refIds = + _tkStructuredPrimaryKeyRef structured + : collectSigRefs (_tkStructuredDirectSignatures structured) + ++ uidRefs + ++ uatRefs + ++ subRefs + mapM + ( \refId -> + case lookupPacketRef structured refId of + Nothing -> + assertFailure + ("lookupPacketRef failed for ref id " ++ show refId) + Just pkt -> pure pkt + ) + refIds + +testCanonicalizeTKWithWireRepMatchesManualWireOrdering + :: Assertion +testCanonicalizeTKWithWireRepMatchesManualWireOrdering = do + lbs <- readFixtureLazy "pubring.gpg" + let src = wireRepRef lbs + parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs) + case parsed of + (tk : _) -> + case toStructuredTKWithWireRep tk of + Left err -> + assertFailure ("toStructuredTKWithWireRep failed: " ++ err) + Right structured -> do + let shuffled = + structured + { _tkStructuredDirectSignatures = + reverse (_tkStructuredDirectSignatures structured) + , _tkStructuredUIDs = + reverse + ( map + ( \uid -> + uid + { _uidWithWireRefsSignatures = + reverse (_uidWithWireRefsSignatures uid) + } + ) + (_tkStructuredUIDs structured) + ) + , _tkStructuredUAts = + reverse + ( map + ( \uat -> + uat + { _uatWithWireRefsSignatures = + reverse (_uatWithWireRefsSignatures uat) + } + ) + (_tkStructuredUAts structured) + ) + , _tkStructuredSubkeys = + reverse + ( map + ( \sub -> + sub + { _subkeyWithWireRefsSignatures = + reverse (_subkeyWithWireRefsSignatures sub) + } + ) + (_tkStructuredSubkeys structured) + ) + } + expected <- + case manualCanonicalizeStructured shuffled of + Left err -> + assertFailure ("manual canonicalization failed: " ++ err) + >> fail "manual canonicalization failed" + Right x -> pure x + got <- + case canonicalizeTKStructuredWithWireRep shuffled of + Left err -> + assertFailure + ("canonicalizeTKStructuredWithWireRep failed: " ++ show err) + >> fail "canonicalizeTKStructuredWithWireRep failed" + Right x -> pure x + assertEqual + "canonicalizeTKStructuredWithWireRep matches manual wire-byte ordering" + expected + got + wrapped <- + case canonicalizeTKWithWireRep tk of + Left err -> + assertFailure ("canonicalizeTKWithWireRep failed: " ++ show err) + >> fail "canonicalizeTKWithWireRep failed" + Right x -> pure x + structuredCanonical <- + case canonicalizeTKStructuredWithWireRep structured of + Left err -> + assertFailure + ("canonicalizeTKStructuredWithWireRep failed: " ++ show err) + >> fail "canonicalizeTKStructuredWithWireRep failed" + Right x -> pure x + assertEqual + "canonicalizeTKWithWireRep delegates to structured canonicalization" + structuredCanonical + wrapped + [] -> + assertFailure + "pubring.gpg should parse to at least one provenance-aware TKUnknown" + where + manualCanonicalizeStructured + :: TKStructuredWithWireRep -> Either String TKUnknown + manualCanonicalizeStructured structured = do + direct <- sortSigs (_tkStructuredDirectSignatures structured) + uids <- + sortByRef _uidWithWireRefsRef + =<< mapM + ( \uid -> do + sigs <- sortSigs (_uidWithWireRefsSignatures uid) + Right (uid, sigs) + ) + (_tkStructuredUIDs structured) + uats <- + sortByRef _uatWithWireRefsRef + =<< mapM + ( \uat -> do + sigs <- sortSigs (_uatWithWireRefsSignatures uat) + Right (uat, sigs) + ) + (_tkStructuredUAts structured) + subs <- + sortByRef _subkeyWithWireRefsRef + =<< mapM + ( \sub -> do + sigs <- sortSigs (_subkeyWithWireRefsSignatures sub) + Right (sub, sigs) + ) + (_tkStructuredSubkeys structured) + Right $ + TKUnknown + { _tkuKey = _tkStructuredPrimaryKey structured + , _tkuRevs = map _signatureWithWireRefValue direct + , _tkuUIDs = + map + ( \(uid, sigs) -> + (_uidWithWireRefsValue uid, map _signatureWithWireRefValue sigs) + ) + uids + , _tkuUAts = + map + ( \(uat, sigs) -> + (_uatWithWireRefsValue uat, map _signatureWithWireRefValue sigs) + ) + uats + , _tkuSubs = + map + ( \(sub, sigs) -> + ( _subkeyWithWireRefsValue sub + , map _signatureWithWireRefValue sigs + ) + ) + subs + } + where + wireBytes refId = + maybe + (Left ("lookupPacketRef failed for ref id " ++ show refId)) + (Right . _pktRaw) + (lookupPacketRef structured refId) + + sortSigs sigs = do + keyed <- + mapM + ( \sig -> do + raw <- wireBytes (_signatureWithWireRefRef sig) + Right ((raw, _signatureWithWireRefRef sig), sig) + ) + sigs + Right (map snd (sortOn fst keyed)) + + sortByRef refAccessor items = do + keyed <- + mapM + ( \(x, sigs) -> do + raw <- wireBytes (refAccessor x) + Right ((raw, refAccessor x), (x, sigs)) + ) + items + Right (map snd (sortOn fst keyed)) + +testCanonicalizeTKWithWireRepReportsMissingRef :: Assertion +testCanonicalizeTKWithWireRepReportsMissingRef = do + lbs <- readFixtureLazy "pubring.gpg" + let src = wireRepRef lbs + parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs) + case parsed of + (tk : _) -> + case toStructuredTKWithWireRep tk of + Left err -> + assertFailure ("toStructuredTKWithWireRep failed: " ++ err) + Right structured -> do + let badRef = PacketRefId src 999999 + brokenWithBadRef = + case _tkStructuredDirectSignatures structured of + (sig : rest) -> + Just + structured + { _tkStructuredDirectSignatures = + sig {_signatureWithWireRefRef = badRef} : rest + } + [] -> + case _tkStructuredUIDs structured of + (uid : restUIDs) -> + Just + structured + { _tkStructuredUIDs = + uid {_uidWithWireRefsRef = badRef} : restUIDs + } + [] -> + case _tkStructuredUAts structured of + (uat : restUATs) -> + Just + structured + { _tkStructuredUAts = + uat {_uatWithWireRefsRef = badRef} : restUATs + } + [] -> + case _tkStructuredSubkeys structured of + (sub : restSubs) -> + Just + structured + { _tkStructuredSubkeys = + sub {_subkeyWithWireRefsRef = badRef} : restSubs + } + [] -> Nothing + case brokenWithBadRef of + Nothing -> + assertFailure + "pubring.gpg first TKUnknown unexpectedly has no direct signatures, UIDs, UATs, or subkeys" + Just broken -> + case canonicalizeTKStructuredWithWireRep broken of + Left (CanonicalizeMissingPacketRef ref) -> + assertEqual + "missing ref error should include unresolved ref id" + badRef + ref + Left err -> + assertFailure + ("Expected CanonicalizeMissingPacketRef, got " ++ show err) + Right _ -> + assertFailure + "Expected canonicalization to fail on missing packet ref" + [] -> + assertFailure + "pubring.gpg should parse to at least one provenance-aware TKUnknown" + +testWireRepRefTracksArmorProvenance :: Assertion +testWireRepRefTracksArmorProvenance = do + armored <- readFixtureLazy "v6-secret.pgp.aa" + case wireRepRefFromInput Nothing armored of + Left err -> + assertFailure + ("wireRepRefFromInput failed on armored input: " ++ err) + Right + WireRepInput + { wireRepInputRef = src + , wireRepInputPayload = payload + } -> do + assertBool + "wireRepRefFromInput should mark ASCII-armored input as originally armored" + (_wireRepWasOriginallyArmored src) + assertBool + "dearmored payload should parse into packets" + (not (null (parsePktsWithWireRep src payload))) + +testDearmorRejectsMultipleBlocks :: Assertion +testDearmorRejectsMultipleBlocks = do + armored <- readFixtureLazy "v6-secret.pgp.aa" + case dearmorIfAsciiArmored (armored <> "\n" <> armored) of + Left err -> + assertBool + "multi-block rejection error should mention expected single block" + ("expected exactly one" `isInfixOf` err) + Right _ -> + assertFailure + "dearmorIfAsciiArmored unexpectedly accepted multi-block armor input" + +testDearmorLenientAcceptsBomPrefixedArmor :: Assertion +testDearmorLenientAcceptsBomPrefixedArmor = do + armored <- readFixtureLazy "v6-secret.pgp.aa" + let bomPrefixed = BL.pack [0xef, 0xbb, 0xbf] <> armored + case dearmorIfAsciiArmored bomPrefixed of + Right (False, _) -> pure () + Right (True, _) -> + assertFailure + "strict dearmorIfAsciiArmored unexpectedly treated BOM-prefixed input as armored" + Left err -> + assertFailure + ("strict dearmorIfAsciiArmored failed unexpectedly: " ++ err) + case dearmorIfAsciiArmoredLenient bomPrefixed of + Left err -> + assertFailure + ("lenient dearmor should decode BOM-prefixed armor: " ++ err) + Right (wasArmored, payload) -> do + assertBool + "lenient dearmor should report armored input" + wasArmored + assertBool + "lenient dearmor payload should parse as packets" + (not (null (parsePkts payload))) + +testLooksLikeAsciiArmor :: Assertion +testLooksLikeAsciiArmor = do + let armoredPrefix = "\n\t -----BEGIN PGP MESSAGE-----\nYWJj\n" + partialPrefix = "-----BEGIN PG" + binaryPrefix = BL.pack [0x99, 0x01, 0x02, 0x03] + assertBool + "looksLikeAsciiArmor accepts canonical armored headers with leading whitespace" + (looksLikeAsciiArmor armoredPrefix) + assertBool + "looksLikeAsciiArmor rejects partial armored headers" + (not (looksLikeAsciiArmor partialPrefix)) + assertBool + "looksLikeAsciiArmor rejects binary packet prefixes" + (not (looksLikeAsciiArmor binaryPrefix)) + +testWireRepRefRejectsMalformedArmoredInput :: Assertion +testWireRepRefRejectsMalformedArmoredInput = do + let malformed = + "-----BEGIN PGP MESSAGE-----\n" + <> "not base64 and no checksum\n" + <> "-----END PGP MESSAGE-----\n" + case wireRepRefFromInput Nothing malformed of + Left _ -> pure () + Right _ -> + assertFailure + "wireRepRefFromInput unexpectedly accepted malformed ASCII-armored input" + +testTksFromWireRepMatchesAnySource :: Assertion +testTksFromWireRepMatchesAnySource = do + lbs <- readFixtureLazy "pubring.gpg" + let srcA = wireRepRef lbs + srcB = namedWireRepRef "synthetic-merge-source" lbs + parsed = parseTKsWithWireRep True (parsePktsWithWireRep srcA lbs) + case parsed of + (tk : _) -> do + let multiSourceTk = tk {_tkWireRepRefs = srcA :| [srcB]} + assertBool + "tksFromWireRep matches TKs whose source list contains the queried source" + (multiSourceTk `elem` tksFromWireRep srcA [multiSourceTk]) + assertBool + "tksFromWireRep can match secondary provenance sources" + (multiSourceTk `elem` tksFromWireRep srcB [multiSourceTk]) + [] -> + assertFailure + "pubring.gpg should parse to at least one provenance-aware TKUnknown" + +testSemigroupTKWithWireRepPreservesStructuredRefs :: Assertion +testSemigroupTKWithWireRepPreservesStructuredRefs = do + lbs <- readFixtureLazy "pubring.gpg" + let srcA = wireRepRef lbs + srcB = namedWireRepRef "synthetic-merge-source" lbs + parsed = parseTKsWithWireRep True (parsePktsWithWireRep srcA lbs) + case parsed of + (tk : _) -> do + let remappedPackets = map (\pkt -> pkt {_pktWireRepRef = srcB}) (packetRefsOfTK tk) + tkFromSecondSource = + TKWithWireRep + (srcB :| []) + (spanByteRanges (map _pktRange remappedPackets)) + remappedPackets + (_tkValue tk) + merged = tk <> tkFromSecondSource + mergedRefIds = map packetRefIdOf (packetRefsOfTK merged) + assertEqual + "Semigroup preserves TKUnknown semantic merge behavior" + (_tkValue tk <> _tkValue tkFromSecondSource) + (_tkValue merged) + assertBool + "Semigroup merged provenance references include both sources" + ( srcA `elem` wireRepsOfTK merged + && srcB `elem` wireRepsOfTK merged + ) + assertEqual + "Semigroup result packet refs match merged TKUnknown packet sequence" + (flattenTK (_tkValue merged)) + (map _pktValue (packetRefsOfTK merged)) + assertEqual + "Semigroup result keeps packet refs unique by source-aware PacketRefId" + (length mergedRefIds) + (length (nub mergedRefIds)) + case toStructuredTKWithWireRep merged of + Left err -> + assertFailure + ("toStructuredTKWithWireRep failed for Semigroup result: " ++ err) + Right structured -> do + resolved <- resolveStructuredPacketRefs structured + assertEqual + "Semigroup result structured refs resolve in packet order" + (map _pktValue (packetRefsOfTK merged)) + (map _pktValue resolved) + [] -> + assertFailure + "pubring.gpg should parse to at least one provenance-aware TKUnknown" + +testKeyPktWrappersRoundTrip :: Assertion +testKeyPktWrappersRoundTrip = do + fixture <- loadV6UnencryptedSecretKeyFixtureForProperty + case fixture of + Left err -> + assertFailure err + Right (pkp, ska, _) -> do + let publicPrimaryPkt = PublicKeyPkt pkp + publicSubkeyPkt = PublicSubkeyPkt pkp + secretPrimaryPkt = SecretKeyPkt pkp ska + secretSubkeyPkt = SecretSubkeyPkt pkp ska + assertEqual + "mkPrimaryKeyPkt preserves public primary packets" + publicPrimaryPkt + (someKeyPktToPkt (mkPrimaryKeyPkt pkp Nothing)) + assertEqual + "mkPrimaryKeyPkt preserves secret primary packets" + secretPrimaryPkt + (someKeyPktToPkt (mkPrimaryKeyPkt pkp (Just ska))) + assertEqual + "mkSubkeyKeyPkt preserves public subkey packets" + publicSubkeyPkt + (someKeyPktToPkt (mkSubkeyKeyPkt pkp Nothing)) + assertEqual + "mkSubkeyKeyPkt preserves secret subkey packets" + secretSubkeyPkt + (someKeyPktToPkt (mkSubkeyKeyPkt pkp (Just ska))) + case pktToPublicKeyPkt publicPrimaryPkt of + Nothing -> + assertFailure "pktToPublicKeyPkt should accept PublicKeyPkt" + Just keyPkt -> do + assertEqual + "public primary role is preserved" + KeyPktPrimary + (keyPktRole keyPkt) + assertEqual + "public primary TKUnknown key view is preserved" + (pkp, Nothing) + (keyPktTKKey keyPkt) + assertEqual + "public primary round-trips through KeyPkt" + publicPrimaryPkt + (keyPktToPkt keyPkt) + case pktToPublicKeyPkt publicSubkeyPkt of + Nothing -> + assertFailure "pktToPublicKeyPkt should accept PublicSubkeyPkt" + Just keyPkt -> + assertEqual + "public subkey role is preserved" + KeyPktSubkey + (keyPktRole keyPkt) + case pktToSecretKeyPkt secretPrimaryPkt of + Nothing -> + assertFailure "pktToSecretKeyPkt should accept SecretKeyPkt" + Just keyPkt -> do + assertEqual + "secret primary role is preserved" + KeyPktPrimary + (keyPktRole keyPkt) + assertEqual + "secret primary TKUnknown key view is preserved" + (pkp, Just ska) + (keyPktTKKey keyPkt) + assertEqual + "secret primary round-trips through KeyPkt" + secretPrimaryPkt + (keyPktToPkt keyPkt) + assertEqual + "secret primary public view downgrades to PublicKeyPkt" + publicPrimaryPkt + (keyPktToPkt (keyPktToPublicView keyPkt)) + case pktToSecretKeyPkt secretSubkeyPkt of + Nothing -> + assertFailure "pktToSecretKeyPkt should accept SecretSubkeyPkt" + Just keyPkt -> do + assertEqual + "secret subkey role is preserved" + KeyPktSubkey + (keyPktRole keyPkt) + assertEqual + "secret subkey public view downgrades to PublicSubkeyPkt" + publicSubkeyPkt + (keyPktToPkt (keyPktToPublicView keyPkt)) + case pktToSomeKeyPktEither (UserIdPkt "not a key packet") of + Left (NotAKeyPacket pkt) -> + assertEqual + "non-key coercion error reports the original packet" + (UserIdPkt "not a key packet") + pkt + other -> + assertFailure + ("Expected NotAKeyPacket error, got " ++ show other) + +testTKTypedRoundTripAndPublicView :: Assertion +testTKTypedRoundTripAndPublicView = do + pubringBytes <- readFixtureLazy "pubring.gpg" + let publicParsed = parseUnknownTKs True (parsePkts pubringBytes) + publicTk <- + case publicParsed of + (tk : _) -> pure tk + [] -> + assertFailure + "pubring.gpg should parse to at least one TKUnknown" + >> fail "unreachable" + publicTyped <- + case fromUnknownToTK publicTk of + Left err -> + assertFailure + ("fromUnknownToTK failed for public TKUnknown: " ++ err) + >> fail "unreachable" + Right typed@(SomePublicTK _) -> pure typed + Right (SomeSecretTK _) -> + assertFailure + "fromUnknownToTK should classify pubring primary key as public" + >> fail "unreachable" + assertEqual + "public typed TKUnknown round-trips back to untyped TKUnknown" + publicTk + (someTKToUnknown publicTyped) + + armored <- readFixtureLazy "v6-secret.pgp.aa" + secretTk <- do + payload <- + case dearmorIfAsciiArmored armored of + Left err -> + assertFailure ("failed to decode v6-secret fixture: " ++ err) + >> fail "unreachable" + Right (_, bs) -> pure bs + case parseUnknownTKs True (parsePkts payload) of + (tk : _) -> pure tk + [] -> + assertFailure + "v6-secret.pgp.aa should parse to at least one TKUnknown" + >> fail "unreachable" + secretTyped <- + case fromUnknownToTK secretTk of + Left err -> + assertFailure + ("fromUnknownToTK failed for secret TKUnknown: " ++ err) + >> fail "unreachable" + Right (SomeSecretTK typed) -> pure typed + Right (SomePublicTK _) -> + assertFailure + "fromUnknownToTK should classify v6 secret primary key as secret" + >> fail "unreachable" + let secretRoundTrip = tkToUnknown secretTyped + assertEqual + "secret typed TKUnknown round-trips back to untyped TKUnknown" + secretTk + secretRoundTrip + let projectedPublic = tkToUnknown (publicViewTK secretTyped) + expectedPublic = + secretTk + { _tkuKey = (\(pkp, _) -> (pkp, Nothing)) (_tkuKey secretTk) + , _tkuSubs = + map + (\(pkt, sigs) -> (publicKeyPacketOf pkt, sigs)) + (_tkuSubs secretTk) + } + assertEqual + "publicViewTK drops secret material from primary/subkeys" + expectedPublic + projectedPublic + +flattenTK :: TKUnknown -> [Pkt] +flattenTK tk = + [someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)] + ++ map SignaturePkt (_tkuRevs tk) + ++ concatMap flattenUID (_tkuUIDs tk) + ++ concatMap flattenUAt (_tkuUAts tk) + ++ concatMap flattenSub (_tkuSubs tk) + where + (pkp, mska) = _tkuKey tk + flattenUID (uid, sigs) = UserIdPkt uid : map SignaturePkt sigs + flattenUAt (uat, sigs) = UserAttributePkt uat : map SignaturePkt sigs + flattenSub (pkt, sigs) = pkt : map SignaturePkt sigs + +testParseTKsDropsDisallowedPrimaryKeySigContextV4 :: Assertion +testParseTKsDropsDisallowedPrimaryKeySigContextV4 = do + let pkp = + PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + ( EdDSAPubKey + EdSigningCurve25519 + ( PrefixedNativeEPoint + (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01)))) + ) + ) + invalidSig = SigV4 GenericCert RSA SHA512 [] [] 0 (MPI 0 :| []) + case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig] of + [tk] -> + assertEqual + "parseUnknownTKs True should drop GenericCert as a primary-key signature in v4" + [] + (_tkuRevs tk) + other -> + assertFailure + ( "Expected one TKUnknown when dropping invalid v4 signature context, got " + ++ show other + ) + +testParseTKsDropsDisallowedPrimaryKeySigContextV6 :: Assertion +testParseTKsDropsDisallowedPrimaryKeySigContextV6 = do + let pkp = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1))) + invalidSig = + SigV6 + GenericCert + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x01)) + [] + [] + 0 + (MPI 0 :| []) + case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig] of + [tk] -> + assertEqual + "parseUnknownTKs True should drop GenericCert as a primary-key signature in v6" + [] + (_tkuRevs tk) + other -> + assertFailure + ( "Expected one TKUnknown when dropping invalid v6 signature context, got " + ++ show other + ) + +testParseTKsAcceptsAllowedPrimaryKeySigContextV6 :: Assertion +testParseTKsAcceptsAllowedPrimaryKeySigContextV6 = do + let pkp = + PKPayload + V6 + (ThirtyTwoBitTimeStamp 0) + 0 + EdDSA + (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1))) + allowedSig = + SigV6 + KeyRevocationSig + EdDSA + SHA512 + (SignatureSalt (BL.replicate 32 0x02)) + [] + [] + 0 + (MPI 0 :| []) + case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt allowedSig] of + [tk] -> + assertBool + "parseUnknownTKs True should keep allowed v6 key-revocation signatures on primary keys" + (not (null (_tkuRevs tk))) + other -> + assertFailure + ( "Expected one TKUnknown with a retained v6 revocation signature, got " + ++ show other + )