hOpenPGP-3.0.2.1/0000755000000000000000000000000007346545000011464 5ustar0000000000000000hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/0000755000000000000000000000000007346545000016103 5ustar0000000000000000hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Arbitrary.hs0000644000000000000000000002304107346545000020376 0ustar0000000000000000-- Arbitrary.hs: QuickCheck instances -- 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 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 ) import Test.QuickCheck.Instances () 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) 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) 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) 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) arbitrarySKESKv4S2K :: Gen S2K arbitrarySKESKv4S2K = 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) supportedSKESKHashAlgorithms :: [HashAlgorithm] supportedSKESKHashAlgorithms = [SHA1, SHA256, SHA384, SHA512] instance Arbitrary Signature where arbitrary = fmap Signature arbitrary instance Arbitrary UserId where 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 instance Arbitrary SigSubPacket where 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) -- instance Arbitrary PubKeyAlgorithm where arbitrary = elements [RSA, DSA, ECDH, ECDSA, DH, EdDSA] instance Arbitrary EightOctetKeyId where 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 ] instance Arbitrary MPI where 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 ] instance Arbitrary HashAlgorithm where 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 ] instance Arbitrary RevocationClass where 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)) instance Arbitrary CompressionAlgorithm where 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)) instance Arbitrary KeyFlag where arbitrary = elements [ GroupKey , AuthKey , SplitKey , EncryptStorageKey , EncryptCommunicationsKey , SignDataKey , CertifyKeysKey ] instance Arbitrary RevocationCode where 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])) instance Arbitrary ThirtyTwoBitTimeStamp where arbitrary = fmap ThirtyTwoBitTimeStamp arbitrary instance Arbitrary ThirtyTwoBitDuration where arbitrary = fmap ThirtyTwoBitDuration arbitrary instance Arbitrary NotationName where arbitrary = fmap NotationName arbitrary instance Arbitrary NotationValue where arbitrary = fmap NotationValue arbitrary hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/BlockCipher.hs0000644000000000000000000001126507346545000020631 0ustar0000000000000000-- BlockCipher.hs: OpenPGP (RFC9580) block cipher stuff -- Copyright © 2013-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE RankNTypes #-} module Codec.Encryption.OpenPGP.BlockCipher ( CipherError(..) , renderCipherError , keySize , withSymmetricCipher ) where import Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes (HOWrappedOldCCT(..)) import Codec.Encryption.OpenPGP.Internal.Crypton (HOWrappedCCT(..)) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types import qualified Crypto.Cipher.AES as AES import qualified Crypto.Cipher.Blowfish as Blowfish import qualified Crypto.Cipher.Camellia as Camellia import qualified Crypto.Cipher.TripleDES as TripleDES import qualified Crypto.Nettle.Ciphers as CNC import qualified Data.ByteString as B -- | Errors that can arise from block-cipher operations in this library. data CipherError = -- | The algorithm is not supported or not implemented. UnsupportedAlgorithm SymmetricAlgorithm | -- | Cipher initialization failed (bad key material). CipherInitFailed SymmetricAlgorithm String | -- | A CFB or other block-cipher operation failed. CipherOperationFailed String deriving (Eq, Show) renderCipherError :: CipherError -> String renderCipherError (UnsupportedAlgorithm sa) = "Unsupported symmetric algorithm: " ++ show sa renderCipherError (CipherInitFailed sa msg) = "Cipher initialization failed for " ++ show sa ++ ": " ++ msg renderCipherError (CipherOperationFailed msg) = "Cipher operation failed: " ++ msg type HOCipher a = forall cipher. HOBlockCipher cipher => cipher -> Either String a withSymmetricCipher :: SymmetricAlgorithm -> B.ByteString -> HOCipher a -> Either CipherError a withSymmetricCipher Plaintext _ _ = Left (UnsupportedAlgorithm Plaintext) withSymmetricCipher IDEA _ _ = Left (UnsupportedAlgorithm IDEA) withSymmetricCipher ReservedSAFER _ _ = Left (UnsupportedAlgorithm ReservedSAFER) withSymmetricCipher ReservedDES _ _ = Left (UnsupportedAlgorithm ReservedDES) withSymmetricCipher (OtherSA n) _ _ = Left (UnsupportedAlgorithm (OtherSA n)) withSymmetricCipher CAST5 keyBytes f = initAndRun CAST5 (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.CAST128)) f withSymmetricCipher Twofish keyBytes f = initAndRun Twofish (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.TWOFISH)) f withSymmetricCipher TripleDES keyBytes f = initAndRun TripleDES (cipherInit keyBytes :: Either String (HOWrappedCCT TripleDES.DES_EDE3)) f withSymmetricCipher Blowfish keyBytes f = initAndRun Blowfish (cipherInit keyBytes :: Either String (HOWrappedCCT Blowfish.Blowfish128)) f withSymmetricCipher AES128 keyBytes f = initAndRun AES128 (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES128)) f withSymmetricCipher AES192 keyBytes f = initAndRun AES192 (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES192)) f withSymmetricCipher AES256 keyBytes f = initAndRun AES256 (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES256)) f withSymmetricCipher Camellia128 keyBytes f = initAndRun Camellia128 (cipherInit keyBytes :: Either String (HOWrappedCCT Camellia.Camellia128)) f withSymmetricCipher Camellia192 keyBytes f = initAndRun Camellia192 (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.Camellia192)) f withSymmetricCipher Camellia256 keyBytes f = initAndRun Camellia256 (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.Camellia256)) f initAndRun :: HOBlockCipher cipher => SymmetricAlgorithm -> Either String cipher -> (cipher -> Either String a) -> Either CipherError a initAndRun algo initResult f = case initResult of Left err -> Left (CipherInitFailed algo err) Right c -> case f c of Left err -> Left (CipherOperationFailed err) Right x -> Right x -- In octets. Keep this as an explicit OpenPGP algorithm mapping so behavior -- stays stable across mixed backends (crypton/nettle) and includes unsupported -- algorithms that never reach backend cipher types. keySize :: SymmetricAlgorithm -> Either CipherError Int keySize Plaintext = Right 0 keySize IDEA = Right 16 keySize TripleDES = Right 24 keySize CAST5 = Right 16 keySize Blowfish = Right 16 keySize ReservedSAFER = Left (UnsupportedAlgorithm ReservedSAFER) keySize ReservedDES = Left (UnsupportedAlgorithm ReservedDES) keySize AES128 = Right 16 keySize AES192 = Right 24 keySize AES256 = Right 32 keySize Twofish = Right 32 keySize Camellia128 = Right 16 keySize Camellia192 = Right 24 keySize Camellia256 = Right 32 keySize (OtherSA n) = Left (UnsupportedAlgorithm (OtherSA n)) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/CFB.hs0000644000000000000000000001656207346545000017043 0ustar0000000000000000-- CFB.hs: OpenPGP (RFC9580) CFB mode -- Copyright © 2013-2026 Clint Adams -- Copyright © 2013 Daniel Kahn Gillmor -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} module Codec.Encryption.OpenPGP.CFB ( decrypt , decryptPreservingNonce , decryptNoNonce , decryptOpenPGPCfb , decryptOpenPGPCfbWithNonce , OpenPGPCFBMode(..) , OpenPGPCFBModeW(..) , encryptNoNonce , encryptOpenPGPCfbRaw , mdcTrailerForSEIPDv1 , seipdv1NonceFromIV , validateSEIPD1MDC , calculateMDC ) where import Codec.Encryption.OpenPGP.BlockCipher (CipherError(..), withSymmetricCipher) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types import qualified Crypto.Hash as CH import qualified Crypto.Hash.Algorithms as CHA import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Control.Monad (when) data OpenPGPCFBMode = OpenPGPCFBResync | OpenPGPCFBNoResync deriving (Eq, Show) data OpenPGPCFBModeW (mode :: OpenPGPCFBMode) where OpenPGPCFBResyncW :: OpenPGPCFBModeW 'OpenPGPCFBResync OpenPGPCFBNoResyncW :: OpenPGPCFBModeW 'OpenPGPCFBNoResync decryptOpenPGPCfb :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either CipherError B.ByteString decryptOpenPGPCfb sa ciphertext keydata = snd <$> decryptOpenPGPCfbWithNonce sa ciphertext keydata decryptOpenPGPCfbWithNonce :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either CipherError (B.ByteString, B.ByteString) decryptOpenPGPCfbWithNonce Plaintext ciphertext _ = return (mempty, ciphertext) decryptOpenPGPCfbWithNonce sa ciphertext keydata = withSymmetricCipher sa keydata $ \bc -> do nonce <- decrypt1 ciphertext bc cleartext <- decrypt2 ciphertext bc if nonceCheck bc nonce then return (nonce, cleartext) else Left "Session key quickcheck failed" where decrypt1 :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString decrypt1 ct cipher = paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) (B.take (blockSize cipher + 2) ct) decrypt2 :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString decrypt2 ct cipher = let i = B.take (blockSize cipher) (B.drop 2 ct) in paddedCfbDecrypt cipher i (B.drop (blockSize cipher + 2) ct) -- should deprecate this? decrypt :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either CipherError B.ByteString decrypt x y z = snd <$> (decryptPreservingNonce x y z) decryptPreservingNonce :: SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either CipherError (B.ByteString, B.ByteString) decryptPreservingNonce Plaintext ciphertext _ = return (mempty, ciphertext) decryptPreservingNonce sa ciphertext keydata = withSymmetricCipher sa keydata $ \bc -> do let bs = blockSize bc decrypted <- paddedCfbDecrypt bc (B.replicate bs 0) ciphertext let (nonce, cleartext) = B.splitAt (bs + 2) decrypted if nonceCheck bc nonce then return (nonce, cleartext) else Left "Session key quickcheck failed" decryptNoNonce :: SymmetricAlgorithm -> IV -> B.ByteString -> B.ByteString -> Either CipherError B.ByteString decryptNoNonce Plaintext _ ciphertext _ = return ciphertext decryptNoNonce sa iv ciphertext keydata = withSymmetricCipher sa keydata (decrypt' ciphertext) where decrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString decrypt' ct cipher = paddedCfbDecrypt cipher (unIV iv) ct nonceCheck :: HOBlockCipher cipher => cipher -> B.ByteString -> Bool nonceCheck bc = (==) <$> B.take 2 . B.drop (blockSize bc - 2) <*> B.drop (blockSize bc) encryptNoNonce :: SymmetricAlgorithm -> S2K -> IV -> B.ByteString -> B.ByteString -> Either CipherError B.ByteString encryptNoNonce Plaintext _ _ payload _ = return payload encryptNoNonce sa s2k iv payload keydata = withSymmetricCipher sa keydata (encrypt' payload) where encrypt' :: HOBlockCipher cipher => B.ByteString -> cipher -> Either String B.ByteString encrypt' ct cipher = paddedCfbEncrypt cipher (unIV iv) ct encryptOpenPGPCfbRaw :: OpenPGPCFBModeW mode -> SymmetricAlgorithm -> IV -> B.ByteString -- ^ plaintext (with MDC trailer already appended) -> B.ByteString -- ^ raw session key bytes -> Either CipherError B.ByteString encryptOpenPGPCfbRaw _ Plaintext _ cleartext _ = Right cleartext encryptOpenPGPCfbRaw mode sa iv cleartext keydata = withSymmetricCipher sa keydata $ \cipher -> do let initialVector = unIV iv bs = blockSize cipher if B.length initialVector /= bs then Left ("IV length mismatch for " ++ show sa ++ ": expected " ++ show bs ++ ", got " ++ show (B.length initialVector)) else do let prefix = initialVector <> B.drop (bs - 2) initialVector case mode of OpenPGPCFBResyncW -> do nonceAndCheck <- paddedCfbEncrypt cipher (B.replicate bs 0) prefix encryptedPayload <- paddedCfbEncrypt cipher (B.take bs (B.drop 2 nonceAndCheck)) cleartext return (nonceAndCheck <> encryptedPayload) OpenPGPCFBNoResyncW -> paddedCfbEncrypt cipher (B.replicate bs 0) (prefix <> cleartext) -- | Compute the MDC trailer appended to SEIPDv1 plaintext before encryption. -- The trailer is: @0xd3 0x14 SHA1(nonce || plaintext || 0xd3 0x14)@. mdcTrailerForSEIPDv1 :: IV -> B.ByteString -> B.ByteString mdcTrailerForSEIPDv1 iv plaintext = mdcHeader <> digest where mdcHeader = B.pack [0xd3, 0x14] nonce = seipdv1NonceFromIV iv digest = BA.convert (CH.hash (nonce <> plaintext <> mdcHeader) :: CH.Digest CHA.SHA1) -- | The SEIPDv1 nonce: the IV bytes followed by its last two bytes (resync prefix). seipdv1NonceFromIV :: IV -> B.ByteString seipdv1NonceFromIV (IV ivBytes) = ivBytes <> B.drop (B.length ivBytes - 2) ivBytes calculateMDC :: B.ByteString -> B.ByteString -> Maybe BL.ByteString calculateMDC nonce garbage | B.length garbage < 23 = Nothing | otherwise = let digest = CH.hash (nonce <> B.take (B.length garbage - 22) garbage <> B.pack [211, 20]) :: CH.Digest CHA.SHA1 in Just (BL.fromStrict (BA.convert digest :: B.ByteString)) -- | Verify the MDC trailer of a decrypted SEIPDv1 payload. -- Takes the CFB nonce (blockSize+2 prefix bytes retained from decryption) -- and the full decrypted bytes (payload + MDC packet), and returns the -- payload without the MDC trailer on success. validateSEIPD1MDC :: B.ByteString -> B.ByteString -> Either String B.ByteString validateSEIPD1MDC nonce decrypted = do when (B.length decrypted < 22) $ Left "SEIPD1 cleartext too short to contain MDC trailer" let (payload, trailer) = B.splitAt (B.length decrypted - 22) decrypted when (B.take 2 trailer /= B.pack [211, 20]) $ Left "SEIPD1 cleartext missing MDC packet trailer (tag 19)" expectedMdc <- case calculateMDC nonce decrypted of Nothing -> Left "SEIPD1 cleartext too short for MDC calculation" Just x -> Right x let actualMdc = BL.fromStrict (B.drop 2 trailer) when (expectedMdc /= actualMdc) $ Left "MDC indicates tampering" Right payload hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Compression.hs0000644000000000000000000001012107346545000020733 0ustar0000000000000000-- Compression.hs: OpenPGP (RFC9580) compression and decompression -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Compression ( CompressionError(..) , renderCompressionError , decompressPkt , compressPkts ) where import qualified Codec.Compression.BZip as BZip import qualified Codec.Compression.Zlib as Zlib import qualified Codec.Compression.Zlib.Raw as ZlibRaw import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types import Data.Binary (get, put) import Data.Binary.Get (runGetOrFail) import Data.Binary.Put (runPut) import qualified Data.ByteString.Lazy as BL -- | Errors that can arise during decompression of an OpenPGP Compressed Data -- packet. Note that corrupt stream exceptions from the underlying -- zlib\/bzip2 library are not captured here; they propagate as 'IOException' -- through the call stack. data CompressionError = -- | The compressed payload bytes are empty; nothing to decompress. EmptyCompressedPayload CompressionAlgorithm | -- | Decompression succeeded but the binary parse of the inner packet -- sequence failed. InnerPacketParseFailed CompressionAlgorithm String | -- | Decompression and parse succeeded but produced no packets at all -- (zero-length uncompressed payload). ZeroLengthDecompressedPayload CompressionAlgorithm | -- | The decompressed content contains only Marker packets (RFC4880 §5.8 -- marker packets carry no semantic content). MarkerOnlyPayload CompressionAlgorithm deriving (Eq, Show) renderCompressionError :: CompressionError -> String renderCompressionError (EmptyCompressedPayload algo) = "Compressed Data packet (" ++ show algo ++ "): empty compressed payload" renderCompressionError (InnerPacketParseFailed algo err) = "Compressed Data packet (" ++ show algo ++ "): inner packet parse failed: " ++ err renderCompressionError (ZeroLengthDecompressedPayload algo) = "Compressed Data packet (" ++ show algo ++ "): zero-length decompressed payload" renderCompressionError (MarkerOnlyPayload algo) = "Compressed Data packet (" ++ show algo ++ "): decompressed content contains only Marker packets" -- | Decompress an OpenPGP Compressed Data packet, classifying structural -- failures as 'CompressionError'. Non-Compressed-Data packets are returned -- unchanged in @Right [p]@. Corrupt compressed streams may still throw -- 'IOException' from the underlying decompression library. decompressPkt :: Pkt -> Either CompressionError [Pkt] decompressPkt compressed@(CompressedDataPkt (OtherCA _) _) = Right [compressed] decompressPkt (CompressedDataPkt algo bs) | BL.null bs = Left (EmptyCompressedPayload algo) | otherwise = case runGetOrFail get (dfunc algo bs) of Left (_, _, err) -> Left (InnerPacketParseFailed algo err) Right (_, _, packs) -> let pkts = unBlock packs in case pkts of [] -> Left (ZeroLengthDecompressedPayload algo) _ | all isMarkerPkt pkts -> Left (MarkerOnlyPayload algo) _ -> Right pkts where dfunc Uncompressed = id dfunc ZIP = ZlibRaw.decompress dfunc ZLIB = Zlib.decompress dfunc BZip2 = BZip.decompress dfunc (OtherCA _) = id decompressPkt p = Right [p] isMarkerPkt :: Pkt -> Bool isMarkerPkt (MarkerPkt _) = True isMarkerPkt _ = False compressPkts :: CompressionAlgorithm -> [Pkt] -> Pkt compressPkts ca packs = let bs = runPut $ put (Block packs) cbs = cfunc ca bs outAlgo = if isSupportedCompressionAlgorithm ca then ca else Uncompressed in CompressedDataPkt outAlgo cbs where cfunc Uncompressed = id cfunc ZIP = ZlibRaw.compress cfunc ZLIB = Zlib.compress cfunc BZip2 = BZip.compress cfunc _ = id isSupportedCompressionAlgorithm :: CompressionAlgorithm -> Bool isSupportedCompressionAlgorithm Uncompressed = True isSupportedCompressionAlgorithm ZIP = True isSupportedCompressionAlgorithm ZLIB = True isSupportedCompressionAlgorithm BZip2 = True isSupportedCompressionAlgorithm (OtherCA _) = False hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Encrypt.hs0000644000000000000000000027227007346545000020075 0ustar0000000000000000-- Encrypt.hs: OpenPGP (RFC9580) packet-level encryption helpers -- 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 hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Expirations.hs0000644000000000000000000003014307346545000020745 0ustar0000000000000000-- Expirations.hs: OpenPGP (RFC9580) expiration checking -- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE GADTs #-} module Codec.Encryption.OpenPGP.Expirations ( KeyState(..) , keyStateAt , effectiveKeyPreferencesAt , effectiveUIDPreferencesAt , effectiveKeyPreferencesAtTimestamp , effectiveUIDPreferencesAtTimestamp , isTKTimeValid , isPKTimeValidWithSelfSignatures , getKeyExpirationTimesFromSignature , isCertificationSig , signatureCreationTime , signatureExpirationTime , signatureExpirationDuration , firstSignatureExpirationDuration , signatureEffectiveAt , addDurationToTime , newestByCreationTime ) where import Control.Error.Util (hush) import Control.Lens ((&), (^.), _1) import Data.List (maximumBy) import Data.Maybe (listToMaybe, mapMaybe) import Data.Ord (comparing) import Data.Text (Text) import Data.Time.Clock (UTCTime, addUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Internal (issuer, issuerFP) import Codec.Encryption.OpenPGP.Ontology (isKET) import Codec.Encryption.OpenPGP.SignatureQualities ( sigCT , sigType , signatureHashedSubpacketsKnown ) import Codec.Encryption.OpenPGP.Types data KeyState = KeyState { keyStateValid :: Bool , keyStateSelfSignaturesKnown :: Bool , keyStateHasEffectiveSelfSignature :: Bool , keyStateExpirationTime :: Maybe UTCTime } deriving (Eq, Show) -- this assumes that all key expiration time subpackets are valid isTKTimeValid :: UTCTime -> TKUnknown -> Bool isTKTimeValid ct = keyStateValid . keyStateAt ct keyStateAt :: UTCTime -> TKUnknown -> KeyState keyStateAt ct tk = baseState {keyStateValid = keyStateValid baseState && bindingStateAllowsValidation} where baseState = keyStateFromSelfSignaturesAt ct (tk ^. tkuKey . _1) relevantSelfSignatures relevantSelfSignatures = filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkuRevs) ++ filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkuUIDs)) ++ filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkuUAts)) selfCertificationGroups = map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkuUIDs) ++ map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkuUAts) hasAnySelfCertification = any (any isCertificationSig) selfCertificationGroups hasAnyActiveSelfCertification = any (selfCertificationGroupActiveAt ct) selfCertificationGroups bindingStateAllowsValidation = not hasAnySelfCertification || hasAnyActiveSelfCertification primaryKey = tk ^. tkuKey . _1 effectiveKeyPreferencesAt :: UTCTime -> TKUnknown -> Maybe [SigSubPacketPayload] effectiveKeyPreferencesAt ct tk | not (keyStateValid (keyStateAt ct tk)) = Nothing | otherwise = do sig <- latestEffectivePreferenceCarrierAt ct tk let prefs = preferencePayloadsFromSignature sig if null prefs then Nothing else Just prefs effectiveUIDPreferencesAt :: UTCTime -> Text -> TKUnknown -> Maybe [SigSubPacketPayload] effectiveUIDPreferencesAt ct uid tk | not (keyStateValid (keyStateAt ct tk)) = Nothing | otherwise = do sigs <- lookup uid (tk ^. tkuUIDs) cert <- latestActiveSelfCertificationAt ct (filter (isSelfSignatureFor primaryKey) sigs) let prefs = preferencePayloadsFromSignature cert if null prefs then Nothing else Just prefs where primaryKey = tk ^. tkuKey . _1 effectiveKeyPreferencesAtTimestamp :: ThirtyTwoBitTimeStamp -> TKUnknown -> Maybe [SigSubPacketPayload] effectiveKeyPreferencesAtTimestamp ts = effectiveKeyPreferencesAt (posixSecondsToUTCTime (realToFrac (unThirtyTwoBitTimeStamp ts))) effectiveUIDPreferencesAtTimestamp :: ThirtyTwoBitTimeStamp -> Text -> TKUnknown -> Maybe [SigSubPacketPayload] effectiveUIDPreferencesAtTimestamp ts uid = effectiveUIDPreferencesAt (posixSecondsToUTCTime (realToFrac (unThirtyTwoBitTimeStamp ts))) uid isPKTimeValidWithSelfSignatures :: UTCTime -> SomePKPayload -> [SignaturePayload] -> Bool isPKTimeValidWithSelfSignatures ct pkp sigs = keyStateValid (keyStateFromSelfSignaturesAt ct pkp sigs) keyStateFromSelfSignaturesAt :: UTCTime -> SomePKPayload -> [SignaturePayload] -> KeyState keyStateFromSelfSignaturesAt ct pkp sigs = KeyState { keyStateValid = ct >= keyCreationTime && selfSignatureStateAllowsValidation && maybe True (ct <) keyExpirationTime , keyStateSelfSignaturesKnown = maybe False (const True) latestKnownSelfSignature , keyStateHasEffectiveSelfSignature = maybe False (signatureEffectiveAt ct) latestKnownSelfSignature , keyStateExpirationTime = keyExpirationTime } where keyCreationTime = _timestamp pkp & posixSecondsToUTCTime . realToFrac knownSelfSignatures = filter (signatureCreatedAtOrBefore ct) sigs selfSignatureStateAllowsValidation = maybe (null sigs) (signatureEffectiveAt ct) latestKnownSelfSignature latestKnownSelfSignature = snd <$> newestByCreationTime (mapMaybeSignatureCreationTime knownSelfSignatures) keyExpirationTime = effectiveKeyExpirationTime ct pkp sigs effectiveKeyExpirationTime :: UTCTime -> SomePKPayload -> [SignaturePayload] -> Maybe UTCTime effectiveKeyExpirationTime ct pkp sigs = signatureExpirationDurationToUTCTime pkp =<< latestKnownExpirationDuration ct sigs latestKnownExpirationDuration :: UTCTime -> [SignaturePayload] -> Maybe ThirtyTwoBitDuration latestKnownExpirationDuration ct sigs = latestKnownSelfSignatureExpirationDuration ct =<< (snd <$> newestByCreationTime (mapMaybeSignatureCreationTime (filter (signatureCreatedAtOrBefore ct) sigs))) latestKnownSelfSignatureExpirationDuration :: UTCTime -> SignaturePayload -> Maybe ThirtyTwoBitDuration latestKnownSelfSignatureExpirationDuration ct sig | signatureEffectiveAt ct sig = listToMaybe (getKeyExpirationTimesFromSignature sig) | otherwise = Nothing signatureEffectiveAt :: UTCTime -> SignaturePayload -> Bool signatureEffectiveAt ct sig = maybe False (<= ct) (signatureCreationTime sig) && maybe True (ct <) (signatureExpirationTime sig) signatureCreatedAtOrBefore :: UTCTime -> SignaturePayload -> Bool signatureCreatedAtOrBefore ct sig = maybe False (<= ct) (signatureCreationTime sig) signatureCreationTime :: SignaturePayload -> Maybe UTCTime signatureCreationTime = fmap (posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp) . sigCT signatureExpirationTime :: SignaturePayload -> Maybe UTCTime signatureExpirationTime sig = addDurationToTime <$> signatureCreationTime sig <*> signatureExpirationDuration sig signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration signatureExpirationDuration sig = signatureHashedSubpacketsKnown sig >>= firstSignatureExpirationDuration firstSignatureExpirationDuration :: [SigSubPacket] -> Maybe ThirtyTwoBitDuration firstSignatureExpirationDuration = foldr (\subpacket acc -> case subpacket of SigSubPacket _ (SigExpirationTime duration) -> Just duration _ -> acc) Nothing signatureExpirationDurationToUTCTime :: SomePKPayload -> ThirtyTwoBitDuration -> Maybe UTCTime signatureExpirationDurationToUTCTime _ (ThirtyTwoBitDuration 0) = Nothing signatureExpirationDurationToUTCTime pkp duration = Just $ addDurationToTime (_timestamp pkp & posixSecondsToUTCTime . realToFrac) duration addDurationToTime :: UTCTime -> ThirtyTwoBitDuration -> UTCTime addDurationToTime baseTime duration = addUTCTime (fromIntegral (unThirtyTwoBitDuration duration)) baseTime newestByCreationTime :: [(UTCTime, a)] -> Maybe (UTCTime, a) newestByCreationTime [] = Nothing newestByCreationTime xs = Just (maximumBy (comparing fst) xs) mapMaybeSignatureCreationTime :: [SignaturePayload] -> [(UTCTime, SignaturePayload)] mapMaybeSignatureCreationTime = foldr (\sig acc -> case signatureCreationTime sig of Just ct -> (ct, sig) : acc Nothing -> acc) [] selfCertificationGroupActiveAt :: UTCTime -> [SignaturePayload] -> Bool selfCertificationGroupActiveAt ct sigs = maybe False (const True) (latestActiveSelfCertificationAt ct sigs) latestActiveSelfCertificationAt :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload latestActiveSelfCertificationAt ct sigs = case latestKnownSelfCertification of Nothing -> Nothing Just certification -> if signatureEffectiveAt ct certification && not (any (\revocation -> revokesCertificationAt ct revocation certification) certRevocations) then Just certification else Nothing where latestKnownSelfCertification = snd <$> newestByCreationTime (mapMaybeSignatureCreationTime knownCertifications) knownCertifications = filter (\sig -> isCertificationSig sig && signatureCreatedAtOrBefore ct sig) sigs certRevocations = filter (\sig -> isCertRevocationForTime ct sig) sigs latestEffectivePreferenceCarrierAt :: UTCTime -> TKUnknown -> Maybe SignaturePayload latestEffectivePreferenceCarrierAt ct tk = snd <$> newestByCreationTime (mapMaybeSignatureCreationTime candidates) where primaryKey = tk ^. tkuKey . _1 directKeySigs = filter (\sig -> isDirectKeySelfSigFor primaryKey sig && signatureEffectiveAt ct sig) (tk ^. tkuRevs) uidSelfCerts = mapMaybe (latestActiveSelfCertificationAt ct . filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkuUIDs) uatSelfCerts = mapMaybe (latestActiveSelfCertificationAt ct . filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkuUAts) candidates = directKeySigs ++ uidSelfCerts ++ uatSelfCerts preferencePayloadsFromSignature :: SignaturePayload -> [SigSubPacketPayload] preferencePayloadsFromSignature = map (\(SigSubPacket _ payload) -> payload) . filter isPreferenceSubpacket . signatureHashedSubpackets signatureHashedSubpackets :: SignaturePayload -> [SigSubPacket] signatureHashedSubpackets sig = maybe [] id (signatureHashedSubpacketsKnown sig) isPreferenceSubpacket :: SigSubPacket -> Bool isPreferenceSubpacket (SigSubPacket _ (PreferredSymmetricAlgorithms _)) = True isPreferenceSubpacket (SigSubPacket _ (PreferredHashAlgorithms _)) = True isPreferenceSubpacket (SigSubPacket _ (PreferredCompressionAlgorithms _)) = True isPreferenceSubpacket (SigSubPacket _ (KeyServerPreferences _)) = True isPreferenceSubpacket (SigSubPacket _ (PreferredKeyServer _)) = True isPreferenceSubpacket (SigSubPacket _ (Features _)) = True isPreferenceSubpacket (SigSubPacket _ (OtherSigSub subpacketType _)) = subpacketType == 39 isPreferenceSubpacket _ = False revokesCertificationAt :: UTCTime -> SignaturePayload -> SignaturePayload -> Bool revokesCertificationAt ct revocation certification = signatureEffectiveAt ct revocation && case (signatureCreationTime certification, signatureCreationTime revocation) of (Just certificationTime, Just revocationTime) -> certificationTime < revocationTime _ -> False isCertRevocationForTime :: UTCTime -> SignaturePayload -> Bool isCertRevocationForTime ct sig = sigType sig == Just CertRevocationSig && signatureCreatedAtOrBefore ct sig isCertificationSig :: SignaturePayload -> Bool isCertificationSig sig = sigType sig `elem` [Just GenericCert, Just PersonaCert, Just CasualCert, Just PositiveCert] isDirectKeySelfSigFor :: SomePKPayload -> SignaturePayload -> Bool isDirectKeySelfSigFor pkp sig = sigType sig == Just SignatureDirectlyOnAKey && isSelfSignatureFor pkp sig isSelfCertificationFor :: SomePKPayload -> SignaturePayload -> Bool isSelfCertificationFor pkp sig = isCertificationSig sig && isSelfSignatureFor pkp sig isSelfSignatureFor :: SomePKPayload -> SignaturePayload -> Bool isSelfSignatureFor pkp sig = (((== fingerprint pkp) <$> issuerFP (SignaturePkt sig)) == Just True) || (((==) <$> issuer (SignaturePkt sig) <*> hush (eightOctetKeyID pkp)) == Just True) getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration] getKeyExpirationTimesFromSignature sig = map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ filter isKET (signatureHashedSubpackets sig) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Fingerprint.hs0000644000000000000000000000730507346545000020733 0ustar0000000000000000-- Fingerprint.hs: OpenPGP (RFC9580) fingerprinting methods -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} module Codec.Encryption.OpenPGP.Fingerprint ( eightOctetKeyID , fingerprint ) where import Crypto.Hash (Digest, hashlazy) import Crypto.Hash.Algorithms (MD5, SHA1, SHA256) import Crypto.Number.Serialize (i2osp) import qualified Crypto.PubKey.RSA as RSA 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 Codec.Encryption.OpenPGP.SerializeForSigs (putPKPforFingerprinting) import Codec.Encryption.OpenPGP.Types eightOctetKeyID :: SomePKPayload -> Either String EightOctetKeyId eightOctetKeyID pkp = case classifyFingerprintingKey pkp of FingerprintingV3RSA _ rp -> Right (v3RSAKeyId rp) FingerprintingV3NonRSA _ -> Left "Cannot calculate the key ID of a non-RSA V3 key" FingerprintingV4 pkpV4 -> Right (EightOctetKeyId (BL.drop 12 (unFingerprint (fingerprintV4 pkpV4)))) FingerprintingV6 pkpV6 -> Right (EightOctetKeyId (BL.take 8 (unFingerprint (fingerprintV6 pkpV6)))) fingerprint :: SomePKPayload -> Fingerprint fingerprint pkp = case classifyFingerprintingKey pkp of FingerprintingV3RSA pkpV3 _ -> fingerprintV3 pkpV3 FingerprintingV3NonRSA pkpV3 -> fingerprintV3 pkpV3 FingerprintingV4 pkpV4 -> fingerprintV4 pkpV4 FingerprintingV6 pkpV6 -> fingerprintV6 pkpV6 data FingerprintingKey where FingerprintingV3RSA :: PKPayload 'DeprecatedV3 -> RSA.PublicKey -> FingerprintingKey FingerprintingV3NonRSA :: PKPayload 'DeprecatedV3 -> FingerprintingKey FingerprintingV4 :: PKPayload 'V4 -> FingerprintingKey FingerprintingV6 :: PKPayload 'V6 -> FingerprintingKey classifyFingerprintingKey :: SomePKPayload -> FingerprintingKey classifyFingerprintingKey (SomePKPayload pkp@(PKPayloadV3 _ _ pka (RSAPubKey (RSA_PublicKey rp)))) | pka == RSA || pka == DeprecatedRSAEncryptOnly || pka == DeprecatedRSASignOnly = FingerprintingV3RSA pkp rp classifyFingerprintingKey (SomePKPayload pkp@PKPayloadV3 {}) = FingerprintingV3NonRSA pkp classifyFingerprintingKey (SomePKPayload pkp@PKPayloadV4 {}) = FingerprintingV4 pkp classifyFingerprintingKey (SomePKPayload pkp@PKPayloadV6 {}) = FingerprintingV6 pkp v3RSAKeyId :: RSA.PublicKey -> EightOctetKeyId v3RSAKeyId = EightOctetKeyId . BL.reverse . BL.take 8 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n fingerprintV3 :: PKPayload 'DeprecatedV3 -> Fingerprint fingerprintV3 = fingerprintFromDigestMD5 . serializeForFingerprinting fingerprintV4 :: PKPayload 'V4 -> Fingerprint fingerprintV4 = fingerprintFromDigestSHA1 . serializeForFingerprinting fingerprintV6 :: PKPayload 'V6 -> Fingerprint fingerprintV6 = fingerprintFromDigestSHA256 . serializeForFingerprinting serializeForFingerprinting :: PKPayload v -> BL.ByteString serializeForFingerprinting = runPut . putPKPforFingerprinting . PublicKeyPkt . SomePKPayload fingerprintFromDigestMD5 :: BL.ByteString -> Fingerprint fingerprintFromDigestMD5 serialized = let digest = hashlazy serialized :: Digest MD5 in Fingerprint (BL.fromStrict (BA.convert digest :: B.ByteString)) fingerprintFromDigestSHA1 :: BL.ByteString -> Fingerprint fingerprintFromDigestSHA1 serialized = let digest = hashlazy serialized :: Digest SHA1 in Fingerprint (BL.fromStrict (BA.convert digest :: B.ByteString)) fingerprintFromDigestSHA256 :: BL.ByteString -> Fingerprint fingerprintFromDigestSHA256 serialized = let digest = hashlazy serialized :: Digest SHA256 in Fingerprint (BL.fromStrict (BA.convert digest :: B.ByteString)) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Internal.hs0000644000000000000000000002042407346545000020215 0ustar0000000000000000-- Internal.hs: private utility functions and such -- 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 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) import qualified Data.ByteString.Lazy as BL import Data.List (find) import Data.Word (Word16, Word8) 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) where go :: Word8 -> Int -> Word8 go _ 0 = 7 go n b = if testBit n b then 7 - fromIntegral b else go n (b - 1) data PktStreamContext = PktStreamContext { lastLD :: Pkt , lastUIDorUAt :: Pkt , lastSig :: Pkt , lastPrimaryKey :: Pkt , lastSubkey :: Pkt } emptyPSC :: PktStreamContext emptyPSC = 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 issuer :: Pkt -> Maybe EightOctetKeyId issuer pkt = 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 data IssuerExtractionCase where 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 hashedSubpackets :: IssuerExtractionCase -> [SigSubPacket] hashedSubpackets (IssuerExtractionCaseV4 (SigPayloadV4Data _ _ _ hsubs _ _ _)) = hsubs hashedSubpackets (IssuerExtractionCaseV6 (SigPayloadV6Data _ _ _ _ hsubs _ _ _)) = hsubs unhashedSubpackets :: IssuerExtractionCase -> [SigSubPacket] unhashedSubpackets (IssuerExtractionCaseV4 (SigPayloadV4Data _ _ _ _ usubs _ _)) = usubs unhashedSubpackets (IssuerExtractionCaseV6 (SigPayloadV6Data _ _ _ _ _ usubs _ _)) = usubs issuerFingerprintVersion :: IssuerExtractionCase -> IssuerFingerprintVersion issuerFingerprintVersion IssuerExtractionCaseV4 {} = IssuerFingerprintV4 issuerFingerprintVersion IssuerExtractionCaseV6 {} = IssuerFingerprintV6 isIssuerFingerprintFor :: IssuerFingerprintVersion -> SigSubPacket -> Bool isIssuerFingerprintFor version (SigSubPacket _ (IssuerFingerprint packetVersion _)) = packetVersion == version isIssuerFingerprintFor _ _ = False issuerFingerprintFromSubpacket :: SigSubPacket -> Maybe Fingerprint issuerFingerprintFromSubpacket (SigSubPacket _ (IssuerFingerprint _ i)) = Just i issuerFingerprintFromSubpacket _ = Nothing issuerFromSubpacket :: SigSubPacket -> Maybe EightOctetKeyId issuerFromSubpacket (SigSubPacket _ (Issuer i)) = Just i issuerFromSubpacket _ = Nothing pubkeyToMPIs :: PKey -> [MPI] pubkeyToMPIs (RSAPubKey (RSA_PublicKey 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 ] 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 (EdDSAPubKey _ ep) _ _) = [MPI (edPointInteger ep)] pubkeyToMPIs (ECDSAPubKey ((ECDSA_PublicKey (ECDSA.PublicKey _ 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 _ 1 = 1 multiplicativeInverse q p = (n * q + 1) `div` p where n = p - multiplicativeInverse p (q `mod` p) 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), ")"] curveToCurveoidBS :: ECCCurve -> Either String B.ByteString curveToCurveoidBS NISTP256 = 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] 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]) where xb = i2osp x yb = i2osp y point2MBS ECCT.PointO = Nothing 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" 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), ")"] 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] curve2Curve :: ECCCurve -> ECCT.Curve curve2Curve NISTP256 = ECCT.getCurveByName ECCT.SEC_p256r1 curve2Curve NISTP384 = ECCT.getCurveByName ECCT.SEC_p384r1 curve2Curve NISTP521 = ECCT.getCurveByName ECCT.SEC_p521r1 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 hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Internal/0000755000000000000000000000000007346545000017657 5ustar0000000000000000hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Internal/CryptoAES.hs0000644000000000000000000000232507346545000022026 0ustar0000000000000000-- CryptoAES.hs: OpenPGP (RFC9580) AES helper utilities -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE PackageImports #-} {-# LANGUAGE RankNTypes #-} module Codec.Encryption.OpenPGP.Internal.CryptoAES ( withAESCipher ) where import Codec.Encryption.OpenPGP.Types import qualified "crypton" Crypto.Cipher.AES as AES import qualified "crypton" Crypto.Cipher.Types as CCT import qualified Crypto.Error as CE import Data.Bifunctor (first) import qualified Data.ByteString as B withAESCipher :: String -> SymmetricAlgorithm -> B.ByteString -> (forall cipher. CCT.BlockCipher cipher => cipher -> Either String a) -> Either String a withAESCipher unsupportedSymmetricError symalgo keyBytes f = case symalgo of AES128 -> first show (CE.eitherCryptoError (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES128)) >>= f AES192 -> first show (CE.eitherCryptoError (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES192)) >>= f AES256 -> first show (CE.eitherCryptoError (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES256)) >>= f _ -> Left unsupportedSymmetricError hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Internal/CryptoCipherTypes.hs0000644000000000000000000000407107346545000023655 0ustar0000000000000000-- CryptoCipherTypes.hs: shim for crypto-cipher-types stuff (current nettle) -- Copyright © 2016-2024 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE UndecidableInstances #-} module Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes ( HOWrappedOldCCT(..) ) where import Control.Error.Util (note) import qualified "crypto-cipher-types" Crypto.Cipher.Types as OldCCT import qualified "crypton" Crypto.Cipher.Types as CCT import qualified Data.ByteString as B import Codec.Encryption.OpenPGP.Internal.HOBlockCipher newtype HOWrappedOldCCT a = HWOCCT a instance OldCCT.BlockCipher cipher => HOBlockCipher (HOWrappedOldCCT cipher) where cipherInit = fmap HWOCCT . either (const (Left "nettle invalid key")) (Right . OldCCT.cipherInit) . OldCCT.makeKey cipherName (HWOCCT c) = OldCCT.cipherName c cipherKeySize (HWOCCT c) = convertKSS . OldCCT.cipherKeySize $ c blockSize (HWOCCT c) = OldCCT.blockSize c cfbEncrypt (HWOCCT c) iv bs = hammerIV iv >>= \i -> return (OldCCT.cfbEncrypt c i bs) cfbDecrypt (HWOCCT c) iv bs = hammerIV iv >>= \i -> return (OldCCT.cfbDecrypt c i bs) paddedCfbEncrypt _ _ _ = Left "padding for nettle-encryption not implemented yet" paddedCfbDecrypt (HWOCCT cipher) iv ciphertext = hammerIV iv >>= \i -> return (B.take (B.length ciphertext) (OldCCT.cfbDecrypt cipher i padded)) where padded = ciphertext `B.append` B.pack (replicate (OldCCT.blockSize cipher - (B.length ciphertext `mod` OldCCT.blockSize cipher)) 0) convertKSS :: OldCCT.KeySizeSpecifier -> CCT.KeySizeSpecifier convertKSS (OldCCT.KeySizeRange a b) = CCT.KeySizeRange a b convertKSS (OldCCT.KeySizeEnum as) = CCT.KeySizeEnum as convertKSS (OldCCT.KeySizeFixed a) = CCT.KeySizeFixed a hammerIV :: OldCCT.BlockCipher cipher => B.ByteString -> Either String (OldCCT.IV cipher) hammerIV = note "nettle bad IV" . OldCCT.makeIV hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs0000644000000000000000000000475307346545000022130 0ustar0000000000000000-- CryptoECDH.hs: OpenPGP (RFC9580) ECDH helper utilities -- 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 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 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)) 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 where 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" 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) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Internal/CryptoSEIPDv2.hs0000644000000000000000000001126007346545000022530 0ustar0000000000000000-- CryptoSEIPDv2.hs: OpenPGP (RFC9580) SEIPD-v2 and SKESK-v6 crypto helpers -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeApplications #-} module Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 ( aeadModeAndNonceSizeForSEIPDv2 , seipdv2SymmetricKeySize , deriveSKESK6KEK , encryptSKESK6SessionKey , decryptSKESK6SessionKey ) where import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher) import Codec.Encryption.OpenPGP.Internal.RFC7253OCB ( decryptWithOCBRFC7253With , encryptWithOCBRFC7253 ) import Codec.Encryption.OpenPGP.Types import qualified "crypton" Crypto.Cipher.Types as CCT import qualified Crypto.Error as CE import qualified Crypto.Hash.Algorithms as CHA import Crypto.KDF.HKDF (expand, extract) import Data.Bifunctor (first) import qualified Data.ByteArray as BA import qualified Data.ByteString as B aeadModeAndNonceSizeForSEIPDv2 :: String -> AEADAlgorithm -> Either String (CCT.AEADMode, Int) aeadModeAndNonceSizeForSEIPDv2 otherAeadError EAX = Left "EAX is currently unsupported by the crypton AEAD backend" aeadModeAndNonceSizeForSEIPDv2 otherAeadError OCB = Right (CCT.AEAD_OCB, 15) aeadModeAndNonceSizeForSEIPDv2 otherAeadError GCM = Right (CCT.AEAD_GCM, 12) aeadModeAndNonceSizeForSEIPDv2 otherAeadError (OtherAEADAlgo _) = Left otherAeadError seipdv2SymmetricKeySize :: String -> SymmetricAlgorithm -> Either String Int seipdv2SymmetricKeySize unsupportedSymmetricError symalgo = case symalgo of AES128 -> Right 16 AES192 -> Right 24 AES256 -> Right 32 _ -> Left unsupportedSymmetricError skeskV6Info :: SymmetricAlgorithm -> AEADAlgorithm -> B.ByteString skeskV6Info symalgo aead = B.pack [0xc3, 6, fromFVal symalgo, fromFVal aead] deriveSKESK6KEK :: SymmetricAlgorithm -> AEADAlgorithm -> B.ByteString -> Either String B.ByteString deriveSKESK6KEK symalgo aead ikm = do keyLen <- seipdv2SymmetricKeySize "SKESK v6 currently supports AES-128/192/256 only" symalgo let prk = extract @CHA.SHA256 B.empty ikm pure (expand @CHA.SHA256 prk (skeskV6Info symalgo aead) keyLen) encryptSKESK6SessionKey :: SymmetricAlgorithm -> AEADAlgorithm -> B.ByteString -> B.ByteString -> B.ByteString -> Either String (B.ByteString, B.ByteString) encryptSKESK6SessionKey symalgo aead kek iv sessionKey = do (mode, nonceSize) <- aeadModeAndNonceSizeForSEIPDv2 "unsupported AEAD algorithm for SKESK v6 encrypt" aead if B.length iv /= nonceSize then Left "SKESK v6 IV length does not match AEAD algorithm" else withAESCipher "SKESK v6 encrypt currently supports AES-128/192/256 only" symalgo kek (\cipher -> if mode == CCT.AEAD_OCB then do (tag, ciphertext) <- encryptWithOCBRFC7253 cipher iv (skeskV6Info symalgo aead) sessionKey pure (ciphertext, authTagToBS tag) else do aeadCtx <- first show . CE.eitherCryptoError $ CCT.aeadInit mode cipher iv let (tag, ciphertext) = CCT.aeadSimpleEncrypt aeadCtx (skeskV6Info symalgo aead) sessionKey 16 pure (ciphertext, authTagToBS tag)) decryptSKESK6SessionKey :: SymmetricAlgorithm -> AEADAlgorithm -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> Either String B.ByteString decryptSKESK6SessionKey symalgo aead kek iv ciphertext tag = do (mode, nonceSize) <- aeadModeAndNonceSizeForSEIPDv2 "unsupported AEAD algorithm for SKESK v6 decrypt" aead if B.length iv /= nonceSize then Left "SKESK v6 IV length does not match AEAD algorithm" else withAESCipher "SKESK v6 decrypt currently supports AES-128/192/256 only" symalgo kek (\cipher -> if mode == CCT.AEAD_OCB then decryptWithOCBRFC7253With (\_ _ _ _ _ _ -> "SKESK v6 authentication failed") cipher iv (skeskV6Info symalgo aead) ciphertext (mkAuthTag tag) else do aeadCtx <- first show . CE.eitherCryptoError $ CCT.aeadInit mode cipher iv case CCT.aeadSimpleDecrypt aeadCtx (skeskV6Info symalgo aead) ciphertext (mkAuthTag tag) of Nothing -> Left "SKESK v6 authentication failed" Just plain -> Right plain) authTagToBS :: CCT.AuthTag -> B.ByteString authTagToBS = BA.convert . CCT.unAuthTag mkAuthTag :: B.ByteString -> CCT.AuthTag mkAuthTag = CCT.AuthTag . BA.convert hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Internal/Crypton.hs0000644000000000000000000000235607346545000021657 0ustar0000000000000000-- Crypton.hs: shim for crypton -- Copyright © 2016-2024 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE UndecidableInstances #-} module Codec.Encryption.OpenPGP.Internal.Crypton ( HOWrappedCCT(..) ) where import Control.Error.Util (note) import qualified "crypton" Crypto.Cipher.Types as CCT import qualified Crypto.Error as CE import Data.Bifunctor (bimap) import qualified Data.ByteString as B import Codec.Encryption.OpenPGP.Internal.HOBlockCipher newtype HOWrappedCCT a = HWCCT a instance CCT.BlockCipher cipher => HOBlockCipher (HOWrappedCCT cipher) where cipherInit = bimap show HWCCT . CE.eitherCryptoError . CCT.cipherInit cipherName (HWCCT c) = CCT.cipherName c cipherKeySize (HWCCT c) = CCT.cipherKeySize c blockSize (HWCCT c) = CCT.blockSize c cfbEncrypt (HWCCT c) iv bs = hammerIV iv >>= \i -> return (CCT.cfbEncrypt c i bs) cfbDecrypt (HWCCT c) iv bs = hammerIV iv >>= \i -> return (CCT.cfbDecrypt c i bs) hammerIV :: CCT.BlockCipher cipher => B.ByteString -> Either String (CCT.IV cipher) hammerIV = note "crypton bad IV" . CCT.makeIV hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Internal/HOBlockCipher.hs0000644000000000000000000000210007346545000022620 0ustar0000000000000000-- HOBlockCipher.hs: abstraction for the different BlockCipher classes, plus crazy CFB mode stuff -- Copyright © 2016-2024 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE PackageImports #-} module Codec.Encryption.OpenPGP.Internal.HOBlockCipher ( HOBlockCipher(..) ) where import qualified "crypton" Crypto.Cipher.Types as CCT import qualified Data.ByteString as B class HOBlockCipher cipher where cipherInit :: B.ByteString -> Either String cipher cipherName :: cipher -> String cipherKeySize :: cipher -> CCT.KeySizeSpecifier blockSize :: cipher -> Int cfbEncrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString cfbDecrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString paddedCfbEncrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString paddedCfbEncrypt = cfbEncrypt paddedCfbDecrypt :: cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString paddedCfbDecrypt = cfbDecrypt hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs0000644000000000000000000001777507346545000021513 0ustar0000000000000000-- RFC7253OCB.hs: RFC7253 implementation as a -- workaround until crypton is fixed -- Copyright © 2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE PackageImports #-} module Codec.Encryption.OpenPGP.Internal.RFC7253OCB ( encryptWithOCBRFC7253 , decryptWithOCBRFC7253 , decryptWithOCBRFC7253With ) where import Control.Monad (when) import qualified "crypton" Crypto.Cipher.Types as CCT import Data.Bits ((.&.), (.|.), shiftL, shiftR, xor) import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.List (foldl') import Crypto.Number.Serialize (i2osp, os2ip) import Data.Word (Word8) encryptWithOCBRFC7253 :: CCT.BlockCipher c => c -> B.ByteString -> B.ByteString -> B.ByteString -> Either String (CCT.AuthTag, B.ByteString) encryptWithOCBRFC7253 cipher nonce ad plaintext = do when (B.length nonce > 15 || B.null nonce) $ Left "invalid nonce size for OCB" offset0 <- ocbOffset0 cipher nonce let zeroBlock = B.replicate 16 0 lStar = CCT.ecbEncrypt cipher zeroBlock lDollar = ocbDouble lStar lCache = iterate ocbDouble (ocbDouble lDollar) hashAd = ocbHash cipher lStar lCache ad (fullBlocks, partial) = splitFullAndPartial plaintext (cipherBlocks, offsetM, checksum) = foldl' (\(accBlocks, offsetPrev, checksumPrev) (idx, pBlock) -> let offsetI = xorBS offsetPrev (lCache !! ntz idx) cipherI = xorBS offsetI (CCT.ecbEncrypt cipher (xorBS offsetI pBlock)) checksumI = xorBS checksumPrev pBlock in (accBlocks ++ [cipherI], offsetI, checksumI)) ([], offset0, zeroBlock) (zip [1 ..] fullBlocks) (cipherLast, offsetLast, checksumLast) = if B.null partial then (B.empty, offsetM, checksum) else let offsetStar = xorBS offsetM lStar pad = CCT.ecbEncrypt cipher offsetStar cipherPartial = xorBS partial (B.take (B.length partial) pad) checksum' = xorBS checksum (ocbPadPartial partial) in (cipherPartial, offsetStar, checksum') tagBytes = xorBS (CCT.ecbEncrypt cipher (xorBS (xorBS checksumLast offsetLast) lDollar)) hashAd ciphertext = B.concat cipherBlocks <> cipherLast in Right (mkAuthTag (B.take 16 tagBytes), ciphertext) decryptWithOCBRFC7253 :: CCT.BlockCipher c => c -> B.ByteString -> B.ByteString -> B.ByteString -> CCT.AuthTag -> Either String B.ByteString decryptWithOCBRFC7253 = decryptWithOCBRFC7253With (\_ _ _ _ _ _ -> "OCB authentication failed") decryptWithOCBRFC7253With :: CCT.BlockCipher c => (B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> String) -> c -> B.ByteString -> B.ByteString -> B.ByteString -> CCT.AuthTag -> Either String B.ByteString decryptWithOCBRFC7253With onAuthFailure cipher nonce ad ciphertext authTag = do when (B.length nonce > 15 || B.null nonce) $ Left "invalid nonce size for OCB" when (B.length tagBytes /= 16) $ Left "invalid auth tag size for OCB" offset0 <- ocbOffset0 cipher nonce let zeroBlock = B.replicate 16 0 lStar = CCT.ecbEncrypt cipher zeroBlock lDollar = ocbDouble lStar lCache = iterate ocbDouble (ocbDouble lDollar) hashAd = ocbHash cipher lStar lCache ad (fullBlocks, partial) = splitFullAndPartial ciphertext (plainBlocks, offsetM, checksum) = foldl' (\(accBlocks, offsetPrev, checksumPrev) (idx, cBlock) -> let offsetI = xorBS offsetPrev (lCache !! ntz idx) plainI = xorBS offsetI (CCT.ecbDecrypt cipher (xorBS offsetI cBlock)) checksumI = xorBS checksumPrev plainI in (accBlocks ++ [plainI], offsetI, checksumI)) ([], offset0, zeroBlock) (zip [1 ..] fullBlocks) (plainLast, offsetLast, checksumLast) = if B.null partial then (B.empty, offsetM, checksum) else let offsetStar = xorBS offsetM lStar pad = CCT.ecbEncrypt cipher offsetStar plainPartial = xorBS partial (B.take (B.length partial) pad) checksum' = xorBS checksum (ocbPadPartial plainPartial) in (plainPartial, offsetStar, checksum') tagComputed = xorBS (CCT.ecbEncrypt cipher (xorBS (xorBS checksumLast offsetLast) lDollar)) hashAd plaintext = B.concat plainBlocks <> plainLast computedTag = B.take 16 tagComputed in if BA.constEq tagBytes computedTag then Right plaintext else Left (onAuthFailure tagBytes computedTag nonce ad hashAd plaintext) where tagBytes = BA.convert authTag :: B.ByteString mkAuthTag :: B.ByteString -> CCT.AuthTag mkAuthTag = CCT.AuthTag . BA.convert ocbOffset0 :: CCT.BlockCipher c => c -> B.ByteString -> Either String B.ByteString ocbOffset0 cipher nonce = do let nonceLen = B.length nonce prefixLen = 16 - nonceLen when (prefixLen <= 0) $ Left "invalid nonce size for OCB" let prefix = B.pack (replicate (prefixLen - 1) 0 <> [1 :: Word8]) nonceBlock = prefix <> nonce bottom = fromIntegral (B.last nonceBlock .&. 0x3f) :: Int nonceTop = B.init nonceBlock <> B.singleton (B.last nonceBlock .&. 0xc0) kTop = CCT.ecbEncrypt cipher nonceTop stretch = kTop <> xorBS (B.take 8 kTop) (B.take 8 (B.drop 1 kTop)) Right (ocbBitSlice128 stretch bottom) ocbHash :: CCT.BlockCipher c => c -> B.ByteString -> [B.ByteString] -> B.ByteString -> B.ByteString ocbHash cipher lStar lCache ad = let (fullBlocks, partial) = splitFullAndPartial ad (sumBlocks, offsetFinal) = foldl' (\(acc, offsetPrev) (idx, block) -> let offsetI = xorBS offsetPrev (lCache !! ntz idx) sumI = xorBS acc (CCT.ecbEncrypt cipher (xorBS offsetI block)) in (sumI, offsetI)) (B.replicate 16 0, B.replicate 16 0) (zip [1 ..] fullBlocks) in if B.null partial then sumBlocks else let offsetStar = xorBS offsetFinal lStar block = ocbPadPartial partial in xorBS sumBlocks (CCT.ecbEncrypt cipher (xorBS offsetStar block)) ocbPadPartial :: B.ByteString -> B.ByteString ocbPadPartial bs = bs <> B.singleton 0x80 <> B.replicate (15 - B.length bs) 0 ocbDouble :: B.ByteString -> B.ByteString ocbDouble bs = let shifted = shiftLeftOne bs carry = (B.head bs .&. 0x80) /= 0 in if carry then B.init shifted <> B.singleton (B.last shifted `xor` 0x87) else shifted shiftLeftOne :: B.ByteString -> B.ByteString shiftLeftOne bs = B.pack shifted where (shifted, _) = foldl' (\(acc, carryIn) x -> let y = ((x `shiftL` 1) .&. 0xff) .|. carryIn carryOut = if (x .&. 0x80) /= 0 then 1 else 0 in (y : acc, carryOut)) ([], 0) (reverse (B.unpack bs)) xorBS :: B.ByteString -> B.ByteString -> B.ByteString xorBS a b = B.pack (B.zipWith xor a b) ocbBitSlice128 :: B.ByteString -> Int -> B.ByteString ocbBitSlice128 stretch startBit = let stretchInt = os2ip stretch shift = 192 - (startBit + 128) mask = (1 `shiftL` (128 :: Int)) - 1 slice = (stretchInt `shiftR` shift) .&. mask in leftPadTo16 (i2osp slice) leftPadTo16 :: B.ByteString -> B.ByteString leftPadTo16 bs | B.length bs >= 16 = B.drop (B.length bs - 16) bs | otherwise = B.replicate (16 - B.length bs) 0 <> bs splitFullAndPartial :: B.ByteString -> ([B.ByteString], B.ByteString) splitFullAndPartial bs | B.null bs = ([], B.empty) | otherwise = let fullLen = (B.length bs `div` 16) * 16 (fullPart, rest) = B.splitAt fullLen bs in (chunk16 fullPart, rest) chunk16 :: B.ByteString -> [B.ByteString] chunk16 bs | B.null bs = [] | otherwise = let (h, t) = B.splitAt 16 bs in h : chunk16 t ntz :: Int -> Int ntz i = go i 0 where go n c | n .&. 1 == 1 = c | otherwise = go (n `shiftR` 1) (c + 1) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/KeyInfo.hs0000644000000000000000000000413507346545000020006 0ustar0000000000000000-- KeyInfo.hs: OpenPGP (RFC9580) fingerprinting methods -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.KeyInfo ( pubkeySize , pkalgoAbbrev ) where 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 (shiftR) import Data.List (unfoldr) import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BaseTypes 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) 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 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)) pkalgoAbbrev :: PubKeyAlgorithm -> String pkalgoAbbrev RSA = "rsa" pkalgoAbbrev DSA = "dsa" pkalgoAbbrev ElgamalEncryptOnly = "elg" pkalgoAbbrev DeprecatedRSAEncryptOnly = "-re" pkalgoAbbrev DeprecatedRSASignOnly = "-rs" pkalgoAbbrev ECDH = "ecdh" pkalgoAbbrev ECDSA = "ecd" pkalgoAbbrev ForbiddenElgamal = "-eg" pkalgoAbbrev DH = "dh" pkalgoAbbrev EdDSA = "edd" pkalgoAbbrev BaseTypes.X25519 = "x25" pkalgoAbbrev BaseTypes.X448 = "x448" pkalgoAbbrev BaseTypes.Ed25519 = "e25" pkalgoAbbrev BaseTypes.Ed448 = "e448" pkalgoAbbrev (OtherPKA _) = "." hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/KeySelection.hs0000644000000000000000000000244707346545000021044 0ustar0000000000000000-- KeySelection.hs: OpenPGP (RFC9580) ways to ask for keys -- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE OverloadedStrings #-} module Codec.Encryption.OpenPGP.KeySelection ( parseEightOctetKeyId , parseFingerprint ) where import Codec.Encryption.OpenPGP.Types import Control.Applicative (optional, (<|>)) import Control.Monad ((<=<)) import Crypto.Number.Serialize (i2osp) import Data.Attoparsec.Text ( Parser , asciiCI , count , hexadecimal , inClass , parseOnly , satisfy ) import qualified Data.ByteString.Lazy as BL import Data.Text (Text, toUpper) import qualified Data.Text as T parseEightOctetKeyId :: Text -> Either String EightOctetKeyId parseEightOctetKeyId = fmap EightOctetKeyId . (parseOnly hexes <=< parseOnly (hexPrefix *> hexen 16)) . toUpper parseFingerprint :: Text -> Either String Fingerprint parseFingerprint = fmap Fingerprint . (parseOnly hexes <=< parseOnly (hexen 64 <|> hexen 40 <|> hexen 32)) . toUpper . T.filter (/= ' ') hexPrefix :: Parser (Maybe Text) hexPrefix = optional (asciiCI "0x") hexen :: Int -> Parser Text hexen n = T.pack <$> count n (satisfy (inClass "A-F0-9")) hexes :: Parser BL.ByteString hexes = BL.fromStrict . i2osp <$> hexadecimal hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/KeyringParser.hs0000644000000000000000000005232207346545000021230 0ustar0000000000000000-- KeyringParser.hs: OpenPGP (RFC9580) transferable keys parsing -- 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 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.Text (Text) import Codec.Encryption.OpenPGP.Ontology (isTrustPkt) import Codec.Encryption.OpenPGP.Policy ( 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) renderChunkParseError :: KeyringChunkParseError -> String renderChunkParseError (ChunkFailureBeforeInput msg) = msg renderChunkParseError ChunkUnexpectedFinalizationFailure = "Unexpected finalization failure" renderChunkParseError (ChunkParserFailure msg) = msg 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) 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) 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)) parseAChunkEither op a (cr, Nothing) = 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)) 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) 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) finalizeParsingEither (_, Just (_, 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 data UidOrUat = I Text | A [UserAttrSubPacket] deriving (Show) splitUs :: [(UidOrUat, [SignaturePayload])] -> ([(Text, [SignaturePayload])], [([UserAttrSubPacket], [SignaturePayload])]) splitUs us = (is, as) where is = map unI (filter isI us) as = map unA (filter isA us) isI (I _, _) = True isI _ = False isA (A _, _) = True isA _ = False unI (I x, y) = (x, y) unI x = error $ "unI should never be called on " ++ show x unA (A x, y) = (x, y) unA x = error $ "unA should never be called on " ++ show x 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) 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) 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 brokenTK 5 = do _ <- 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) _ -> failure _ -> failure where isPKP [pkt] = 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] signatureWithPredicate intolerant predicate = 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 brokensig' = const [] <$> broken 2 isSP True [SignaturePkt sp] = isSP' sp isSP False [SignaturePkt _] = True isSP _ _ = False isSP' sigPayload = maybe False predicate (sigType sigPayload) 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 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 where isUAt [UserAttributePkt _] = True isUAt _ = False 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 where isPSKP [pkt] = 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 [] 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 where isSSKP [pkt] = 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 [] 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) _ -> failure _ -> failure where isSKP [pkt] = 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 where isBroken [BrokenPacketPkt _ a _] = t == fromIntegral a isBroken _ = False -- | parse TKs from packets parseUnknownTKs :: Bool -> [Pkt] -> [TKUnknown] parseUnknownTKs intolerant ps = catMaybes $ runIncrementalParser (anyTK intolerant) (map (: []) (filter notTrustPacket ps)) where notTrustPacket = not . isTrustPkt parseTKsEither :: Bool -> [Pkt] -> [Either TKConversionError SomeTK] parseTKsEither 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) parseSecretTKs :: Bool -> [Pkt] -> [TK 'SecretTK] parseSecretTKs intolerant packets = mapMaybe someTKToSecretTK (parseTKs intolerant packets) anyTKWithWireRep :: Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep) anyTKWithWireRep True = publicTKWithWireRep True <|> secretTKWithWireRep True anyTKWithWireRep False = publicTKWithWireRep False <|> secretTKWithWireRep False <|> brokenTKWithWireRep 6 <|> brokenTKWithWireRep 5 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) where pubsub True = signedOrRevokedPubSubkeyWithWireRep True pubsub False = 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) where secsub True = rawOrSignedOrRevokedSecSubkeyWithWireRep True secsub False = rawOrSignedOrRevokedSecSubkeyWithWireRep False <|> brokenSecSubkeyWithWireRep 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 brokenTKWithWireRep 5 = do _ <- 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 = do pkpkts <- satisfy isPKPWS case pkpkts of [pktWithSource] -> case pktToPublicKeyPkt (_pktValue pktWithSource) of Just keyPkt | keyPktRole keyPkt == KeyPktPrimary -> return (keyPktTKKey keyPkt, [pktWithSource]) _ -> failure _ -> failure where isPKPWS [pktWithSource] = case pktToPublicKeyPkt (_pktValue pktWithSource) of Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary _ -> False isPKPWS _ = False signatureWithWireRep :: Bool -> [SigType] -> Parser [PktWithWireRep] ([SignaturePayload], [PktWithWireRep]) signatureWithWireRep intolerant rts = signatureWithWireRepPredicate intolerant (\st -> st `elem` rts) -- | RFC9580-aware signature parser with wire representation support signatureWithWireRepPredicate :: Bool -> (SigType -> Bool) -> Parser [PktWithWireRep] ([SignaturePayload], [PktWithWireRep]) signatureWithWireRepPredicate intolerant predicate = 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]) _ -> failure _ -> failure brokensig' = const ([], []) <$> brokenWithWireRep 2 isSPWS True [pktWithSource] = case _pktValue pktWithSource of SignaturePkt sp -> isSP' sp _ -> False isSPWS False [pktWithSource] = case _pktValue pktWithSource of SignaturePkt _ -> True _ -> False isSPWS _ _ = False isSP' sigPayload = maybe False predicate (sigType sigPayload) 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) _ -> failure _ -> failure where isUIDWS [pktWithSource] = case _pktValue pktWithSource of UserIdPkt _ -> True _ -> False isUIDWS _ = False 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) _ -> failure _ -> failure where isUAtWS [pktWithSource] = case _pktValue pktWithSource of UserAttributePkt _ -> True _ -> False isUAtWS _ = False 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 where isPSKPWS [pktWithSource] = case pktToPublicKeyPkt (_pktValue pktWithSource) of Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey _ -> False isPSKPWS _ = False brokenPubSubkeyWithWireRep :: Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])] brokenPubSubkeyWithWireRep = do _ <- brokenWithWireRep 14 _ <- concatMany (signatureWithWireRepPredicate False isAllowedSubkeySigType) return [] 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 where isSSKPWS [pktWithSource] = case pktToSecretKeyPkt (_pktValue pktWithSource) of Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey _ -> False isSSKPWS _ = False brokenSecSubkeyWithWireRep :: Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])] brokenSecSubkeyWithWireRep = do _ <- brokenWithWireRep 7 _ <- concatMany (signatureWithWireRepPredicate False isAllowedSubkeySigType) return [] 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]) _ -> failure _ -> failure where isSKPWS [pktWithSource] = case pktToSecretKeyPkt (_pktValue pktWithSource) of Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary _ -> False isSKPWS _ = False brokenWithWireRep :: Int -> Parser [PktWithWireRep] PktWithWireRep brokenWithWireRep t = do bpkts <- satisfy isBrokenWS case bpkts of [bp] -> return bp _ -> failure where isBrokenWS [pktWithSource] = case _pktValue pktWithSource of BrokenPacketPkt _ a _ -> t == fromIntegral a _ -> False isBrokenWS _ = False parseTKsWithWireRep :: Bool -> [PktWithWireRep] -> [TKWithWireRep] parseTKsWithWireRep intolerant 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 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 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 hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Message.hs0000644000000000000000000010022407346545000020022 0ustar0000000000000000-- Message.hs: OpenPGP (RFC9580) message helpers -- Copyright © 2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Codec.Encryption.OpenPGP.Message ( Passphrase , mkPassphrase , passphraseBytes , EncryptedPayload , mkEncryptedPayload , encryptedPayloadBytes , ClearPayload , mkClearPayload , clearPayloadBytes , WrappedSessionMaterial , SigningAlgorithm(..) , SecretKeyFor , VersionedPKPayload , asV4PKPayload , asV6PKPayload , Signer , SigningCapability , mkRSASignerV4 , mkRSASignerV6 , mkEd25519SignerV4 , mkEd25519SignerV6 , mkEd448SignerV4 , mkEd448SignerV6 , MessageParseFailure(..) , MessageDecryptFailure(..) , MessageError(..) , SessionMaterialExposure(..) , EncryptMessageProfile , EncryptMessageOptions(..) , RecoveredSessionMaterial(..) , encryptMessage , decryptMessage , signMessage , signMessageWith , ConduitMessage.VerificationPolicy(..) , ConduitMessage.VerificationOptions(..) , ConduitMessage.defaultVerificationOptions , verifySignedMessage ) where import Data.Bifunctor (first) import Data.Kind (Type) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import qualified Crypto.Hash as CH import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.RSA.Types as RSATypes import qualified Data.ByteArray as BA import Crypto.Random.Types (MonadRandom, getRandomBytes) import Data.Binary (put) import Data.Binary.Put (runPut) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Word (Word8) import Codec.Encryption.OpenPGP.BlockCipher (CipherError, renderCipherError, keySize, withSymmetricCipher) import Codec.Encryption.OpenPGP.CFB ( OpenPGPCFBModeW(..) , decryptOpenPGPCfb , decryptPreservingNonce , encryptOpenPGPCfbRaw , mdcTrailerForSEIPDv1 , seipdv1NonceFromIV , validateSEIPD1MDC ) import Codec.Encryption.OpenPGP.Encrypt (encryptSEIPDv2WithSKESKBlock) import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..)) import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 ( decryptSKESK6SessionKey , deriveSKESK6KEK ) import Codec.Encryption.OpenPGP.Policy ( OpenPGPPolicy , defaultPolicy , deprecatedHashAlgorithms , messageDefaultAEADAlgorithm , messageDefaultChunkSize , messageSEIPDv2SaltOctets , policyGenerationDeprecations , policyMessageEncryption , supportsSEIPDv2Symmetric , OpenPGPRFCW(..) , HashAlgorithmW(..) ) import Codec.Encryption.OpenPGP.S2K (S2KError(..), renderS2KError, skesk2SessionKey, string2Key) import Codec.Encryption.OpenPGP.Serialize (parsePkts) import Codec.Encryption.OpenPGP.Signatures ( SignError(..) , VerificationError , signDataWithRSABuilder , signDataWithRSAV6Builder , signDataWithEd25519Builder , signDataWithEd25519V6Builder , signDataWithEd448Builder , signDataWithEd448V6Builder ) import Codec.Encryption.OpenPGP.Subpackets ( sigBuilderInitTyped , sigBuilderInitV6Typed , addHashedSubs , addUnhashedSubs , listToHashedSubs , listToUnhashedSubs ) import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA import Data.Conduit.OpenPGP.Decrypt (decryptSEIPDv2Payload) import qualified Data.Conduit.OpenPGP.Message as ConduitMessage newtype Passphrase = Passphrase { unPassphrase :: BL.ByteString } deriving (Eq, Ord, Show) newtype EncryptedPayload = EncryptedPayload { unEncryptedPayload :: BL.ByteString } deriving (Eq, Ord, Show) newtype ClearPayload = ClearPayload { unClearPayload :: BL.ByteString } deriving (Eq, Ord, Show) newtype WrappedSessionMaterial = WrappedSessionMaterial { unWrappedSessionMaterial :: B.ByteString } deriving (Eq, Ord, Show) data SigningAlgorithm = AlgoRSA | AlgoEd25519 | AlgoEd448 type family SecretKeyFor (alg :: SigningAlgorithm) where SecretKeyFor 'AlgoRSA = RSATypes.PrivateKey SecretKeyFor 'AlgoEd25519 = Ed25519.SecretKey SecretKeyFor 'AlgoEd448 = Ed448.SecretKey type family KeyVersionForSig (v :: Type) :: KeyVersion where KeyVersionForSig V4Sig = 'V4 KeyVersionForSig V6Sig = 'V6 data VersionedPKPayload (v :: KeyVersion) where VersionedPKPayloadV4 :: PKPayload 'V4 -> VersionedPKPayload 'V4 VersionedPKPayloadV6 :: PKPayload 'V6 -> VersionedPKPayload 'V6 asV4PKPayload :: SomePKPayload -> Either String (VersionedPKPayload 'V4) asV4PKPayload (SomePKPayload pk@(PKPayloadV4 _ _ _)) = Right (VersionedPKPayloadV4 pk) asV4PKPayload _ = Left "Expected a v4 PKPayload" asV6PKPayload :: SomePKPayload -> Either String (VersionedPKPayload 'V6) asV6PKPayload (SomePKPayload pk@(PKPayloadV6 _ _ _)) = Right (VersionedPKPayloadV6 pk) asV6PKPayload _ = Left "Expected a v6 PKPayload" data Signer (alg :: SigningAlgorithm) (v :: Type) where RSASigner :: VersionedPKPayload (KeyVersionForSig v) -> SecretKeyFor 'AlgoRSA -> Signer 'AlgoRSA v Ed25519Signer :: VersionedPKPayload (KeyVersionForSig v) -> SecretKeyFor 'AlgoEd25519 -> Signer 'AlgoEd25519 v Ed448Signer :: VersionedPKPayload (KeyVersionForSig v) -> SecretKeyFor 'AlgoEd448 -> Signer 'AlgoEd448 v class SigningCapability (alg :: SigningAlgorithm) v instance SigningCapability 'AlgoRSA V4Sig instance SigningCapability 'AlgoRSA V6Sig instance SigningCapability 'AlgoEd25519 V4Sig instance SigningCapability 'AlgoEd25519 V6Sig instance SigningCapability 'AlgoEd448 V4Sig instance SigningCapability 'AlgoEd448 V6Sig mkRSASignerV4 :: VersionedPKPayload 'V4 -> SecretKeyFor 'AlgoRSA -> Signer 'AlgoRSA V4Sig mkRSASignerV4 = RSASigner mkRSASignerV6 :: VersionedPKPayload 'V6 -> SecretKeyFor 'AlgoRSA -> Signer 'AlgoRSA V6Sig mkRSASignerV6 = RSASigner mkEd25519SignerV4 :: VersionedPKPayload 'V4 -> SecretKeyFor 'AlgoEd25519 -> Signer 'AlgoEd25519 V4Sig mkEd25519SignerV4 = Ed25519Signer mkEd25519SignerV6 :: VersionedPKPayload 'V6 -> SecretKeyFor 'AlgoEd25519 -> Signer 'AlgoEd25519 V6Sig mkEd25519SignerV6 = Ed25519Signer mkEd448SignerV4 :: VersionedPKPayload 'V4 -> SecretKeyFor 'AlgoEd448 -> Signer 'AlgoEd448 V4Sig mkEd448SignerV4 = Ed448Signer mkEd448SignerV6 :: VersionedPKPayload 'V6 -> SecretKeyFor 'AlgoEd448 -> Signer 'AlgoEd448 V6Sig mkEd448SignerV6 = Ed448Signer data MessageError = MessageEncryptError String | MessageDecryptError String | MessageSignError SignError | MessageParseError String | MessageParseFailureError MessageParseFailure | MessageDecryptFailureError MessageDecryptFailure deriving (Eq, Show) newtype MessageFlow a = MessageFlow { runMessageFlow :: Either MessageError a } instance Functor MessageFlow where fmap f (MessageFlow result) = MessageFlow (fmap f result) instance Applicative MessageFlow where pure = MessageFlow . Right MessageFlow ff <*> MessageFlow fa = MessageFlow (ff <*> fa) instance Monad MessageFlow where MessageFlow result >>= f = case result of Left err -> MessageFlow (Left err) Right x -> f x messageStep :: Either MessageError a -> MessageFlow a messageStep = MessageFlow type MessageFlowT m = ExceptT MessageError m runMessageFlowT :: MessageFlowT m a -> m (Either MessageError a) runMessageFlowT = runExceptT liftMessageFlowT :: Monad m => MessageFlow a -> MessageFlowT m a liftMessageFlowT (MessageFlow result) = case result of Left err -> throwE err Right x -> pure x data MessageParseFailure = MissingEncryptedMessage | ExpectedSKESKThenEncryptedData | SKESKSEIPDAlgorithmMismatch | UnsupportedEncryptedSKESK | MissingLiteralDataPacket | UnknownCriticalPacketType Word8 | BrokenCriticalPacketType Word8 String deriving (Eq, Show) data MessageDecryptFailure = SessionMaterialDerivationFailed S2KError | PayloadDecryptFailed String deriving (Eq, Show) data ParsedEncryptedPayloadKind = LegacySEDPayloadKind | LegacySEIPDv1PayloadKind | SEIPDv2PayloadKind data EncryptedPreludeKind = LegacyEncryptedPreludeKind | SEIPDv2EncryptedPreludeKind data SessionMaterialExposure = DoNotExposeSessionMaterial | ExposeSessionMaterial deriving (Eq, Show) data EncryptMessageProfile = RFC4880Message | RFC9580Message data EncryptMessageOptions (p :: EncryptMessageProfile) where RFC4880EncryptMessageOptions :: { rfc4880EncryptMessageExposure :: SessionMaterialExposure , rfc4880EncryptMessageSymmetricAlgorithm :: SymmetricAlgorithm , rfc4880EncryptMessageS2K :: S2K , rfc4880EncryptMessageIV :: IV } -> EncryptMessageOptions 'RFC4880Message RFC9580EncryptMessageOptions :: { rfc9580EncryptMessageExposure :: SessionMaterialExposure , rfc9580EncryptMessageSymmetricAlgorithm :: SymmetricAlgorithm , rfc9580EncryptMessageS2K :: S2K , rfc9580EncryptMessageIV :: IV } -> EncryptMessageOptions 'RFC9580Message deriving instance Eq (EncryptMessageOptions p) deriving instance Show (EncryptMessageOptions p) data RecoveredSessionMaterial = RecoveredSessionMaterial { recoveredSessionAlgorithm :: SymmetricAlgorithm , recoveredSessionKey :: SessionKey } deriving (Eq, Show) renderMessageParseFailure :: MessageParseFailure -> String renderMessageParseFailure MissingEncryptedMessage = "Could not parse encrypted OpenPGP message" renderMessageParseFailure ExpectedSKESKThenEncryptedData = "Expected an SKESK packet followed by symmetrically encrypted data or SEIPD v2 data" renderMessageParseFailure SKESKSEIPDAlgorithmMismatch = "SKESK and SEIPD v2 algorithms do not match" renderMessageParseFailure UnsupportedEncryptedSKESK = "Cannot decrypt SKESK packets with encrypted session keys" renderMessageParseFailure MissingLiteralDataPacket = "Decrypted message does not contain a literal data packet" renderMessageParseFailure (UnknownCriticalPacketType t) = "Unknown critical packet type: " ++ show t renderMessageParseFailure (BrokenCriticalPacketType t err) = "Broken critical packet type " ++ show t ++ ": " ++ err renderMessageDecryptFailure :: MessageDecryptFailure -> String renderMessageDecryptFailure (SessionMaterialDerivationFailed err) = renderS2KError err renderMessageDecryptFailure (PayloadDecryptFailed err) = err mkPassphrase :: BL.ByteString -> Passphrase mkPassphrase = Passphrase passphraseBytes :: Passphrase -> BL.ByteString passphraseBytes = unPassphrase mkEncryptedPayload :: BL.ByteString -> EncryptedPayload mkEncryptedPayload = EncryptedPayload mkClearPayload :: BL.ByteString -> ClearPayload mkClearPayload = ClearPayload clearPayloadBytes :: ClearPayload -> BL.ByteString clearPayloadBytes = unClearPayload encryptedPayloadBytes :: EncryptedPayload -> BL.ByteString encryptedPayloadBytes = unEncryptedPayload firstLeft :: (e -> e') -> Either e a -> Either e' a firstLeft f = either (Left . f) Right -- | Lift a parse failure step into the unified MessageError channel parseStep :: Either MessageParseFailure a -> MessageFlow a parseStep = messageStep . firstLeft MessageParseFailureError -- | Lift a decrypt failure step into the unified MessageError channel decryptStep :: Either MessageDecryptFailure a -> MessageFlow a decryptStep = messageStep . firstLeft MessageDecryptFailureError -- | Lift a string encrypt error step into the unified MessageError channel encryptStep :: Either String a -> MessageFlow a encryptStep = messageStep . firstLeft MessageEncryptError -- | Lift a sign error step into the unified MessageError channel signStep :: Either SignError a -> MessageFlow a signStep = messageStep . firstLeft MessageSignError signStepT :: Monad m => Either SignError a -> MessageFlowT m a signStepT = liftMessageFlowT . signStep signBackendStep :: Either String a -> Either SignError a signBackendStep = firstLeft SignBackendError decryptSessionStep :: Either S2KError a -> Either MessageDecryptFailure a decryptSessionStep = firstLeft SessionMaterialDerivationFailed decryptSessionKeySizeStep :: Either CipherError a -> Either MessageDecryptFailure a decryptSessionKeySizeStep = firstLeft (SessionMaterialDerivationFailed . S2KUnsupportedAlgorithm) decryptCipherStep :: Either CipherError a -> Either MessageDecryptFailure a decryptCipherStep = firstLeft (PayloadDecryptFailed . renderCipherError) decryptPayloadStep :: Either String a -> Either MessageDecryptFailure a decryptPayloadStep = firstLeft PayloadDecryptFailed encryptMessage :: EncryptMessageOptions p -> Passphrase -> ClearPayload -> Either MessageError (EncryptedPayload, Maybe RecoveredSessionMaterial) encryptMessage options passphrase payload = runMessageFlow $ case options of RFC4880EncryptMessageOptions exposure sa s2k iv -> do encryptedPayload <- encryptMessageWithRFC4880Fallback sa s2k iv passphrase payload sessionKeyMaterial <- deriveSessionMaterial sa s2k passphrase pure (encryptedPayload, exposedSessionMaterial exposure sa sessionKeyMaterial) RFC9580EncryptMessageOptions exposure sa s2k iv -> do encryptStep $ validateRFC9580MessageSymmetric defaultPolicy sa encryptStep $ validateModernMessageS2K defaultPolicy s2k encrypted <- encryptStep $ encryptSEIPDv2WithSKESKBlock sa (messageDefaultAEADAlgorithm messagePolicy) (messageDefaultChunkSize messagePolicy) (defaultSEIPDv2SaltFromIV (messageSEIPDv2SaltOctets messagePolicy) iv) s2k (unPassphrase passphrase) (Block [LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload)]) sessionKeyMaterial <- deriveSessionMaterial sa s2k passphrase pure ( EncryptedPayload (runPut (put (Block encrypted))) , exposedSessionMaterial exposure sa sessionKeyMaterial ) where messagePolicy = policyMessageEncryption defaultPolicy defaultSEIPDv2SaltFromIV :: Int -> IV -> Salt defaultSEIPDv2SaltFromIV outputLen (IV ivBytes) = Salt (B.take outputLen (B.concat (replicate outputLen seed))) where seed | B.null ivBytes = B.singleton 0 | otherwise = ivBytes encryptMessageWithRFC4880Fallback :: SymmetricAlgorithm -> S2K -> IV -> Passphrase -> ClearPayload -> MessageFlow EncryptedPayload encryptMessageWithRFC4880Fallback sa s2k iv passphrase payload = do keyLen <- encryptStep . first renderCipherError $ keySize sa sessionMaterial <- encryptStep . first renderS2KError $ WrappedSessionMaterial <$> string2Key s2k keyLen (unPassphrase passphrase) let literal = LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload) cleartext = BL.toStrict (runPut (put (Block [literal]))) cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext encrypted <- encryptStep . first renderCipherError $ encryptOpenPGPCfbRaw OpenPGPCFBNoResyncW sa iv cleartextWithMDC (unWrappedSessionMaterial sessionMaterial) return . EncryptedPayload . runPut . put $ Block [ SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) , SymEncIntegrityProtectedDataPkt (SEIPD1 1 (BL.fromStrict encrypted)) ] deriveSessionMaterial :: SymmetricAlgorithm -> S2K -> Passphrase -> MessageFlow B.ByteString deriveSessionMaterial sa s2k passphrase = do keyLen <- encryptStep . first renderCipherError $ keySize sa encryptStep . first renderS2KError $ string2Key s2k keyLen (unPassphrase passphrase) exposedSessionMaterial :: SessionMaterialExposure -> SymmetricAlgorithm -> B.ByteString -> Maybe RecoveredSessionMaterial exposedSessionMaterial DoNotExposeSessionMaterial _ _ = Nothing exposedSessionMaterial ExposeSessionMaterial sa sessionKeyMaterial = Just (RecoveredSessionMaterial { recoveredSessionAlgorithm = sa , recoveredSessionKey = SessionKey sessionKeyMaterial }) decryptMessage :: Passphrase -> EncryptedPayload -> Either MessageError ClearPayload decryptMessage passphrase encrypted = runMessageFlow $ do encryptedPackets <- parseStep $ rejectUnknownCriticalPacketsTyped (parsePkts (unEncryptedPayload encrypted)) payload <- parseStep $ extractEncryptedPayload encryptedPackets cleartext <- decryptStep $ decryptPayloadTyped passphrase payload clearPackets <- parseStep $ rejectUnknownCriticalPacketsTyped (parsePkts (unClearPayload cleartext)) parseStep $ extractLiteralPayload clearPackets signMessageWith :: (MonadRandom m, SigningCapability alg v) => Signer alg v -> ClearPayload -> m (Either MessageError BL.ByteString) signMessageWith signer payload = runMessageFlowT $ case signer of RSASigner signerPK signingKey -> case signerPK of VersionedPKPayloadV4 pk -> signV4Message pk (\hashed unhashed clear -> let builder = sigBuilderInitTyped @'PKA.RSA RFC9580W BinarySig SHA512W withHashed = addHashedSubs (listToHashedSubs hashed) builder withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed in signDataWithRSABuilder withUnhashed signingKey clear) payload VersionedPKPayloadV6 pk -> signV6Message pk (\salt hashed unhashed clear -> let builder = sigBuilderInitV6Typed @'PKA.RSA RFC9580W BinarySig SHA512W salt withHashed = addHashedSubs (listToHashedSubs hashed) builder withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed in signDataWithRSAV6Builder withUnhashed signingKey clear) payload Ed25519Signer signerPK signingKey -> case signerPK of VersionedPKPayloadV4 pk -> signV4Message pk (\hashed unhashed clear -> let builder = sigBuilderInitTyped @'PKA.Ed25519 RFC9580W BinarySig SHA512W withHashed = addHashedSubs (listToHashedSubs hashed) builder withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed in signDataWithEd25519Builder withUnhashed signingKey clear) payload VersionedPKPayloadV6 pk -> signV6Message pk (\salt hashed unhashed clear -> let builder = sigBuilderInitV6Typed @'PKA.Ed25519 RFC9580W BinarySig SHA512W salt withHashed = addHashedSubs (listToHashedSubs hashed) builder withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed in signDataWithEd25519V6Builder withUnhashed signingKey clear) payload Ed448Signer signerPK signingKey -> case signerPK of VersionedPKPayloadV4 pk -> signV4Message pk (\hashed unhashed clear -> let builder = sigBuilderInitTyped @'PKA.Ed448 RFC9580W BinarySig SHA512W withHashed = addHashedSubs (listToHashedSubs hashed) builder withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed in signDataWithEd448Builder withUnhashed signingKey clear) payload VersionedPKPayloadV6 pk -> signV6Message pk (\salt hashed unhashed clear -> let builder = sigBuilderInitV6Typed @'PKA.Ed448 RFC9580W BinarySig SHA512W salt withHashed = addHashedSubs (listToHashedSubs hashed) builder withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed in signDataWithEd448V6Builder withUnhashed signingKey clear) payload signMessage :: (MonadRandom m, SigningCapability alg v) => Signer alg v -> BL.ByteString -> m (Either MessageError BL.ByteString) signMessage signer = signMessageWith signer . mkClearPayload versionedPKPayload :: VersionedPKPayload v -> PKPayload v versionedPKPayload (VersionedPKPayloadV4 pk) = pk versionedPKPayload (VersionedPKPayloadV6 pk) = pk verifySignedMessage :: ConduitMessage.VerificationOptions -> PublicKeyring -> BL.ByteString -> [Either VerificationError Verification] verifySignedMessage = ConduitMessage.verifyMessage signV4Message :: Monad m => PKPayload 'V4 -> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload) -> ClearPayload -> MessageFlowT m BL.ByteString signV4Message signer signingFn payload = signStepT (signV4WithIssuers signer signingFn payload) signV6Message :: MonadRandom m => PKPayload 'V6 -> (SignatureSalt -> [SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload) -> ClearPayload -> MessageFlowT m BL.ByteString signV6Message signer signingFn payload = do salt <- lift randomSHA512SignatureSalt signStepT (signV6WithFingerprintOnly signer (signingFn salt) payload) randomSHA512SignatureSalt :: MonadRandom m => m SignatureSalt randomSHA512SignatureSalt = SignatureSalt . BL.fromStrict <$> getRandomBytes 32 signV4WithIssuers :: PKPayload 'V4 -> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload) -> ClearPayload -> Either SignError BL.ByteString signV4WithIssuers signer signingFn payload = do issuerKeyId <- signBackendStep (eightOctetKeyID (SomePKPayload signer)) let hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint (SomePKPayload signer)))] unhashed = [SigSubPacket False (Issuer issuerKeyId)] signWithSubpackets hashed unhashed signingFn payload signV6WithFingerprintOnly :: PKPayload 'V6 -> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload) -> ClearPayload -> Either SignError BL.ByteString signV6WithFingerprintOnly signer signingFn payload = do let hashed = [SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 (fingerprint (SomePKPayload signer)))] unhashed = [] signWithSubpackets hashed unhashed signingFn payload signWithSubpackets :: [SigSubPacket] -> [SigSubPacket] -> ([SigSubPacket] -> [SigSubPacket] -> BL.ByteString -> Either SignError SignaturePayload) -> ClearPayload -> Either SignError BL.ByteString signWithSubpackets hashed unhashed signingFn payload = do let clear = unClearPayload payload literal = LiteralDataPkt BinaryData BL.empty 0 clear signature <- signingFn hashed unhashed clear return . runPut . put $ Block [literal, SignaturePkt signature] encryptOpenPGPCfb :: SymmetricAlgorithm -> IV -> B.ByteString -> WrappedSessionMaterial -> Either CipherError B.ByteString encryptOpenPGPCfb sa iv cleartext (WrappedSessionMaterial keydata) = encryptOpenPGPCfbRaw OpenPGPCFBResyncW sa iv cleartext keydata extractEncryptedPayload :: [Pkt] -> Either MessageParseFailure SomeParsedEncryptedPayload extractEncryptedPayload = fmap parsedEncryptedPayloadFromPrelude . extractEncryptedPreludeTyped data EncryptedPrelude (k :: EncryptedPreludeKind) where LegacySEDPrelude :: SKESK 'SKESKV4 -> B.ByteString -> EncryptedPrelude 'LegacyEncryptedPreludeKind LegacySEIPDv1Prelude :: SKESK 'SKESKV4 -> B.ByteString -> EncryptedPrelude 'LegacyEncryptedPreludeKind SEIPDv2SKESK4Prelude :: SymmetricAlgorithm -> S2K -> AEADAlgorithm -> Word8 -> Salt -> B.ByteString -> EncryptedPrelude 'SEIPDv2EncryptedPreludeKind SEIPDv2SKESK6Prelude :: SymmetricAlgorithm -> AEADAlgorithm -> S2K -> BL.ByteString -> BL.ByteString -> BL.ByteString -> Word8 -> Salt -> B.ByteString -> EncryptedPrelude 'SEIPDv2EncryptedPreludeKind data SomeEncryptedPrelude where SomeEncryptedPrelude :: EncryptedPrelude k -> SomeEncryptedPrelude extractEncryptedPreludeTyped :: [Pkt] -> Either MessageParseFailure SomeEncryptedPrelude extractEncryptedPreludeTyped (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k esk)):SymEncDataPkt payload:_) = Right (SomeEncryptedPrelude (LegacySEDPrelude (SKESK4Packet sa s2k esk) (BL.toStrict payload))) extractEncryptedPreludeTyped (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k esk)):SymEncIntegrityProtectedDataPkt (SEIPD1 _ payload):_) = Right (SomeEncryptedPrelude (LegacySEIPDv1Prelude (SKESK4Packet sa s2k esk) (BL.toStrict payload))) extractEncryptedPreludeTyped (SKESKPkt skesk:SymEncIntegrityProtectedDataPkt (SEIPD2 payloadSA aead chunkSize salt payload):_) = toSEIPDv2Prelude skesk payloadSA aead chunkSize salt payload extractEncryptedPreludeTyped [] = Left MissingEncryptedMessage extractEncryptedPreludeTyped _ = Left ExpectedSKESKThenEncryptedData toSEIPDv2Prelude :: SKESKPayload -> SymmetricAlgorithm -> AEADAlgorithm -> Word8 -> Salt -> BL.ByteString -> Either MessageParseFailure SomeEncryptedPrelude toSEIPDv2Prelude (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) payloadSA aead chunkSize salt payload | sa /= payloadSA = Left SKESKSEIPDAlgorithmMismatch | otherwise = Right (SomeEncryptedPrelude (SEIPDv2SKESK4Prelude sa s2k aead chunkSize salt (BL.toStrict payload))) toSEIPDv2Prelude (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) payloadSA aead chunkSize salt payload | sa /= payloadSA = Left SKESKSEIPDAlgorithmMismatch | otherwise = Right (SomeEncryptedPrelude (SEIPDv2SKESK6Prelude sa aa s2k iv esk tag chunkSize salt (BL.toStrict payload))) toSEIPDv2Prelude (SKESKPayloadV4Packet (SKESKPayloadV4 _ _ (Just _))) _ _ _ _ _ = Left UnsupportedEncryptedSKESK toSEIPDv2Prelude _ _ _ _ _ _ = Left ExpectedSKESKThenEncryptedData parsedEncryptedPayloadFromPrelude :: SomeEncryptedPrelude -> SomeParsedEncryptedPayload parsedEncryptedPayloadFromPrelude (SomeEncryptedPrelude prelude) = case prelude of LegacySEDPrelude skesk payload -> SomeParsedEncryptedPayload (LegacySEDPayload skesk payload) LegacySEIPDv1Prelude skesk payload -> SomeParsedEncryptedPayload (LegacySEIPDv1Payload skesk payload) SEIPDv2SKESK4Prelude sa s2k aead chunkSize salt payload -> SomeParsedEncryptedPayload (SEIPDv2Payload sa aead chunkSize salt (SEIPDv2SKESK4 sa s2k) payload) SEIPDv2SKESK6Prelude sa aa s2k iv esk tag chunkSize salt payload -> SomeParsedEncryptedPayload (SEIPDv2Payload sa aa chunkSize salt (SEIPDv2SKESK6 sa aa s2k iv esk tag) payload) data SEIPDv2SKESKInfo (v :: KeyVersion) where SEIPDv2SKESK4 :: SymmetricAlgorithm -> S2K -> SEIPDv2SKESKInfo 'V4 SEIPDv2SKESK6 :: SymmetricAlgorithm -> AEADAlgorithm -> S2K -> BL.ByteString -> BL.ByteString -> BL.ByteString -> SEIPDv2SKESKInfo 'V6 data ParsedEncryptedPayload (k :: ParsedEncryptedPayloadKind) where LegacySEDPayload :: SKESK 'SKESKV4 -> B.ByteString -> ParsedEncryptedPayload 'LegacySEDPayloadKind LegacySEIPDv1Payload :: SKESK 'SKESKV4 -> B.ByteString -> ParsedEncryptedPayload 'LegacySEIPDv1PayloadKind SEIPDv2Payload :: SymmetricAlgorithm -> AEADAlgorithm -> Word8 -> Salt -> SEIPDv2SKESKInfo v -> B.ByteString -> ParsedEncryptedPayload 'SEIPDv2PayloadKind data SomeParsedEncryptedPayload where SomeParsedEncryptedPayload :: ParsedEncryptedPayload k -> SomeParsedEncryptedPayload decryptPayload :: Passphrase -> SomeParsedEncryptedPayload -> Either String ClearPayload decryptPayload passphrase = first renderMessageDecryptFailure . decryptPayloadTyped passphrase decryptPayloadTyped :: Passphrase -> SomeParsedEncryptedPayload -> Either MessageDecryptFailure ClearPayload decryptPayloadTyped passphrase (SomeParsedEncryptedPayload payload) = case payload of LegacySEDPayload skesk encryptedPayload -> decryptLegacySEDPayloadTyped passphrase skesk encryptedPayload LegacySEIPDv1Payload skesk encryptedPayload -> decryptLegacySEIPDv1PayloadTyped passphrase skesk encryptedPayload SEIPDv2Payload sa aead chunkSize salt skeskInfo encryptedPayload -> decryptSEIPDv2PayloadTyped passphrase sa aead chunkSize salt skeskInfo encryptedPayload decryptLegacySEDPayloadTyped :: Passphrase -> SKESK 'SKESKV4 -> B.ByteString -> Either MessageDecryptFailure ClearPayload decryptLegacySEDPayloadTyped passphrase skesk payload = do (sessionAlgorithm, sessionKeyBytes) <- decryptSessionStep $ skesk2SessionKey skesk (unPassphrase passphrase) decryptCipherStep $ ClearPayload . BL.fromStrict <$> decryptOpenPGPCfb sessionAlgorithm payload sessionKeyBytes decryptLegacySEIPDv1PayloadTyped :: Passphrase -> SKESK 'SKESKV4 -> B.ByteString -> Either MessageDecryptFailure ClearPayload decryptLegacySEIPDv1PayloadTyped passphrase skesk payload = do (sessionAlgorithm, sessionKeyBytes) <- decryptSessionStep $ skesk2SessionKey skesk (unPassphrase passphrase) (nonce, decrypted) <- decryptCipherStep $ decryptPreservingNonce sessionAlgorithm payload sessionKeyBytes cleartext <- decryptPayloadStep $ validateSEIPD1MDC nonce decrypted Right (ClearPayload (BL.fromStrict cleartext)) decryptSEIPDv2PayloadTyped :: Passphrase -> SymmetricAlgorithm -> AEADAlgorithm -> Word8 -> Salt -> SEIPDv2SKESKInfo v -> B.ByteString -> Either MessageDecryptFailure ClearPayload decryptSEIPDv2PayloadTyped passphrase sa aead chunkSize salt skeskInfo payload = do sessionKey <- SessionKey <$> deriveSEIPDv2SessionKeyBytes passphrase skeskInfo decryptPayloadStep $ ClearPayload . BL.fromStrict <$> decryptSEIPDv2Payload sa aead chunkSize salt payload sessionKey deriveSEIPDv2SessionKeyBytes :: Passphrase -> SEIPDv2SKESKInfo v -> Either MessageDecryptFailure B.ByteString deriveSEIPDv2SessionKeyBytes passphrase (SEIPDv2SKESK4 sa s2k) = deriveSessionKeyBytes passphrase sa s2k deriveSEIPDv2SessionKeyBytes passphrase (SEIPDv2SKESK6 sa aead s2k iv esk tag) = do ikm <- deriveSessionKeyBytes passphrase sa s2k kek <- decryptPayloadStep $ deriveSKESK6KEK sa aead ikm decryptPayloadStep $ decryptSKESK6SessionKey sa aead kek (BL.toStrict iv) (BL.toStrict esk) (BL.toStrict tag) deriveSessionKeyBytes :: Passphrase -> SymmetricAlgorithm -> S2K -> Either MessageDecryptFailure B.ByteString deriveSessionKeyBytes passphrase sa s2k = do keyLen <- decryptSessionKeySizeStep $ keySize sa decryptSessionStep $ string2Key s2k keyLen (unPassphrase passphrase) extractLiteralPayload :: [Pkt] -> Either MessageParseFailure ClearPayload extractLiteralPayload pkts = case [p | LiteralDataPkt _ _ _ p <- pkts] of payload:_ -> Right (ClearPayload payload) [] -> Left MissingLiteralDataPacket rejectUnknownCriticalPacketsTyped :: [Pkt] -> Either MessageParseFailure [Pkt] rejectUnknownCriticalPacketsTyped = go [] where go acc [] = Right (reverse acc) go acc (pkt:rest) = case pkt of OtherPacketPkt t _ | t < 40 -> Left (UnknownCriticalPacketType t) BrokenPacketPkt err t _ | t < 40 -> Left (BrokenCriticalPacketType t err) _ -> go (pkt : acc) rest validateModernMessageS2K :: OpenPGPPolicy -> S2K -> Either String () validateModernMessageS2K policy s2k = case s2kHashAlgorithm s2k of Just ha | ha `elem` deprecatedHashAlgorithms (policyGenerationDeprecations policy) -> Left ("deprecated hash algorithm disallowed for modern message generation: " ++ show ha) _ -> Right () validateRFC9580MessageSymmetric :: OpenPGPPolicy -> SymmetricAlgorithm -> Either String () validateRFC9580MessageSymmetric policy sa | supportsSEIPDv2Symmetric policy sa = Right () | otherwise = Left ("symmetric algorithm disallowed for RFC9580 message generation: " ++ show sa) s2kHashAlgorithm :: S2K -> Maybe HashAlgorithm s2kHashAlgorithm (Simple ha) = Just ha s2kHashAlgorithm (Salted ha _) = Just ha s2kHashAlgorithm (IteratedSalted ha _ _) = Just ha s2kHashAlgorithm Argon2 {} = Nothing s2kHashAlgorithm (OtherS2K _ _) = Nothing hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Ontology.hs0000644000000000000000000001031007346545000020244 0ustar0000000000000000-- Ontology.hs: OpenPGP (RFC9580) "is" functions -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} module Codec.Encryption.OpenPGP.Ontology ( -- * for signature payloads isCertRevocationSig , isRevokerP , isPKBindingSig , isSKBindingSig , isSubkeyBindingSig , isSubkeyRevocation , isTrustPkt -- * for signature subpackets , isCT , isIssuerSSP , isIssuerFPSSP , isKET , isKUF , isPHA , isRevocationKeySSP , isSigCreationTime ) where import Codec.Encryption.OpenPGP.Types data TrailerCapableSignaturePayload where TrailerCapableSignaturePayloadV4 :: SignaturePayloadV 'SigPayloadV4 -> TrailerCapableSignaturePayload TrailerCapableSignaturePayloadV6 :: SignaturePayloadV 'SigPayloadV6 -> TrailerCapableSignaturePayload trailerCapableSignaturePayload :: SignaturePayload -> Maybe TrailerCapableSignaturePayload trailerCapableSignaturePayload sig = case toSomeSignaturePayload sig of SomeSignaturePayload (payload@SigPayloadV4Data {}) -> Just (TrailerCapableSignaturePayloadV4 payload) SomeSignaturePayload (payload@SigPayloadV6Data {}) -> Just (TrailerCapableSignaturePayloadV6 payload) _ -> Nothing trailerCapableSigType :: TrailerCapableSignaturePayload -> SigType trailerCapableSigType (TrailerCapableSignaturePayloadV4 (SigPayloadV4Data st _ _ _ _ _ _)) = st trailerCapableSigType (TrailerCapableSignaturePayloadV6 (SigPayloadV6Data st _ _ _ _ _ _ _)) = st trailerCapableSubpacketLists :: TrailerCapableSignaturePayload -> ([SigSubPacket], [SigSubPacket]) trailerCapableSubpacketLists (TrailerCapableSignaturePayloadV4 (SigPayloadV4Data _ _ _ h u _ _)) = (h, u) trailerCapableSubpacketLists (TrailerCapableSignaturePayloadV6 (SigPayloadV6Data _ _ _ _ h u _ _)) = (h, u) -- | Test whether a 'SignaturePayload' has the given 'SigType'. -- Returns 'False' for V3 and 'SigVOther' payloads; V3 signatures are excluded -- from structural predicate checks since they lack subpacket support and are -- not used in V4/V6 keyring contexts. isSigTypeFor :: SigType -> SignaturePayload -> Bool isSigTypeFor expected sig = case trailerCapableSignaturePayload sig of Just trailerCapable -> trailerCapableSigType trailerCapable == expected _ -> False isCertRevocationSig :: SignaturePayload -> Bool isCertRevocationSig = isSigTypeFor CertRevocationSig isRevokerP :: SignaturePayload -> Bool isRevokerP sig = case trailerCapableSignaturePayload sig of Just trailerCapable | trailerCapableSigType trailerCapable == SignatureDirectlyOnAKey -> let (h, u) = trailerCapableSubpacketLists trailerCapable in hasRevokerSubpackets h u _ -> False hasRevokerSubpackets :: [SigSubPacket] -> [SigSubPacket] -> Bool hasRevokerSubpackets h u = any isRevocationKeySSP h && any isIssuerSSP u isPKBindingSig :: SignaturePayload -> Bool isPKBindingSig = isSigTypeFor PrimaryKeyBindingSig isSKBindingSig :: SignaturePayload -> Bool isSKBindingSig = isSigTypeFor SubkeyBindingSig isSubkeyRevocation :: SignaturePayload -> Bool isSubkeyRevocation = isSigTypeFor SubkeyRevocationSig isSubkeyBindingSig :: SignaturePayload -> Bool isSubkeyBindingSig = isSigTypeFor SubkeyBindingSig isTrustPkt :: Pkt -> Bool isTrustPkt (TrustPkt _) = True isTrustPkt _ = False isCT :: SigSubPacket -> Bool isCT (SigSubPacket _ (SigCreationTime _)) = True isCT _ = False isIssuerSSP :: SigSubPacket -> Bool isIssuerSSP (SigSubPacket _ (Issuer _)) = True isIssuerSSP _ = False isIssuerFPSSP :: SigSubPacket -> Bool isIssuerFPSSP (SigSubPacket _ (IssuerFingerprint _ _)) = True isIssuerFPSSP _ = False isKET :: SigSubPacket -> Bool isKET (SigSubPacket _ (KeyExpirationTime _)) = True isKET _ = False isKUF :: SigSubPacket -> Bool isKUF (SigSubPacket _ (KeyFlags _)) = True isKUF _ = False isPHA :: SigSubPacket -> Bool isPHA (SigSubPacket _ (PreferredHashAlgorithms _)) = True isPHA _ = False isRevocationKeySSP :: SigSubPacket -> Bool isRevocationKeySSP (SigSubPacket _ RevocationKey {}) = True isRevocationKeySSP _ = False isSigCreationTime :: SigSubPacket -> Bool isSigCreationTime (SigSubPacket _ (SigCreationTime _)) = True isSigCreationTime _ = False hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Policy.hs0000644000000000000000000004674307346545000017714 0ustar0000000000000000-- Policy.hs: OpenPGP standards policy profiles -- 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 #-} {-# LANGUAGE KindSignatures #-} {-# 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 import Codec.Encryption.OpenPGP.Types import Codec.Encryption.OpenPGP.SignatureQualities (sigType) 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.Word (Word8) import GHC.TypeLits (ErrorMessage(..), TypeError) data OpenPGPRFC = RFC2440 | RFC4880 | RFC9580 deriving (Eq, Show) data OpenPGPRFCW (rfc :: OpenPGPRFC) where RFC2440W :: OpenPGPRFCW 'RFC2440 RFC4880W :: OpenPGPRFCW 'RFC4880 RFC9580W :: OpenPGPRFCW 'RFC9580 data SomeOpenPGPRFCW where SomeOpenPGPRFCW :: OpenPGPRFCW rfc -> SomeOpenPGPRFCW demoteOpenPGPRFCW :: OpenPGPRFCW rfc -> OpenPGPRFC demoteOpenPGPRFCW RFC2440W = RFC2440 demoteOpenPGPRFCW RFC4880W = RFC4880 demoteOpenPGPRFCW RFC9580W = RFC9580 promoteOpenPGPRFC :: OpenPGPRFC -> SomeOpenPGPRFCW promoteOpenPGPRFC RFC2440 = SomeOpenPGPRFCW RFC2440W promoteOpenPGPRFC RFC4880 = SomeOpenPGPRFCW RFC4880W 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 data SomeHashAlgorithmW where SomeHashAlgorithmW :: HashAlgorithmW h -> SomeHashAlgorithmW demoteHashAlgorithmW :: HashAlgorithmW h -> HashAlgorithm demoteHashAlgorithmW DeprecatedMD5W = DeprecatedMD5 demoteHashAlgorithmW SHA1W = SHA1 demoteHashAlgorithmW RIPEMD160W = RIPEMD160 demoteHashAlgorithmW SHA256W = SHA256 demoteHashAlgorithmW SHA384W = SHA384 demoteHashAlgorithmW SHA512W = SHA512 demoteHashAlgorithmW SHA224W = SHA224 demoteHashAlgorithmW SHA3_256W = SHA3_256 demoteHashAlgorithmW SHA3_512W = SHA3_512 promoteHashAlgorithm :: HashAlgorithm -> Maybe SomeHashAlgorithmW promoteHashAlgorithm DeprecatedMD5 = Just (SomeHashAlgorithmW DeprecatedMD5W) promoteHashAlgorithm SHA1 = Just (SomeHashAlgorithmW SHA1W) promoteHashAlgorithm RIPEMD160 = Just (SomeHashAlgorithmW RIPEMD160W) promoteHashAlgorithm SHA256 = Just (SomeHashAlgorithmW SHA256W) promoteHashAlgorithm SHA384 = Just (SomeHashAlgorithmW SHA384W) promoteHashAlgorithm SHA512 = Just (SomeHashAlgorithmW SHA512W) promoteHashAlgorithm SHA224 = Just (SomeHashAlgorithmW SHA224W) promoteHashAlgorithm SHA3_256 = Just (SomeHashAlgorithmW SHA3_256W) promoteHashAlgorithm SHA3_512 = Just (SomeHashAlgorithmW SHA3_512W) promoteHashAlgorithm (OtherHA _) = Nothing signatureV6SaltSizeForHashAlgorithm :: HashAlgorithm -> Maybe Word8 signatureV6SaltSizeForHashAlgorithm SHA224 = Just 16 signatureV6SaltSizeForHashAlgorithm SHA256 = Just 16 signatureV6SaltSizeForHashAlgorithm SHA384 = Just 24 signatureV6SaltSizeForHashAlgorithm SHA512 = Just 32 signatureV6SaltSizeForHashAlgorithm SHA3_256 = Just 16 signatureV6SaltSizeForHashAlgorithm SHA3_512 = Just 32 signatureV6SaltSizeForHashAlgorithm _ = Nothing data HashAlgoStatus = 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 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") 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") type HashAlgoVerifiableFor rfc h = AssertHashVerifiable (HashAlgoStatusFor rfc h) data PKESKVersionPolicy = PreferV6 | ForceV3Interop deriving (Eq, Show) data MessageEncryptionPolicy = MessageEncryptionPolicy { 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 } data GenerationDeprecationPolicy = GenerationDeprecationPolicy { deprecatedHashAlgorithms :: [HashAlgorithm] , deprecatedSymmetricAlgorithms :: [SymmetricAlgorithm] } data VerificationDefaults = VerificationDefaults { 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. 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) data OpenPGPPolicy = OpenPGPPolicy { 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 } 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 } 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 } requireSalt8 :: String -> Salt -> Salt8 requireSalt8 context 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") defaultPolicy :: OpenPGPPolicy defaultPolicy = policyForRFC RFC9580 defaultPKESKVersionPolicy :: PKESKVersionPolicy defaultPKESKVersionPolicy = PreferV6 defaultVerificationDefaults :: VerificationDefaults defaultVerificationDefaults = 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. defaultDecryptPolicy :: DecryptPolicy defaultDecryptPolicy = 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. lenientDecryptPolicy :: DecryptPolicy lenientDecryptPolicy = DecryptPolicy { decryptAllowSEDNoIntegrity = True , decryptAllowSEIPDv1 = True , decryptAllowedSymmetricAlgos = Nothing , decryptAllowedAEADAlgos = Nothing , decryptRejectDeprecatedSKESK = False , decryptRejectTrailingData = False , decryptRejectESKVersionMismatch = False } supportsSEIPDv2Symmetric :: OpenPGPPolicy -> SymmetricAlgorithm -> Bool supportsSEIPDv2Symmetric policy sa = sa `elem` messageSEIPDv2SymmetricAlgorithms (policyMessageEncryption policy) secretKeyProtectionPolicyForKeyVersion :: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy secretKeyProtectionPolicyForKeyVersion policy V6 = policySecretKeyProtection policy secretKeyProtectionPolicyForKeyVersion _ _ = Nothing 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)) ecdhKdfHashDigest SHA384 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA384)) ecdhKdfHashDigest SHA512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA512)) ecdhKdfHashDigest SHA3_256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA3_256)) 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 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 ++ ")") 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 allowedTable30EcdhParameterSets _ _ = Nothing legacySecretKeyProtectionErrorMessage :: String legacySecretKeyProtectionErrorMessage = "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 -- | RFC9580 §3.2: Primary key can only have KeyRevocationSig or SignatureDirectlyOnAKey isAllowedPrimaryKeySig :: SignaturePayload -> Bool isAllowedPrimaryKeySig = maybe False isAllowedPrimaryKeySigType . sigType -- | RFC9580 §3.3: Subkey can only have SubkeyBindingSig or SubkeyRevocationSig isAllowedSubkeySig :: SignaturePayload -> Bool isAllowedSubkeySig = maybe False isAllowedSubkeySigType . sigType -- | RFC9580 §3.4: User ID can only have various certification types or CertRevocationSig isAllowedUIDSig :: SignaturePayload -> Bool isAllowedUIDSig = maybe False isAllowedUIDSigType . sigType -- | Test if a SigType is allowed on a primary key isAllowedPrimaryKeySigType :: SigType -> Bool isAllowedPrimaryKeySigType KeyRevocationSig = True isAllowedPrimaryKeySigType SignatureDirectlyOnAKey = True isAllowedPrimaryKeySigType _ = False -- | Test if a SigType is allowed on a subkey isAllowedSubkeySigType :: SigType -> Bool isAllowedSubkeySigType SubkeyBindingSig = True isAllowedSubkeySigType SubkeyRevocationSig = True isAllowedSubkeySigType _ = False -- | Test if a SigType is allowed on a User ID isAllowedUIDSigType :: SigType -> Bool isAllowedUIDSigType GenericCert = True isAllowedUIDSigType PersonaCert = True isAllowedUIDSigType CasualCert = True isAllowedUIDSigType PositiveCert = True isAllowedUIDSigType CertRevocationSig = True isAllowedUIDSigType _ = False hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/S2K.hs0000644000000000000000000002363307346545000017045 0ustar0000000000000000-- S2K.hs: OpenPGP (RFC9580) string-to-key conversion -- Copyright © 2013-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} module Codec.Encryption.OpenPGP.S2K ( EncodedSessionKeyError(..) , renderEncodedSessionKeyError , S2KError(..) , renderS2KError , decodeOpenPGPEncodedSessionKey , string2Key , skesk2Key , skesk2SessionKey ) where import Codec.Encryption.OpenPGP.BlockCipher (CipherError(..), keySize, withSymmetricCipher) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..)) import Codec.Encryption.OpenPGP.Types import Data.Bits (shiftL) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Word (Word8, Word16) import Crypto.Error (CryptoFailable(..)) import qualified Crypto.Hash as CH import qualified Crypto.KDF.Argon2 as Argon2 import qualified Data.ByteArray as BA import Data.Bifunctor (first) data EncodedSessionKeyError = EncodedSessionKeyTooShort | EncodedSessionKeyUnsupportedAlgorithm SymmetricAlgorithm | EncodedSessionKeyLengthMismatch SymmetricAlgorithm Int Int | EncodedSessionKeyChecksumMismatch deriving (Eq, Show) renderEncodedSessionKeyError :: EncodedSessionKeyError -> String renderEncodedSessionKeyError EncodedSessionKeyTooShort = "session key material too short" renderEncodedSessionKeyError (EncodedSessionKeyUnsupportedAlgorithm sa) = "unsupported symmetric algorithm: " ++ show sa renderEncodedSessionKeyError (EncodedSessionKeyLengthMismatch _ _ _) = "session key material length does not match encoded algorithm" renderEncodedSessionKeyError EncodedSessionKeyChecksumMismatch = "session key checksum mismatch" -- | Errors that can arise during string-to-key derivation. data S2KError = -- | The symmetric algorithm used in the SKESK is not supported. S2KUnsupportedAlgorithm CipherError | -- | An unsupported or unknown S2K specifier type was encountered. S2KUnsupportedSpecifier Word8 | -- | An unsupported SKESK shape (e.g. non-zero ESK). S2KUnsupportedSKESKShape String | -- | A required hash algorithm is not supported for S2K. S2KUnsupportedHashAlgorithm HashAlgorithm | -- | The Argon2 S2K parameters are invalid. S2KArgon2ParamError String | -- | The Argon2 KDF itself failed. S2KArgon2Failed String | -- | Decrypting an embedded encrypted session key failed. S2KEncryptedSessionKeyCipherError CipherError | -- | Embedded encrypted session key material was malformed. S2KEncryptedSessionKeyDecodeError EncodedSessionKeyError deriving (Eq, Show) renderS2KError :: S2KError -> String renderS2KError (S2KUnsupportedAlgorithm ce) = "S2K: " ++ renderCipherError' ce where renderCipherError' (UnsupportedAlgorithm sa) = "unsupported symmetric algorithm: " ++ show sa renderCipherError' (CipherInitFailed sa msg) = "cipher init failed for " ++ show sa ++ ": " ++ msg renderCipherError' (CipherOperationFailed msg) = "cipher operation failed: " ++ msg renderS2KError (S2KUnsupportedSpecifier t) = "S2K: unsupported S2K type " ++ show t renderS2KError (S2KUnsupportedSKESKShape msg) = "S2K: unsupported SKESK shape: " ++ msg renderS2KError (S2KUnsupportedHashAlgorithm ha) = "S2K: unsupported hash algorithm for S2K: " ++ show ha renderS2KError (S2KArgon2ParamError msg) = "S2K: Argon2 parameter error: " ++ msg renderS2KError (S2KArgon2Failed msg) = "S2K: Argon2 KDF failed: " ++ msg renderS2KError (S2KEncryptedSessionKeyCipherError ce) = "S2K: encrypted session key decrypt failed: " ++ renderCipherError' ce where renderCipherError' (UnsupportedAlgorithm sa) = "unsupported symmetric algorithm: " ++ show sa renderCipherError' (CipherInitFailed sa msg) = "cipher init failed for " ++ show sa ++ ": " ++ msg renderCipherError' (CipherOperationFailed msg) = "cipher operation failed: " ++ msg renderS2KError (S2KEncryptedSessionKeyDecodeError err) = "S2K: encrypted session key decode failed: " ++ renderEncodedSessionKeyError err string2Key :: S2K -> Int -> BL.ByteString -> Either S2KError B.ByteString string2Key (Simple ha) ksz bs = B.take (fromIntegral ksz) <$> hashpp ha ksz bs string2Key (Salted ha salt) ksz bs = string2Key (Simple ha) ksz (BL.append (BL.fromStrict (unSalt8 salt)) bs) string2Key (IteratedSalted ha salt cnt) ksz bs = string2Key (Simple ha) ksz (BL.take (fromIntegral cnt) . BL.cycle $ BL.append (BL.fromStrict (unSalt8 salt)) bs) string2Key (Argon2 salt t p encodedM) ksz pass = argon2String2Key salt t p encodedM ksz pass string2Key (OtherS2K t _) _ _ = Left (S2KUnsupportedSpecifier t) skesk2Key :: SKESK 'SKESKV4 -> BL.ByteString -> Either S2KError B.ByteString skesk2Key skesk pass = snd <$> skesk2SessionKey skesk pass skesk2SessionKey :: SKESK 'SKESKV4 -> BL.ByteString -> Either S2KError (SymmetricAlgorithm, B.ByteString) skesk2SessionKey (SKESK4Packet sa s2k Nothing) pass = do keyLen <- first S2KUnsupportedAlgorithm (keySize sa) sessionKey <- string2Key s2k keyLen pass pure (sa, sessionKey) skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) pass = do keyLen <- first S2KUnsupportedAlgorithm (keySize sa) kek <- string2Key s2k keyLen pass decrypted <- first S2KEncryptedSessionKeyCipherError $ withSymmetricCipher sa kek (\cipher -> paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) (BL.toStrict esk)) first S2KEncryptedSessionKeyDecodeError (decodeSKESK4EncryptedSessionKey decrypted) decodeOpenPGPEncodedSessionKey :: B.ByteString -> Either EncodedSessionKeyError (SymmetricAlgorithm, B.ByteString) decodeOpenPGPEncodedSessionKey encodedSessionKey = do if B.length encodedSessionKey < 3 then Left EncodedSessionKeyTooShort else Right () let symalgo = toFVal (B.head encodedSessionKey) rest = B.tail encodedSessionKey keyLen <- encodedSessionKeyKeyLength symalgo if B.length rest < keyLen + 2 then Left (EncodedSessionKeyLengthMismatch symalgo keyLen (B.length rest)) else Right () let (sessionKey, restAfterKey) = B.splitAt keyLen rest checksumBytes = B.take 2 restAfterKey actualChecksum = checksum16 sessionKey expectedChecksum = fromIntegral (B.index checksumBytes 0) `shiftL` 8 + fromIntegral (B.index checksumBytes 1) if actualChecksum /= expectedChecksum then Left EncodedSessionKeyChecksumMismatch else Right (symalgo, sessionKey) decodeSKESK4EncryptedSessionKey :: B.ByteString -> Either EncodedSessionKeyError (SymmetricAlgorithm, B.ByteString) decodeSKESK4EncryptedSessionKey encodedSessionKey = do if B.length encodedSessionKey < 1 then Left EncodedSessionKeyTooShort else Right () let symalgo = toFVal (B.head encodedSessionKey) sessionKey = B.tail encodedSessionKey keyLen <- encodedSessionKeyKeyLength symalgo if B.length sessionKey /= keyLen then Left (EncodedSessionKeyLengthMismatch symalgo keyLen (B.length sessionKey)) else Right (symalgo, sessionKey) encodedSessionKeyKeyLength :: SymmetricAlgorithm -> Either EncodedSessionKeyError Int encodedSessionKeyKeyLength symalgo = first renderKeySizeError (keySize symalgo) where renderKeySizeError :: CipherError -> EncodedSessionKeyError renderKeySizeError (UnsupportedAlgorithm sa) = EncodedSessionKeyUnsupportedAlgorithm sa renderKeySizeError (CipherInitFailed sa _) = EncodedSessionKeyUnsupportedAlgorithm sa renderKeySizeError (CipherOperationFailed _) = EncodedSessionKeyUnsupportedAlgorithm symalgo checksum16 :: B.ByteString -> Word16 checksum16 = fromIntegral . B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0 argon2String2Key :: Salt16 -> Word8 -> Word8 -> Word8 -> Int -> BL.ByteString -> Either S2KError B.ByteString argon2String2Key salt t p encodedM keyLen pass | t == 0 = Left (S2KArgon2ParamError "Argon2 S2K pass count must be non-zero") | p == 0 = Left (S2KArgon2ParamError "Argon2 S2K parallelism must be non-zero") | encodedM > 31 = Left (S2KArgon2ParamError "Argon2 S2K encoded_m must be <= 31") | encodedM < minEncodedM = Left (S2KArgon2ParamError "Argon2 S2K encoded_m is too small for parallelism") | otherwise = case Argon2.hash opts (BL.toStrict pass) (unSalt16 salt) keyLen of CryptoPassed k -> Right k CryptoFailed e -> Left (S2KArgon2Failed (show e)) where opts = Argon2.defaultOptions { Argon2.iterations = fromIntegral t , Argon2.memory = fromIntegral (1 `shiftL` fromIntegral encodedM :: Int) , Argon2.parallelism = fromIntegral p , Argon2.variant = Argon2.Argon2id , Argon2.version = Argon2.Version13 } minEncodedM = fromIntegral (3 + ceilLog2 (fromIntegral p :: Int)) ceilLog2 :: Int -> Int ceilLog2 n | n <= 1 = 0 | otherwise = go 0 1 where go e v | v >= n = e | otherwise = go (e + 1) (v * 2) hashpp :: HashAlgorithm -> Int -> BL.ByteString -> Either S2KError B.ByteString hashpp ha keysize pp = go 0 B.empty where go ctr acc | B.length acc >= keysize = Right acc | otherwise = do digest <- hf ha (nulpad ctr `BL.append` pp) go (ctr + 1) (acc `B.append` digest) nulpad = BL.pack . flip replicate 0 hf :: HashAlgorithm -> BL.ByteString -> Either S2KError B.ByteString hf DeprecatedMD5 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.MD5)) hf SHA1 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA1)) hf SHA224 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA224)) hf SHA256 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA256)) hf SHA384 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA384)) hf SHA512 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA512)) hf SHA3_256 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA3_256)) hf SHA3_512 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA3_512)) hf (OtherHA ha') _ = Left (S2KUnsupportedHashAlgorithm (OtherHA ha')) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/SecretKey.hs0000644000000000000000000006530007346545000020341 0ustar0000000000000000-- SecretKey.hs: OpenPGP (RFC9580) secret key encryption/decryption -- Copyright © 2013-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE GADTs #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE TypeApplications #-} module Codec.Encryption.OpenPGP.SecretKey ( decryptPrivateKey , reinterpretUnknownSKeyForPKPayload , mkUnencryptedSKAddendum , encryptPrivateKeyWithPolicyAndSaltAndIV , encryptPrivateKey , changePrivateKeyPassphrase , changePrivateKeyPassphraseRandom , changeSecretKeyPassphrase , changeSecretKeyPassphraseRandom , reencryptSecretKeyRandomEither , reencryptPrivateKeyTyped ) where import Codec.Encryption.OpenPGP.BlockCipher (renderCipherError, keySize) import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce) import Codec.Encryption.OpenPGP.Internal.RFC7253OCB ( decryptWithOCBRFC7253With , encryptWithOCBRFC7253 ) import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher) import Codec.Encryption.OpenPGP.Policy ( OpenPGPPolicy(..) , OpenPGPRFC(..) , SecretKeyProtectionPolicy , defaultPolicy , legacySecretKeyProtectionErrorMessage , secretKeyAEADNonceOctets , secretKeyDefaultAEADAlgorithm , secretKeyDefaultS2KForSalt , secretKeyDefaultSymmetricAlgorithm , secretKeyProtectionPolicyForKeyVersion , secretKeyS2KSaltOctets ) import Codec.Encryption.OpenPGP.S2K ( renderS2KError , skesk2Key , string2Key ) import Codec.Encryption.OpenPGP.Serialize (getSecretKey, putSKeyForPKPayload) import Codec.Encryption.OpenPGP.Types 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.ModArithmetic (inverse) import Crypto.Number.Serialize (os2ip) import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.RSA as R import Crypto.Random.Types (MonadRandom, getRandomBytes) import Control.Monad (when) import Data.Bifunctor (bimap, first) import Data.Binary (put) import Data.Binary.Get (getRemainingLazyByteString, getWord16be, runGetOrFail) import Data.Binary.Put (Put, putByteString, putLazyByteString, putWord16be, runPut) import qualified Data.ByteArray as BA import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import Data.List (nub) import Data.Word (Word8, Word16) decryptPrivateKey :: (SomePKPayload, SKAddendum) -> BL.ByteString -> Either String SKAddendum decryptPrivateKey (pkp, ska) pp = case fromSKAddendumForPKPayload pkp ska of Left err -> Left err Right (SomeSKAddendumV skaV) -> toSKAddendum <$> decryptPrivateKeyTyped pkp skaV pp decryptPrivateKeyTyped :: SomePKPayload -> SKAddendumV v -> BL.ByteString -> Either String (SKAddendumV v) decryptPrivateKeyTyped pkp (SKA16bit sa s2k iv payload) pp = do (sk, cksum) <- decryptS2KProtectedPayload pkp sa s2k iv payload pp parse16BitProtectedSecretKey pure (SKAUnencryptedLegacy sk cksum) decryptPrivateKeyTyped pkp (SKASHA1Legacy sa s2k iv payload) pp = do (sk, cksum) <- decryptS2KProtectedPayload pkp sa s2k iv payload pp parseSHA1ProtectedSecretKey pure (SKAUnencryptedLegacy sk cksum) decryptPrivateKeyTyped pkp (SKASHA1V6 sa s2k iv payload) pp = do (sk, _) <- decryptS2KProtectedPayload pkp sa s2k iv payload pp parseSHA1ProtectedSecretKey pure (SKAUnencryptedV6 sk) decryptPrivateKeyTyped pkp (SKAAEADV6 sa aa s2k iv payload) pp = do sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp pure (SKAUnencryptedV6 sk) decryptPrivateKeyTyped pkp (SKAAEADLegacy sa aa s2k iv payload) pp = do sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp pure (SKAUnencryptedLegacy sk 0) decryptPrivateKeyTyped pkp (SKASymLegacy sa iv payload) pp = do keyLen <- first renderCipherError (keySize sa) dek <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp) p <- first renderCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek) (sk, cksum) <- parse16BitProtectedSecretKey pkp p pure (SKAUnencryptedLegacy sk cksum) decryptPrivateKeyTyped pkp (SKASymV6 sa iv payload) pp = do keyLen <- first renderCipherError (keySize sa) dek <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp) p <- first renderCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek) (sk, _) <- parse16BitProtectedSecretKey pkp p pure (SKAUnencryptedV6 sk) decryptPrivateKeyTyped _ ska@(SKAUnencryptedLegacy {}) _ = Right ska decryptPrivateKeyTyped _ ska@(SKAUnencryptedV6 {}) _ = Right ska reinterpretUnknownSKeyForPKPayload :: SomePKPayload -> SKey -> Either String SKey reinterpretUnknownSKeyForPKPayload _ sk@RSAPrivateKey {} = Right sk reinterpretUnknownSKeyForPKPayload _ sk@DSAPrivateKey {} = Right sk reinterpretUnknownSKeyForPKPayload _ sk@ElGamalPrivateKey {} = Right sk reinterpretUnknownSKeyForPKPayload _ sk@ECDHPrivateKey {} = Right sk reinterpretUnknownSKeyForPKPayload _ sk@ECDSAPrivateKey {} = Right sk reinterpretUnknownSKeyForPKPayload _ sk@EdDSAPrivateKey {} = Right sk reinterpretUnknownSKeyForPKPayload _ sk@X25519PrivateKey {} = Right sk reinterpretUnknownSKeyForPKPayload _ sk@X448PrivateKey {} = Right sk reinterpretUnknownSKeyForPKPayload pkp (UnknownSKey payload) = case runGetOrFail ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString) payload of Left (_, _, err) -> Left err Right (_, _, (skey, trailing)) | BL.null trailing -> Right skey | otherwise -> Left "decoded secret key material has trailing bytes" mkUnencryptedSKAddendum :: SomePKPayload -> SKey -> Either String SKAddendum mkUnencryptedSKAddendum pkp skey = do payload <- legacySecretKeyPayload pkp skey let checksum = case _keyVersion pkp of V6 -> 0 _ -> checksum16 (BL.toStrict payload) pure (SUUnencrypted skey checksum) decryptS2KProtectedPayload :: SomePKPayload -> SymmetricAlgorithm -> S2K -> IV -> BL.ByteString -> BL.ByteString -> (SomePKPayload -> B.ByteString -> Either String (SKey, Word16)) -> Either String (SKey, Word16) decryptS2KProtectedPayload pkp sa s2k iv payload pp parser = do dek <- first renderS2KError (skesk2Key (SKESK4Packet sa s2k Nothing) pp) decrypted <- first renderCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek) parser pkp decrypted parse16BitProtectedSecretKey :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16) parse16BitProtectedSecretKey pkp p | B.length p < 2 = Left "secret key payload is too short for a 16-bit checksum" | otherwise = do let (skeyPayload, checksumPayload) = B.splitAt (B.length p - 2) p sk <- decodeSecretKey pkp skeyPayload cksum <- decodeChecksum checksumPayload let expected = checksum16 skeyPayload if cksum == expected then Right (sk, cksum) else Left ("16-bit secret key checksum mismatch (expected " ++ show expected ++ ", got " ++ show cksum ++ ")") parseSHA1ProtectedSecretKey :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16) parseSHA1ProtectedSecretKey pkp p | B.length p < 20 = Left "secret key payload is too short for a SHA1 checksum" | otherwise = do let (skeyPayload, hashPayload) = B.splitAt (B.length p - 20) p expected = BA.convert (CH.hash skeyPayload :: CH.Digest CH.SHA1) sk <- decodeSecretKey pkp skeyPayload if hashPayload == expected then Right (sk, checksum16 skeyPayload) else Left "SHA1 secret key checksum mismatch" decodeSecretKey :: SomePKPayload -> B.ByteString -> Either String SKey decodeSecretKey pkp payloadBytes = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail (getSecretKey pkp) (BL.fromStrict payloadBytes)) decodeChecksum :: B.ByteString -> Either String Word16 decodeChecksum checksumBytes = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail getWord16be (BL.fromStrict checksumBytes)) decryptAEADPayloadCore :: SomePKPayload -> SymmetricAlgorithm -> AEADAlgorithm -> S2K -> IV -> BL.ByteString -> BL.ByteString -> Either String SKey decryptAEADPayloadCore pkp sa aa s2k iv payload pp = do keyLen <- first renderCipherError (keySize sa) keyMaterial <- first renderS2KError (string2Key s2k keyLen pp) let keyCandidates = [keyMaterial] tagCandidates = [0xC5, 0xC7, 0x94, 0x95, 0x96, 0x97, 0x9C, 0x9D, 0x9E, 0x9F] infoCandidates = nub [ B.pack [tag, keyVersionByte (_keyVersion pkp), fromFVal sa, fromFVal aa] | tag <- tagCandidates ] pkpBytes = BL.toStrict (runPut (put pkp)) adCandidates = nub [B.cons tagByte pkpBytes | tagByte <- tagCandidates] aaCandidates = [aa] nonce = unIV iv payloadStrict = BL.toStrict payload tagLen = 16 tryDecrypt candidateKeyMaterial info ad aaTry = do when (B.length payloadStrict < tagLen) $ Left "v6 AEAD secret key payload too short" let (ciphertext, tagBytes) = B.splitAt (B.length payloadStrict - tagLen) payloadStrict authTag = CCT.AuthTag (BA.convert tagBytes) prk = extract @CHA.SHA256 B.empty candidateKeyMaterial kekCandidates = nub [ B.take keyLen candidateKeyMaterial , (expand @CHA.SHA256 prk info keyLen :: B.ByteString) , (expand @CHA.SHA256 prk B.empty keyLen :: B.ByteString) ] tryKeks = go Nothing where go merr [] = Left $ "could not decrypt using any KEK candidate" ++ maybe "" (\e -> " (last error: " ++ e ++ ")") merr go merr (kek:ks) = case decryptWithKey sa aaTry kek ad nonce ciphertext authTag of Right cleartext -> Right cleartext Left err -> go (Just (maybe err id merr)) ks tryKeks kekCandidates tryAll = go Nothing where go merr [] = Left $ "could not decrypt v6 AEAD secret key payload" ++ maybe "" (\e -> " (last error: " ++ e ++ ")") merr go merr ((keyMaterialCandidate, info, ad, aaTry):xs) = case tryDecrypt keyMaterialCandidate info ad aaTry of Right cleartext -> Right cleartext Left err -> go (Just (maybe err id merr)) xs cleartext <- tryAll [ (k, i, a, m) | k <- keyCandidates , i <- infoCandidates , a <- adCandidates , m <- aaCandidates ] parseSecretKeyExact pkp cleartext checksum16 :: B.ByteString -> Word16 checksum16 = fromIntegral . B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0 decryptWithKey :: SymmetricAlgorithm -> AEADAlgorithm -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> CCT.AuthTag -> Either String B.ByteString decryptWithKey sa aa kek ad nonce ciphertext authTag = do let toHex = BC.unpack . B16.encode authFailure expectedTag computedTag n a hashAd plaintext = "failed to authenticate v6 AEAD secret key payload (expected tag=" ++ toHex expectedTag ++ ", computed tag=" ++ toHex computedTag ++ ", nonce=" ++ toHex n ++ ", ad=" ++ toHex a ++ ", hashAd=" ++ toHex hashAd ++ ", plaintext=" ++ toHex plaintext ++ ")" unsupportedSecretKeyAEADError = "unsupported secret-key AEAD symmetric algorithm" case aa of OCB -> withAESCipher unsupportedSecretKeyAEADError sa kek (\cipher -> decryptWithOCBRFC7253With authFailure cipher nonce ad ciphertext authTag) _ -> do mode <- aeadMode aa expectedNonceLen <- aeadNonceSize aa when (B.length nonce /= expectedNonceLen) $ Left "invalid nonce size for v6 AEAD secret key payload" withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher -> first show (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead -> maybe (Left "failed to authenticate v6 AEAD secret key payload") Right (CCT.aeadSimpleDecrypt aead ad ciphertext authTag) aeadMode :: AEADAlgorithm -> Either String CCT.AEADMode aeadMode EAX = Right CCT.AEAD_EAX aeadMode OCB = Right CCT.AEAD_OCB aeadMode GCM = Right CCT.AEAD_GCM aeadMode (OtherAEADAlgo _) = Left "unknown AEAD mode" aeadNonceSize :: AEADAlgorithm -> Either String Int aeadNonceSize EAX = Right 16 aeadNonceSize OCB = Right 15 aeadNonceSize GCM = Right 12 aeadNonceSize (OtherAEADAlgo _) = Left "unknown AEAD nonce size" parseSecretKeyExact :: SomePKPayload -> B.ByteString -> Either String SKey parseSecretKeyExact pkp cleartext = case runGetOrFail ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString) (BL.fromStrict cleartext) of Left (_, _, err) -> Left err Right (_, _, (sk, trailing)) | BL.null trailing -> Right sk | otherwise -> Left "v6 AEAD secret key cleartext has trailing bytes" keyVersionByte :: KeyVersion -> Word8 keyVersionByte DeprecatedV3 = 3 keyVersionByte V4 = 4 keyVersionByte V6 = 6 -- |generates pseudo-random salt and IV encryptPrivateKey :: MonadRandom m => OpenPGPPolicy -> SomePKPayload -> SKAddendum -> BL.ByteString -> m (Either String SKAddendum) encryptPrivateKey policy pkp ska pp = do nextMaterial <- generateSecretKeyProtectionMaterial policy pkp pure $ do (salt, iv) <- nextMaterial encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp encryptPrivateKeyWithPolicyAndSaltAndIV :: OpenPGPPolicy -> SomePKPayload -> Salt -> IV -> SKAddendum -> BL.ByteString -> Either String SKAddendum encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp = case ska of SUUnencrypted skey _ -> encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey pp _ -> Right ska encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV :: OpenPGPPolicy -> SomePKPayload -> Salt -> IV -> SKey -> BL.ByteString -> Either String SKAddendum encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey pp = do (sa, aa, s2k) <- secretKeyProtectionDefaults policy pkp salt iv (\payload -> SUSAEAD sa aa s2k iv (BL.fromStrict payload)) <$> encryptV6SKey pkp skey sa aa s2k iv pp changePrivateKeyPassphrase :: (SomePKPayload, SKAddendum) -> BL.ByteString -> Salt -> IV -> BL.ByteString -> Either String SKAddendum changePrivateKeyPassphrase (pkp, ska) oldPassphrase salt iv newPassphrase = do decrypted <- decryptPrivateKey (pkp, ska) oldPassphrase case decrypted of SUUnencrypted skey _ -> reencryptPrivateKeyWithSaltAndIV pkp ska salt iv skey newPassphrase _ -> Left "Unexpected codepath: decrypted private key material was not in unencrypted form" changePrivateKeyPassphraseRandom :: MonadRandom m => (SomePKPayload, SKAddendum) -> BL.ByteString -> BL.ByteString -> m (Either String SKAddendum) changePrivateKeyPassphraseRandom (pkp, ska) oldPassphrase newPassphrase = do nextMaterial <- generateSecretKeyProtectionMaterial defaultPolicy pkp pure $ do (salt, iv) <- nextMaterial changePrivateKeyPassphrase (pkp, ska) oldPassphrase salt iv newPassphrase changeSecretKeyPassphrase :: SecretKey -> BL.ByteString -> Salt -> IV -> BL.ByteString -> Either String SecretKey changeSecretKeyPassphrase sk oldPassphrase salt iv newPassphrase = do ska <- changePrivateKeyPassphrase (_secretKeyPKPayload sk, _secretKeySKAddendum sk) oldPassphrase salt iv newPassphrase return sk {_secretKeySKAddendum = ska} changeSecretKeyPassphraseRandom :: MonadRandom m => SecretKey -> BL.ByteString -> BL.ByteString -> m (Either String SecretKey) changeSecretKeyPassphraseRandom sk oldPassphrase newPassphrase = do nextSKA <- changePrivateKeyPassphraseRandom (_secretKeyPKPayload sk, _secretKeySKAddendum sk) oldPassphrase newPassphrase pure ((\ska -> sk {_secretKeySKAddendum = ska}) <$> nextSKA) encodeSKeyMaterial :: SKey -> Either String BL.ByteString encodeSKeyMaterial keyMaterial = case keyMaterial of RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _)) -> case inverse p q of Nothing -> Left "could not derive RSA multiplicative inverse while encrypting secret key" Just u -> Right (runPut (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u))) DSAPrivateKey (DSA_PrivateKey (DSA.PrivateKey _ x)) -> Right (runPut (put (MPI x))) ElGamalPrivateKey x -> Right (runPut (put (MPI x))) ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d)) -> Right (runPut (put (MPI d))) ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d)) -> Right (runPut (put (MPI d))) EdDSAPrivateKey _ bs -> Right (runPut (put (MPI (os2ip bs)))) X25519PrivateKey bs -> Right (runPut (putByteString bs)) X448PrivateKey bs -> Right (runPut (putByteString bs)) UnknownSKey bs -> Right (runPut (putLazyByteString bs)) encryptV6SKey :: SomePKPayload -> SKey -> SymmetricAlgorithm -> AEADAlgorithm -> S2K -> IV -> BL.ByteString -> Either String B.ByteString encryptV6SKey pkp skey sa aa s2k iv pp = do keyLen <- first renderCipherError (keySize sa) keyMaterial <- first renderS2KError (string2Key s2k keyLen pp) payload <- encodeSKeyMaterial skey let info = B.pack [0xC5, keyVersionByte (_keyVersion pkp), fromFVal sa, fromFVal aa] ad = B.cons 0xC5 (BL.toStrict (runPut (put pkp))) prk = extract @CHA.SHA256 B.empty keyMaterial kek = expand @CHA.SHA256 prk info keyLen :: B.ByteString (tag, ciphertext) <- encryptWithKey sa aa kek ad (unIV iv) (BL.toStrict payload) pure (ciphertext <> BA.convert (CCT.unAuthTag tag)) secretKeyProtectionMaterialLengths :: OpenPGPPolicy -> SomePKPayload -> Either String (Int, Int) secretKeyProtectionMaterialLengths policy pkp = case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of Just policy -> Right (secretKeyS2KSaltOctets policy, secretKeyAEADNonceOctets policy) Nothing -> Left legacySecretKeyProtectionErrorMessage generateSecretKeyProtectionMaterial :: MonadRandom m => OpenPGPPolicy -> SomePKPayload -> m (Either String (Salt, IV)) generateSecretKeyProtectionMaterial policy pkp = case secretKeyProtectionMaterialLengths policy pkp of Left err -> pure (Left err) Right (saltLen, nonceLen) -> do entropy <- getRandomBytes (saltLen + nonceLen) let (saltBytes, ivBytes) = B.splitAt saltLen entropy pure (Right (Salt saltBytes, IV ivBytes)) secretKeyProtectionDefaults :: OpenPGPPolicy -> SomePKPayload -> Salt -> IV -> Either String (SymmetricAlgorithm, AEADAlgorithm, S2K) secretKeyProtectionDefaults policy pkp salt iv = case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of Just policy -> do when (B.length (unSalt salt) /= secretKeyS2KSaltOctets policy) $ Left ("v6 secret key S2K salt must be " ++ show (secretKeyS2KSaltOctets policy) ++ " octets") when (B.length (unIV iv) /= secretKeyAEADNonceOctets policy) $ Left ("v6 secret key AEAD nonce must be " ++ show (secretKeyAEADNonceOctets policy) ++ " octets") pure ( secretKeyDefaultSymmetricAlgorithm policy , secretKeyDefaultAEADAlgorithm policy , secretKeyDefaultS2KForSalt policy salt ) Nothing -> Left legacySecretKeyProtectionErrorMessage secretKeyProtectionPolicyForEncryption :: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy secretKeyProtectionPolicyForEncryption policy V6 = secretKeyProtectionPolicyForKeyVersion policy V6 secretKeyProtectionPolicyForEncryption policy _ | policyRFC policy == RFC9580 = Nothing | otherwise = policySecretKeyProtection policy encryptWithKey :: SymmetricAlgorithm -> AEADAlgorithm -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString -> Either String (CCT.AuthTag, B.ByteString) encryptWithKey sa aa kek ad nonce plaintext = do expectedNonceLen <- aeadNonceSize aa when (B.length nonce /= expectedNonceLen) $ Left "invalid nonce size for v6 AEAD secret key payload" let unsupportedSecretKeyAEADError = "unsupported secret-key AEAD symmetric algorithm" case aa of OCB -> withAESCipher unsupportedSecretKeyAEADError sa kek (\cipher -> encryptWithOCBRFC7253 cipher nonce ad plaintext) _ -> do mode <- aeadMode aa withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher -> first show (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead -> pure (CCT.aeadSimpleEncrypt aead ad plaintext 16) reencryptSecretKeyRandomEither :: MonadRandom m => SecretKey -> BL.ByteString -> m (Either String SecretKey) reencryptSecretKeyRandomEither sk pp = changeSecretKeyPassphraseRandom sk pp pp -- | Version-preserving re-encryption of a typed secret-key addendum. -- -- Each constructor family is re-encrypted in kind: -- * V6 variants (AEAD, SHA1, Sym, Unencrypted) → SKAAEADV6 (default v6 policy) -- * SKA16bit / SKASHA1Legacy → same S2K family with updated salt -- * SKAAEADLegacy → re-protected as SKASHA1Legacy (standard v3\/v4 S2K) -- * SKASymLegacy → legacy CFB re-encryption as SKASymLegacy -- * SKAUnencryptedLegacy → Left (cannot re-encrypt unencrypted legacy keys) reencryptPrivateKeyTyped :: SomePKPayload -> SKAddendumV v -> Salt -> IV -> SKey -> BL.ByteString -> Either String (SKAddendumV v) reencryptPrivateKeyTyped pkp skaV salt iv skey pp = case skaV of SKAAEADV6 {} -> reencryptV6 SKASHA1V6 {} -> reencryptV6 SKASymV6 {} -> reencryptV6 SKAUnencryptedV6 {} -> reencryptV6 SKA16bit sa s2k _ _ -> reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km -> encryptProtectedSecretKey sa' s2k' iv' ct km checksum16Trailer (SKA16bit sa' s2k' iv') SKASHA1Legacy sa s2k _ _ -> reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km -> encryptProtectedSecretKey sa' s2k' iv' ct km sha1Trailer (SKASHA1Legacy sa' s2k' iv') SKAAEADLegacy sa _aa s2k _ _ -> reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km -> encryptProtectedSecretKey sa' s2k' iv' ct km sha1Trailer (SKASHA1Legacy sa' s2k' iv') SKASymLegacy sa _ _ -> do keyLen <- first renderCipherError (keySize sa) keyMaterial <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp) cleartext <- legacySecretKeyPayload pkp skey let clearWithChecksum = BL.toStrict (cleartext <> runPut (putWord16be (checksum16 (BL.toStrict cleartext)))) (\encrypted -> SKASymLegacy sa iv (BL.fromStrict encrypted)) <$> first renderCipherError (encryptNoNonce sa (Simple DeprecatedMD5) iv clearWithChecksum keyMaterial) SKAUnencryptedLegacy _ _ -> Left legacySecretKeyProtectionErrorMessage where reencryptV6 = do (sa, aa, s2k) <- secretKeyProtectionDefaults defaultPolicy pkp salt iv (\payload -> SKAAEADV6 sa aa s2k iv (BL.fromStrict payload)) <$> encryptV6SKey pkp skey sa aa s2k iv pp reencryptPrivateKeyWithSaltAndIV :: SomePKPayload -> SKAddendum -> Salt -> IV -> SKey -> BL.ByteString -> Either String SKAddendum reencryptPrivateKeyWithSaltAndIV pkp originalSka salt iv skey pp = case fromSKAddendumForPKPayload pkp originalSka of Left err -> Left err Right (SomeSKAddendumV skaV) -> toSKAddendum <$> reencryptPrivateKeyTyped pkp skaV salt iv skey pp reencryptS2KProtectedSecretKey :: SomePKPayload -> Salt -> IV -> SKey -> BL.ByteString -> SymmetricAlgorithm -> S2K -> (SymmetricAlgorithm -> S2K -> IV -> BL.ByteString -> B.ByteString -> Either String r) -> Either String r reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k encryptFn = do keyLen <- first renderCipherError (keySize sa) let retargetedS2K = retargetS2K salt s2k keyMaterial <- first renderS2KError (string2Key retargetedS2K keyLen pp) cleartext <- legacySecretKeyPayload pkp skey encryptFn sa retargetedS2K iv cleartext keyMaterial encryptLegacyCFBSecretKey :: SomePKPayload -> SymmetricAlgorithm -> IV -> SKey -> BL.ByteString -> Either String SKAddendum encryptLegacyCFBSecretKey pkp sa iv skey pp = do keyLen <- first renderCipherError (keySize sa) keyMaterial <- first renderS2KError (string2Key (Simple DeprecatedMD5) keyLen pp) cleartext <- legacySecretKeyPayload pkp skey let clearWithChecksum = BL.toStrict (cleartext <> runPut (putWord16be (checksum16 (BL.toStrict cleartext)))) (\encrypted -> SUSym sa iv (BL.fromStrict encrypted)) <$> first renderCipherError (encryptNoNonce sa (Simple DeprecatedMD5) iv clearWithChecksum keyMaterial) encrypt16BitProtectedSecretKey :: SymmetricAlgorithm -> S2K -> IV -> BL.ByteString -> B.ByteString -> Either String SKAddendum encrypt16BitProtectedSecretKey sa s2k iv cleartext keyMaterial = encryptProtectedSecretKey sa s2k iv cleartext keyMaterial checksum16Trailer (\payload -> SUS16bit sa s2k iv payload) encryptSHA1ProtectedSecretKey :: SymmetricAlgorithm -> S2K -> IV -> BL.ByteString -> B.ByteString -> Either String SKAddendum encryptSHA1ProtectedSecretKey sa s2k iv cleartext keyMaterial = encryptProtectedSecretKey sa s2k iv cleartext keyMaterial sha1Trailer (\payload -> SUSSHA1 sa s2k iv payload) encryptProtectedSecretKey :: SymmetricAlgorithm -> S2K -> IV -> BL.ByteString -> B.ByteString -> (BL.ByteString -> BL.ByteString) -> (BL.ByteString -> r) -> Either String r encryptProtectedSecretKey sa s2k iv cleartext keyMaterial checksumTrailer mkAddendum = do let clearWithChecksum = BL.toStrict (cleartext <> checksumTrailer cleartext) encrypted <- first renderCipherError (encryptNoNonce sa s2k iv clearWithChecksum keyMaterial) pure (mkAddendum (BL.fromStrict encrypted)) checksum16Trailer :: BL.ByteString -> BL.ByteString checksum16Trailer cleartext = runPut (putWord16be (checksum16 (BL.toStrict cleartext))) sha1Trailer :: BL.ByteString -> BL.ByteString sha1Trailer cleartext = BL.fromStrict (BA.convert (CH.hash (BL.toStrict cleartext) :: CH.Digest CH.SHA1)) legacySecretKeyPayload :: SomePKPayload -> SKey -> Either String BL.ByteString legacySecretKeyPayload pkp skey = runPut <$> putSKeyForPKPayload pkp skey retargetS2K :: Salt -> S2K -> S2K retargetS2K salt (Salted ha oldSalt) = maybe (Salted ha oldSalt) (Salted ha) (salt8FromSalt salt) retargetS2K salt (IteratedSalted ha oldSalt cnt) = maybe (IteratedSalted ha oldSalt cnt) (\salt8 -> IteratedSalted ha salt8 cnt) (salt8FromSalt salt) retargetS2K _ s2k = s2k hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Serialize.hs0000644000000000000000000033407507346545000020402 0ustar0000000000000000-- Serialize.hs: OpenPGP (RFC9580) serialization (using binary) -- 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) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/SerializeForSigs.hs0000644000000000000000000002327007346545000021667 0ustar0000000000000000-- SerializeForSigs.hs: OpenPGP (RFC9580) special serialization for signature purposes -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} module Codec.Encryption.OpenPGP.SerializeForSigs ( putPKPforFingerprinting , putPartialSigforSigning , putSigTrailer , putUforSigning , putUIDforSigning , putUAtforSigning , putKeyforSigning , putSigforSigning , payloadForSig , payloadForSigWith ) where import Control.Lens ((^.)) import Crypto.Number.Serialize (i2osp) import Data.Binary (put) import Data.Binary.Put ( Put , putByteString , putLazyByteString , putWord16be , putWord32be , putWord8 , runPut ) import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Text.Encoding (encodeUtf8) import Data.Word (Word8) import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), pubkeyToMPIs) import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Subpackets (TextNormalizationMode(..)) import Codec.Encryption.OpenPGP.Types data SignatureSerializationCase where SignatureSerializationCaseV4 :: SignaturePayloadV 'SigPayloadV4 -> SignatureSerializationCase SignatureSerializationCaseV6 :: SignaturePayloadV 'SigPayloadV6 -> SignatureSerializationCase fromPktSignatureSerializationCase :: Pkt -> Maybe SignatureSerializationCase fromPktSignatureSerializationCase pkt = case fromPktEitherSomeSignatureV pkt of Right (SomeSignatureV (SignatureV4Packet payload)) -> Just (SignatureSerializationCaseV4 payload) Right (SomeSignatureV (SignatureV6Packet payload)) -> Just (SignatureSerializationCaseV6 payload) _ -> Nothing putPartialSigforSigningCase :: SignatureSerializationCase -> Put putPartialSigforSigningCase (SignatureSerializationCaseV4 (SigPayloadV4Data st pka ha hashed _ _ _)) = do putWord8 4 put st put pka put ha let hb = runPut $ mapM_ put hashed putWord16be . fromIntegral . BL.length $ hb putLazyByteString hb putPartialSigforSigningCase (SignatureSerializationCaseV6 (SigPayloadV6Data st pka ha _salt hashed _ _ _)) = do putWord8 6 put st put pka put ha let hb = runPut $ mapM_ put hashed putWord32be . fromIntegral . BL.length $ hb putLazyByteString hb putSigTrailerCase :: SignatureSerializationCase -> Put putSigTrailerCase (SignatureSerializationCaseV4 (SigPayloadV4Data _ _ _ hs _ _ _)) = do putWord8 0x04 putWord8 0xff putWord32be . fromIntegral . (+ 6) . BL.length $ runPut $ mapM_ put hs -- this +6 seems like a bug in RFC4880 putSigTrailerCase signatureCase@(SignatureSerializationCaseV6 _) = do putWord8 0x06 putWord8 0xff putWord32be . fromIntegral . (+ 6) . BL.length $ runPut (putPartialSigforSigningCase signatureCase) putSigforSigningCase :: SignatureSerializationCase -> Put putSigforSigningCase (SignatureSerializationCaseV4 (SigPayloadV4Data st pka ha hashed _ left16 mpis)) = do putWord8 0x88 let bs = runPut $ put (SigV4 st pka ha hashed [] left16 mpis) putWord32be . fromIntegral . BL.length $ bs putLazyByteString bs putSigforSigningCase (SignatureSerializationCaseV6 (SigPayloadV6Data st pka ha salt hashed _ left16 mpis)) = do putWord8 0xC2 let bs = runPut $ put (SigV6 st pka ha salt hashed [] left16 mpis) putWord32be . fromIntegral . BL.length $ bs putLazyByteString bs putPKPforFingerprinting :: Pkt -> Put putPKPforFingerprinting (PublicKeyPkt (PKPayload DeprecatedV3 _ _ _ pk)) = mapM_ putMPIforFingerprinting (pubkeyToMPIs pk) putPKPforFingerprinting (PublicKeyPkt pkp@(PKPayload V4 _ _ _ _)) = do putWord8 0x99 let bs = runPut $ put pkp putWord16be . fromIntegral $ BL.length bs putLazyByteString bs putPKPforFingerprinting (PublicKeyPkt pkp@(PKPayload V6 _ _ _ _)) = do putWord8 0x9B let bs = runPut $ put pkp putWord32be . fromIntegral $ BL.length bs putLazyByteString bs putPKPforFingerprinting _ = error "This should never happen (putPKPforFingerprinting)" putMPIforFingerprinting :: MPI -> Put putMPIforFingerprinting (MPI i) = let bs = i2osp i in putByteString bs putPartialSigforSigning :: Pkt -> Put putPartialSigforSigning pkt = case fromPktSignatureSerializationCase pkt of Just signatureCase -> putPartialSigforSigningCase signatureCase Nothing -> error ("putPartialSigforSigning: unsupported signature packet version: " ++ show (pktTag pkt)) putSigTrailer :: Pkt -> Put putSigTrailer pkt = case fromPktSignatureSerializationCase pkt of Just signatureCase -> putSigTrailerCase signatureCase Nothing -> error "This should never happen (putSigTrailer)" putUforSigning :: Pkt -> Put putUforSigning u@(UserIdPkt _) = putUIDforSigning u putUforSigning u@(UserAttributePkt _) = putUAtforSigning u putUforSigning _ = error "This should never happen (putUforSigning)" putUIDforSigning :: Pkt -> Put putUIDforSigning (UserIdPkt u) = do putWord8 0xB4 let bs = encodeUtf8 u putWord32be . fromIntegral . B.length $ bs putByteString bs putUIDforSigning _ = error "This should never happen (putUIDforSigning)" putUAtforSigning :: Pkt -> Put putUAtforSigning (UserAttributePkt us) = do putWord8 0xD1 let bs = runPut (mapM_ put us) putWord32be . fromIntegral . BL.length $ bs putLazyByteString bs putUAtforSigning _ = error "This should never happen (putUAtforSigning)" putSigforSigning :: Pkt -> Put putSigforSigning pkt = case fromPktSignatureSerializationCase pkt of Just signatureCase -> putSigforSigningCase signatureCase Nothing -> error ("putSigforSigning: unsupported signature packet version: " ++ show (pktTag pkt)) putKeyforSigning :: Pkt -> Put putKeyforSigning (PublicKeyPkt pkp) = putKeyForSigning' pkp putKeyforSigning (PublicSubkeyPkt pkp) = putKeyForSigning' pkp putKeyforSigning (SecretKeyPkt pkp _) = putKeyForSigning' pkp putKeyforSigning (SecretSubkeyPkt pkp _) = putKeyForSigning' pkp putKeyforSigning x = error ("This should never happen (putKeyforSigning) " ++ show (pktTag x) ++ "/" ++ show x) putKeyForSigning' :: SomePKPayload -> Put putKeyForSigning' pkp@(PKPayload V6 _ _ _ _) = do putWord8 0x9B let bs = runPut $ put pkp putWord32be . fromIntegral . BL.length $ bs putLazyByteString bs putKeyForSigning' pkp = do putWord8 0x99 let bs = runPut $ put pkp putWord16be . fromIntegral . BL.length $ bs putLazyByteString bs payloadForSig :: SigType -> PktStreamContext -> ByteString payloadForSig BinarySig state = case (fromPktEither (lastLD state) :: Either String LiteralData) of Right ld -> ld ^. literalDataPayload Left err -> error ("payloadForSig expected literal data packet: " ++ err) payloadForSig CanonicalTextSig state = stripTrailingWhitespacePerLine (canonicalizeLineEndings (payloadForSig BinarySig state)) payloadForSig StandaloneSig _ = BL.empty payloadForSig GenericCert state = kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) payloadForSig PersonaCert state = payloadForSig GenericCert state payloadForSig CasualCert state = payloadForSig GenericCert state payloadForSig PositiveCert state = payloadForSig GenericCert state payloadForSig SubkeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig PrimaryKeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig SignatureDirectlyOnAKey state = runPut (putKeyforSigning (lastPrimaryKey state)) payloadForSig KeyRevocationSig state = payloadForSig SignatureDirectlyOnAKey state payloadForSig SubkeyRevocationSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig CertRevocationSig state = -- RFC 9580 §5.2.1: 0x30 revokes a UID certification when a UID/UAt is in -- scope, but when there is no UID/UAt in scope it revokes a direct-key sig -- (0x1F) and the payload is just the primary key material. case lastUIDorUAt state of UserIdPkt _ -> kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) UserAttributePkt _ -> kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) _ -> runPut (putKeyforSigning (lastPrimaryKey state)) payloadForSig st _ = error ("payloadForSig: unhandled signature type " ++ show st) -- | Like 'payloadForSig' but accepts an explicit 'TextNormalizationMode' -- that controls whether trailing whitespace is stripped for CanonicalTextSig. -- -- Use 'RFC9580Strict' for inline type 0x01 document signatures. -- Use 'CleartextCompat' (or 'payloadForSig') for cleartext-armored messages. payloadForSigWith :: TextNormalizationMode -> SigType -> PktStreamContext -> ByteString payloadForSigWith RFC9580Strict CanonicalTextSig state = canonicalizeLineEndings (payloadForSig BinarySig state) payloadForSigWith _ st state = payloadForSig st state 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 kandUPayload :: Pkt -> Pkt -> ByteString kandUPayload k u = runPut (sequence_ [putKeyforSigning k, putUforSigning u]) kandKPayload :: Pkt -> Pkt -> ByteString kandKPayload k1 k2 = runPut (sequence_ [putKeyforSigning k1, putKeyforSigning k2]) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/SignatureQualities.hs0000644000000000000000000000703107346545000022262 0ustar0000000000000000-- SignatureQualities.hs: OpenPGP (RFC9580) signature qualities -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} module Codec.Encryption.OpenPGP.SignatureQualities ( sigType , sigPKA , sigHA , sigCT , signatureSubpacketListsKnown , signatureHashedSubpacketsKnown ) where import Data.List (find) import Codec.Encryption.OpenPGP.Ontology (isSigCreationTime) import Codec.Encryption.OpenPGP.Types data KnownSignaturePayload where KnownSignaturePayloadV3 :: SignaturePayloadV 'SigPayloadV3 -> KnownSignaturePayload KnownSignaturePayloadV4 :: SignaturePayloadV 'SigPayloadV4 -> KnownSignaturePayload KnownSignaturePayloadV6 :: SignaturePayloadV 'SigPayloadV6 -> KnownSignaturePayload knownSignaturePayload :: SignaturePayload -> Maybe KnownSignaturePayload knownSignaturePayload sig = case toSomeSignaturePayload sig of SomeSignaturePayload (payload@SigPayloadV3Data {}) -> Just (KnownSignaturePayloadV3 payload) SomeSignaturePayload (payload@SigPayloadV4Data {}) -> Just (KnownSignaturePayloadV4 payload) SomeSignaturePayload (payload@SigPayloadV6Data {}) -> Just (KnownSignaturePayloadV6 payload) SomeSignaturePayload (SigPayloadOtherData _ _) -> Nothing sigType :: SignaturePayload -> Maybe SigType sigType sig = case knownSignaturePayload sig of Just (KnownSignaturePayloadV3 (SigPayloadV3Data st _ _ _ _ _ _)) -> Just st Just (KnownSignaturePayloadV4 (SigPayloadV4Data st _ _ _ _ _ _)) -> Just st Just (KnownSignaturePayloadV6 (SigPayloadV6Data st _ _ _ _ _ _ _)) -> Just st Nothing -> Nothing sigPKA :: SignaturePayload -> Maybe PubKeyAlgorithm sigPKA sig = case knownSignaturePayload sig of Just (KnownSignaturePayloadV3 (SigPayloadV3Data _ _ _ pka _ _ _)) -> Just pka Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ pka _ _ _ _ _)) -> Just pka Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ pka _ _ _ _ _ _)) -> Just pka Nothing -> Nothing sigHA :: SignaturePayload -> Maybe HashAlgorithm sigHA sig = case knownSignaturePayload sig of Just (KnownSignaturePayloadV3 (SigPayloadV3Data _ _ _ _ ha _ _)) -> Just ha Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ _ ha _ _ _ _)) -> Just ha Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ _ ha _ _ _ _ _)) -> Just ha Nothing -> Nothing sigCT :: SignaturePayload -> Maybe ThirtyTwoBitTimeStamp sigCT sig = case knownSignaturePayload sig of Just (KnownSignaturePayloadV3 (SigPayloadV3Data _ ct _ _ _ _ _)) -> Just ct Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ _ _ hsubs _ _ _)) -> fmap (\(SigSubPacket _ (SigCreationTime i)) -> i) (find isSigCreationTime hsubs) Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ _ _ _ hsubs _ _ _)) -> fmap (\(SigSubPacket _ (SigCreationTime i)) -> i) (find isSigCreationTime hsubs) Nothing -> Nothing signatureSubpacketListsKnown :: SignaturePayload -> Maybe ([SigSubPacket], [SigSubPacket]) signatureSubpacketListsKnown sigPayload = case knownSignaturePayload sigPayload of Just (KnownSignaturePayloadV4 (SigPayloadV4Data _ _ _ hashed unhashed _ _)) -> Just (hashed, unhashed) Just (KnownSignaturePayloadV6 (SigPayloadV6Data _ _ _ _ hashed unhashed _ _)) -> Just (hashed, unhashed) _ -> Nothing signatureHashedSubpacketsKnown :: SignaturePayload -> Maybe [SigSubPacket] signatureHashedSubpacketsKnown sigPayload = fst <$> signatureSubpacketListsKnown sigPayload hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Signatures.hs0000644000000000000000000021063607346545000020573 0ustar0000000000000000-- 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 hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Subpackets.hs0000644000000000000000000004376307346545000020560 0ustar0000000000000000-- Subpackets.hs: Type-safe subpacket builders with phantom types -- 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 MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Codec.Encryption.OpenPGP.Subpackets ( -- * Safe subpacket construction SafeSubpacket , mkSafeSubpacket , safePayload , safeSubpacket -- * Critical subpacket handling , CriticalSubpacket , mkCritical , canBeCritical -- * Text normalization mode , TextNormalizationMode(..) -- * Builder API for signature composition , SigBuilder , LegalSubpacket(..) , legalSubpacket , singleLegalSub , consLegalSub , listToLegalSubs , sbSigType , sbPubKeyAlgo , sbHashAlgo , sbHashedSubs , sbUnhashedSubs , sbSalt , sbTextNormMode , buildSigV4 , buildSigV6 , sigBuilderInit , sigBuilderInitTyped , sigBuilderInitRuntime , sigBuilderInitV6 , sigBuilderInitV6Typed , sigBuilderInitV6Runtime , addHashedSubs , addUnhashedSubs , KnownPubKeyAlgorithm(..) -- * Private key wrapper (algorithm-specific) , PrivateKeyFor(..) -- * Subpacket list utilities , HashedSubpackets , UnhashedSubpackets , consHashedSub , singleHashedSub , singleUnhashedSub , listToHashedSubs , listToUnhashedSubs ) where import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty) import Data.Proxy (Proxy(..)) import Data.Word (Word16) 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.Types as RSATypes import Codec.Encryption.OpenPGP.Types ( Hashed , Unhashed , V4Sig , V6Sig , Fingerprint , EightOctetKeyId , ThirtyTwoBitTimeStamp , MPI , SigSubPacket(..) , SigSubPacketPayload(..) , SignaturePayload(..) , SignatureSalt , SigType , HashAlgorithm , SubpacketList(..) ) import Codec.Encryption.OpenPGP.Types.Internal.Base ( PubKeyAlgorithm(..) , IssuerFingerprintVersion(..) ) import Codec.Encryption.OpenPGP.Policy ( HashAlgoAllowedFor , OpenPGPRFC , OpenPGPRFCW(..) , SomeOpenPGPRFCW(..) , HashAlgorithmW(..) , SomeHashAlgorithmW(..) , promoteOpenPGPRFC , promoteHashAlgorithm , demoteHashAlgorithmW , policyForRFC , policyGenerationDeprecations , deprecatedHashAlgorithms ) -- | Type alias for readability: hashed subpacket list type HashedSubpackets v = SubpacketList Hashed v -- | Type alias for readability: unhashed subpacket list type UnhashedSubpackets v = SubpacketList Unhashed v -- | A subpacket that has passed basic safety checks -- (does not guarantee it's critical-safe; use CriticalSubpacket for that) newtype SafeSubpacket = SafeSubpacket SigSubPacket deriving (Eq, Ord, Show) -- | Create a safe subpacket from a payload and criticality flag -- Basic validation that the payload is well-formed mkSafeSubpacket :: Bool -> SigSubPacketPayload -> Either String SafeSubpacket mkSafeSubpacket crit payload = do -- Validate criticality constraints: some subpackets should never be critical if crit && not (canBeCritical payload) then Left $ "Subpacket type cannot be marked critical: " ++ show payload else Right (SafeSubpacket (SigSubPacket crit payload)) -- | Extract the payload from a safe subpacket safePayload :: SafeSubpacket -> SigSubPacketPayload safePayload (SafeSubpacket (SigSubPacket _ payload)) = payload -- | Extract the underlying SigSubPacket from a safe subpacket safeSubpacket :: SafeSubpacket -> SigSubPacket safeSubpacket (SafeSubpacket ssp) = ssp -- | A subpacket that is guaranteed to be both well-formed AND can be safely marked critical -- Used to prevent accidentally marking non-critical-safe types as critical newtype CriticalSubpacket = CriticalSubpacket SigSubPacket deriving (Eq, Ord, Show) -- | Create a critical subpacket only if the payload type allows it -- RFC9580 section 5.2.3.5: only certain subpacket types can be marked critical mkCritical :: SigSubPacketPayload -> Either String CriticalSubpacket mkCritical payload | canBeCritical payload = Right $ CriticalSubpacket (SigSubPacket True payload) | otherwise = Left $ "Cannot mark as critical: " ++ payloadType payload where payloadType (SigCreationTime _) = "SigCreationTime" payloadType (SigExpirationTime _) = "SigExpirationTime" payloadType (ExportableCertification _) = "ExportableCertification" payloadType (TrustSignature {}) = "TrustSignature" payloadType (RegularExpression _) = "RegularExpression" payloadType (Revocable _) = "Revocable" payloadType (KeyExpirationTime _) = "KeyExpirationTime" payloadType (PreferredSymmetricAlgorithms _) = "PreferredSymmetricAlgorithms" payloadType (RevocationKey {}) = "RevocationKey" payloadType (Issuer _) = "Issuer" payloadType (NotationData {}) = "NotationData" payloadType (PreferredHashAlgorithms _) = "PreferredHashAlgorithms" payloadType (PreferredCompressionAlgorithms _) = "PreferredCompressionAlgorithms" payloadType (KeyServerPreferences _) = "KeyServerPreferences" payloadType (PreferredKeyServer _) = "PreferredKeyServer" payloadType (PrimaryUserId _) = "PrimaryUserId" payloadType (PolicyURL _) = "PolicyURL" payloadType (KeyFlags _) = "KeyFlags" payloadType (SignersUserId _) = "SignersUserId" payloadType (ReasonForRevocation {}) = "ReasonForRevocation" payloadType (Features _) = "Features" payloadType (SignatureTarget {}) = "SignatureTarget" payloadType (EmbeddedSignature _) = "EmbeddedSignature" payloadType (IssuerFingerprint {}) = "IssuerFingerprint" payloadType (UserDefinedSigSub _ _) = "UserDefinedSigSub" payloadType (OtherSigSub _ _) = "OtherSigSub" -- | RFC9580 §5.2.3.5 lists which subpacket types can be marked critical canBeCritical :: SigSubPacketPayload -> Bool canBeCritical KeyFlags {} = True canBeCritical IssuerFingerprint {} = True canBeCritical EmbeddedSignature {} = True -- Future-proofing: unknown critical types are allowed to be critical canBeCritical UserDefinedSigSub {} = True canBeCritical OtherSigSub {} = True canBeCritical _ = False -- | Wrapper GADT for algorithm-specific private keys -- Encodes the algorithm at the type level to ensure type-safe key/builder matching data PrivateKeyFor (algo :: PubKeyAlgorithm) where RSAPrivateKey :: RSATypes.PrivateKey -> PrivateKeyFor 'RSA Ed25519PrivateKey :: Ed25519.SecretKey -> PrivateKeyFor 'Ed25519 Ed448PrivateKey :: Ed448.SecretKey -> PrivateKeyFor 'Ed448 DSAPrivateKey :: DSA.PrivateKey -> PrivateKeyFor 'DSA ECDSAPrivateKey :: ECDSA.PrivateKey -> PrivateKeyFor 'ECDSA class KnownPubKeyAlgorithm (algo :: PubKeyAlgorithm) where demotePubKeyAlgorithmT :: Proxy algo -> PubKeyAlgorithm instance KnownPubKeyAlgorithm 'RSA where demotePubKeyAlgorithmT _ = RSA instance KnownPubKeyAlgorithm 'DSA where demotePubKeyAlgorithmT _ = DSA instance KnownPubKeyAlgorithm 'ECDSA where demotePubKeyAlgorithmT _ = ECDSA instance KnownPubKeyAlgorithm 'EdDSA where demotePubKeyAlgorithmT _ = EdDSA instance KnownPubKeyAlgorithm 'Ed25519 where demotePubKeyAlgorithmT _ = Ed25519 instance KnownPubKeyAlgorithm 'Ed448 where demotePubKeyAlgorithmT _ = Ed448 -- | Legal subpackets encoded by placement and signature-version constraints. -- This expands compile-time legality beyond bare hashed/unhashed staging. data LegalSubpacket (h :: Type) (v :: Type) where -- RFC9580: signature creation time is a hashed subpacket. LegalSigCreationTime :: ThirtyTwoBitTimeStamp -> LegalSubpacket Hashed v -- v4 signatures use an issuer fingerprint subpacket with version marker 4 in hashed area. LegalIssuerFingerprintV4 :: Fingerprint -> LegalSubpacket Hashed V4Sig -- v6 signatures use an issuer fingerprint subpacket with version marker 6 in hashed area. LegalIssuerFingerprintV6 :: Fingerprint -> LegalSubpacket Hashed V6Sig -- Legacy issuer key ID subpacket is accepted only in v4 and only unhashed. LegalIssuerV4 :: EightOctetKeyId -> LegalSubpacket Unhashed V4Sig legalSubpacket :: LegalSubpacket h v -> SigSubPacket legalSubpacket (LegalSigCreationTime ts) = SigSubPacket False (SigCreationTime ts) legalSubpacket (LegalIssuerFingerprintV4 fp) = SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 fp) legalSubpacket (LegalIssuerFingerprintV6 fp) = SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 fp) legalSubpacket (LegalIssuerV4 keyId) = SigSubPacket False (Issuer keyId) singleLegalSub :: LegalSubpacket h v -> SubpacketList h v singleLegalSub = SubpacketList . (: []) . legalSubpacket consLegalSub :: LegalSubpacket h v -> SubpacketList h v -> SubpacketList h v consLegalSub legal (SubpacketList sps) = SubpacketList (legalSubpacket legal : sps) listToLegalSubs :: [LegalSubpacket h v] -> SubpacketList h v listToLegalSubs = SubpacketList . fmap legalSubpacket -- | Construct a single hashed subpacket into a hashed subpacket list singleHashedSub :: SigSubPacket -> HashedSubpackets v singleHashedSub sp = SubpacketList [sp] -- | Construct a single unhashed subpacket into an unhashed subpacket list singleUnhashedSub :: SigSubPacket -> UnhashedSubpackets v singleUnhashedSub sp = SubpacketList [sp] -- | Prepend a subpacket to a hashed subpacket list consHashedSub :: SigSubPacket -> HashedSubpackets v -> HashedSubpackets v consHashedSub sp (SubpacketList sps) = SubpacketList (sp : sps) -- | Controls how text payload is normalized for CanonicalTextSig. -- -- RFC 9580 §5.2.1.2 requires only CRLF normalization for type 0x01 -- signatures. Trailing-whitespace stripping is only mandated by -- §7 (Cleartext Signature Framework). Use 'CleartextCompat' for -- GnuPG-compatible behaviour when producing cleartext-armored -- signatures; use 'RFC9580Strict' for inline text signatures. data TextNormalizationMode = RFC9580Strict -- ^ CRLF normalization only; no trailing-whitespace stripping. -- Correct for inline type 0x01 document signatures. | CleartextCompat -- ^ CRLF normalization *plus* per-line trailing-whitespace stripping. -- Required by the Cleartext Signature Framework (RFC 9580 §7). deriving (Eq, Show) -- | Staged signature builder that enforces completion order -- -- Usage pattern: -- builder <- sigBuilderInit SigTypeBinary RSA SHA256 -- builder' <- addHashedSubs hashedList builder -- finalPayload <- buildSigV4 sigMPIs (addUnhashedSubs unhashedList builder') data SigBuilder (hashedness :: Type) (v :: Type) (algo :: PubKeyAlgorithm) = SigBuilder { sbSigType :: SigType , sbHashAlgo :: HashAlgorithm , sbHashedSubs :: [SigSubPacket] , sbUnhashedSubs :: [SigSubPacket] , sbSalt :: BuilderSalt v , sbTextNormMode :: TextNormalizationMode -- ^ Normalization mode for CanonicalTextSig payloads. -- Defaults to 'CleartextCompat' for backward compatibility. } type family BuilderSalt (v :: Type) where BuilderSalt V4Sig = () BuilderSalt V6Sig = SignatureSalt sbPubKeyAlgo :: forall hashedness v algo. KnownPubKeyAlgorithm algo => SigBuilder hashedness v algo -> PubKeyAlgorithm sbPubKeyAlgo _ = demotePubKeyAlgorithmT (Proxy @algo) -- | Initialize a builder for a v4 signature -- Starts with no subpackets and must call addHashedSubs and addUnhashedSubs sigBuilderInit :: forall algo . KnownPubKeyAlgorithm algo => SigType -> HashAlgorithm -> SigBuilder Hashed V4Sig algo sigBuilderInit st ha = SigBuilder { sbSigType = st , sbHashAlgo = ha , sbHashedSubs = [] , sbUnhashedSubs = [] , sbSalt = () , sbTextNormMode = CleartextCompat } -- | Initialize a builder for a v4 signature with compile-time RFC/hash policy enforcement. sigBuilderInitTyped :: forall algo rfc h . (KnownPubKeyAlgorithm algo, HashAlgoAllowedFor rfc h) => OpenPGPRFCW rfc -> SigType -> HashAlgorithmW h -> SigBuilder Hashed V4Sig algo sigBuilderInitTyped _ st hashW = sigBuilderInit @algo st (demoteHashAlgorithmW hashW) -- | Initialize a v4 builder from runtime RFC/hash inputs with policy validation -- and witness promotion at the API boundary. sigBuilderInitRuntime :: forall algo . KnownPubKeyAlgorithm algo => OpenPGPRFC -> SigType -> HashAlgorithm -> Either String (SigBuilder Hashed V4Sig algo) sigBuilderInitRuntime rfc st ha = withGenerationHashWitness rfc ha (\rfcW hashW -> sigBuilderInitTyped @algo rfcW st hashW) -- | Initialize a builder for a v6 signature sigBuilderInitV6 :: forall algo . KnownPubKeyAlgorithm algo => SigType -> HashAlgorithm -> SignatureSalt -> SigBuilder Hashed V6Sig algo sigBuilderInitV6 st ha salt = SigBuilder { sbSigType = st , sbHashAlgo = ha , sbHashedSubs = [] , sbUnhashedSubs = [] , sbSalt = salt , sbTextNormMode = CleartextCompat } -- | Initialize a builder for a v6 signature with compile-time RFC/hash policy enforcement. sigBuilderInitV6Typed :: forall algo rfc h . (KnownPubKeyAlgorithm algo, HashAlgoAllowedFor rfc h) => OpenPGPRFCW rfc -> SigType -> HashAlgorithmW h -> SignatureSalt -> SigBuilder Hashed V6Sig algo sigBuilderInitV6Typed _ st hashW salt = sigBuilderInitV6 @algo st (demoteHashAlgorithmW hashW) salt -- | Initialize a v6 builder from runtime RFC/hash inputs with policy validation -- and witness promotion at the API boundary. sigBuilderInitV6Runtime :: forall algo . KnownPubKeyAlgorithm algo => OpenPGPRFC -> SigType -> HashAlgorithm -> SignatureSalt -> Either String (SigBuilder Hashed V6Sig algo) sigBuilderInitV6Runtime rfc st ha salt = withGenerationHashWitness rfc ha (\rfcW hashW -> sigBuilderInitV6Typed @algo rfcW st hashW salt) withGenerationHashWitness :: OpenPGPRFC -> HashAlgorithm -> (forall rfc h. HashAlgoAllowedFor rfc h => OpenPGPRFCW rfc -> HashAlgorithmW h -> a) -> Either String a withGenerationHashWitness rfc ha mk | ha `elem` deprecatedHashAlgorithms (policyGenerationDeprecations (policyForRFC rfc)) = Left (hashPolicyDisallowedMessage rfc ha) | otherwise = case promoteHashAlgorithm ha of Nothing -> Left (hashNotTypedBuilderMessage ha) Just (SomeHashAlgorithmW hashW) -> case promoteOpenPGPRFC rfc of SomeOpenPGPRFCW RFC2440W -> Right $ case hashW of DeprecatedMD5W -> mk RFC2440W DeprecatedMD5W SHA1W -> mk RFC2440W SHA1W RIPEMD160W -> mk RFC2440W RIPEMD160W SHA256W -> mk RFC2440W SHA256W SHA384W -> mk RFC2440W SHA384W SHA512W -> mk RFC2440W SHA512W SHA224W -> mk RFC2440W SHA224W SHA3_256W -> mk RFC2440W SHA3_256W SHA3_512W -> mk RFC2440W SHA3_512W SomeOpenPGPRFCW RFC4880W -> case hashW of SHA1W -> Right (mk RFC4880W SHA1W) RIPEMD160W -> Right (mk RFC4880W RIPEMD160W) SHA256W -> Right (mk RFC4880W SHA256W) SHA384W -> Right (mk RFC4880W SHA384W) SHA512W -> Right (mk RFC4880W SHA512W) SHA224W -> Right (mk RFC4880W SHA224W) SHA3_256W -> Right (mk RFC4880W SHA3_256W) SHA3_512W -> Right (mk RFC4880W SHA3_512W) DeprecatedMD5W -> Left (hashPolicyDisallowedMessage rfc ha) SomeOpenPGPRFCW RFC9580W -> case hashW of SHA256W -> Right (mk RFC9580W SHA256W) SHA384W -> Right (mk RFC9580W SHA384W) SHA512W -> Right (mk RFC9580W SHA512W) SHA224W -> Right (mk RFC9580W SHA224W) SHA3_256W -> Right (mk RFC9580W SHA3_256W) SHA3_512W -> Right (mk RFC9580W SHA3_512W) DeprecatedMD5W -> Left (hashPolicyDisallowedMessage rfc ha) SHA1W -> Left (hashPolicyDisallowedMessage rfc ha) RIPEMD160W -> Left (hashPolicyDisallowedMessage rfc ha) hashPolicyDisallowedMessage :: OpenPGPRFC -> HashAlgorithm -> String hashPolicyDisallowedMessage rfc ha = "signature hash algorithm disallowed by RFC policy (" ++ show rfc ++ "): " ++ show ha hashNotTypedBuilderMessage :: HashAlgorithm -> String hashNotTypedBuilderMessage ha = "signature hash algorithm is not supported by typed builder API: " ++ show ha -- | Add hashed subpackets to a builder -- Must be called before addUnhashedSubs addHashedSubs :: HashedSubpackets v -> SigBuilder Hashed v algo -> SigBuilder Unhashed v algo addHashedSubs (SubpacketList sps) builder = builder { sbHashedSubs = sps } -- | Add unhashed subpackets to a builder -- Must be called after addHashedSubs addUnhashedSubs :: UnhashedSubpackets v -> SigBuilder Unhashed v algo -> SigBuilder Unhashed v algo addUnhashedSubs (SubpacketList sps) builder = builder { sbUnhashedSubs = sps } -- | Build a v4 signature from a completed builder and MPI values buildSigV4 :: KnownPubKeyAlgorithm algo => SigBuilder Unhashed V4Sig algo -> Word16 -> NonEmpty MPI -> SignaturePayload buildSigV4 builder hashLeft mpis = SigV4 (sbSigType builder) (sbPubKeyAlgo builder) (sbHashAlgo builder) (sbHashedSubs builder) (sbUnhashedSubs builder) hashLeft mpis -- | Build a v6 signature from a completed builder and MPI values buildSigV6 :: KnownPubKeyAlgorithm algo => SigBuilder Unhashed V6Sig algo -> Word16 -> NonEmpty MPI -> SignaturePayload buildSigV6 builder hashLeft mpis = SigV6 (sbSigType builder) (sbPubKeyAlgo builder) (sbHashAlgo builder) (sbSalt builder) (sbHashedSubs builder) (sbUnhashedSubs builder) hashLeft mpis -- | Convert a list to a hashed subpacket list -- Used to bridge between list-based and phantom-typed APIs listToHashedSubs :: [SigSubPacket] -> HashedSubpackets v listToHashedSubs sps = SubpacketList sps -- | Convert a list to an unhashed subpacket list -- Used to bridge between list-based and phantom-typed APIs listToUnhashedSubs :: [SigSubPacket] -> UnhashedSubpackets v listToUnhashedSubs sps = SubpacketList sps hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Types.hs0000644000000000000000000000115707346545000017547 0ustar0000000000000000-- Types.hs: OpenPGP (RFC9580) data types -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Types ( module X ) where import Codec.Encryption.OpenPGP.Types.Internal.Base as X hiding (Ed25519, Ed448) 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 import Codec.Encryption.OpenPGP.Types.Internal.Pkt as X import Codec.Encryption.OpenPGP.Types.Internal.TK as X hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Types/Internal/0000755000000000000000000000000007346545000020763 5ustar0000000000000000hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Types/Internal/Base.hs0000644000000000000000000015057207346545000022203 0ustar0000000000000000-- Base.hs: OpenPGP (RFC9580) data types -- 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) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Types/Internal/CryptonNewtypes.hs0000644000000000000000000002100707346545000024514 0ustar0000000000000000-- CryptonNewtypes.hs: OpenPGP (RFC4880) newtype wrappers for some crypton types -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes where import GHC.Generics (Generic) import Control.Monad (mzero) 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 qualified Data.Aeson as A import Data.Data (Data) import Data.Hashable (Hashable(..)) import Data.Typeable (Typeable) import Prettyprinter (Pretty(..), (<+>), tupled) newtype DSA_PublicKey = DSA_PublicKey { unDSA_PublicKey :: DSA.PublicKey } deriving (Data, Eq, Generic, Show, Typeable) instance Ord DSA_PublicKey where compare (DSA_PublicKey (DSA.PublicKey p1 y1)) (DSA_PublicKey (DSA.PublicKey p2 y2)) = compare (DSA_Params p1) (DSA_Params p2) <> compare y1 y2 instance A.ToJSON DSA_PublicKey where toJSON (DSA_PublicKey (DSA.PublicKey p y)) = A.toJSON (DSA_Params p, y) instance Pretty DSA_PublicKey where pretty (DSA_PublicKey (DSA.PublicKey p y)) = pretty (DSA_Params p) <+> pretty y newtype RSA_PublicKey = RSA_PublicKey { unRSA_PublicKey :: RSA.PublicKey } deriving (Data, Eq, Generic, Show, Typeable) instance Ord RSA_PublicKey where compare (RSA_PublicKey (RSA.PublicKey size1 n1 e1)) (RSA_PublicKey (RSA.PublicKey size2 n2 e2)) = compare size1 size2 <> compare n1 n2 <> compare e1 e2 instance A.ToJSON RSA_PublicKey where toJSON (RSA_PublicKey (RSA.PublicKey size n e)) = A.toJSON (size, n, e) instance Pretty RSA_PublicKey where pretty (RSA_PublicKey (RSA.PublicKey size n e)) = pretty size <+> pretty n <+> pretty e newtype ECDSA_PublicKey = ECDSA_PublicKey { unECDSA_PublicKey :: ECDSA.PublicKey } deriving (Data, Eq, Generic, Show, Typeable) instance Ord ECDSA_PublicKey where compare (ECDSA_PublicKey (ECDSA.PublicKey curve1 q1)) (ECDSA_PublicKey (ECDSA.PublicKey curve2 q2)) = compareCurve curve1 curve2 <> compareECPoint q1 q2 instance A.ToJSON ECDSA_PublicKey where toJSON (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = A.toJSON (show curve, show q) instance Pretty ECDSA_PublicKey where pretty (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = pretty (show curve, show q) newtype DSA_PrivateKey = DSA_PrivateKey { unDSA_PrivateKey :: DSA.PrivateKey } deriving (Data, Eq, Generic, Show, Typeable) instance Ord DSA_PrivateKey where compare (DSA_PrivateKey (DSA.PrivateKey p1 x1)) (DSA_PrivateKey (DSA.PrivateKey p2 x2)) = compare (DSA_Params p1) (DSA_Params p2) <> compare x1 x2 instance A.ToJSON DSA_PrivateKey where toJSON (DSA_PrivateKey (DSA.PrivateKey p x)) = A.toJSON (DSA_Params p, x) instance Pretty DSA_PrivateKey where pretty (DSA_PrivateKey (DSA.PrivateKey p x)) = pretty (DSA_Params p, x) newtype RSA_PrivateKey = RSA_PrivateKey { unRSA_PrivateKey :: RSA.PrivateKey } deriving (Data, Eq, Generic, Show, Typeable) instance Ord RSA_PrivateKey where compare (RSA_PrivateKey (RSA.PrivateKey pub1 d1 p1 q1 dP1 dQ1 qinv1)) (RSA_PrivateKey (RSA.PrivateKey pub2 d2 p2 q2 dP2 dQ2 qinv2)) = compare (RSA_PublicKey pub1) (RSA_PublicKey pub2) <> compare d1 d2 <> compare p1 p2 <> compare q1 q2 <> compare dP1 dP2 <> compare dQ1 dQ2 <> compare qinv1 qinv2 instance A.ToJSON RSA_PrivateKey where toJSON (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = A.toJSON (RSA_PublicKey pub, d, p, q, dP, dQ, qinv) instance Pretty RSA_PrivateKey where pretty (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = pretty (RSA_PublicKey pub) <+> tupled (map pretty [d, p, q, dP, dQ, qinv]) newtype ECDSA_PrivateKey = ECDSA_PrivateKey { unECDSA_PrivateKey :: ECDSA.PrivateKey } deriving (Data, Eq, Generic, Show, Typeable) instance Ord ECDSA_PrivateKey where compare (ECDSA_PrivateKey (ECDSA.PrivateKey curve1 d1)) (ECDSA_PrivateKey (ECDSA.PrivateKey curve2 d2)) = compareCurve curve1 curve2 <> compare d1 d2 instance A.ToJSON ECDSA_PrivateKey where toJSON (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = A.toJSON (show curve, show d) instance Pretty ECDSA_PrivateKey where pretty (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = pretty (show curve, show d) newtype DSA_Params = DSA_Params { unDSA_Params :: DSA.Params } deriving (Data, Eq, Generic, Show, Typeable) instance Ord DSA_Params where compare (DSA_Params (DSA.Params p1 g1 q1)) (DSA_Params (DSA.Params p2 g2 q2)) = compare p1 p2 <> compare g1 g2 <> compare q1 q2 instance A.ToJSON DSA_Params where toJSON (DSA_Params (DSA.Params p g q)) = A.toJSON (p, g, q) instance Pretty DSA_Params where pretty (DSA_Params (DSA.Params p g q)) = pretty (p, g, q) instance Hashable DSA_Params where hashWithSalt s (DSA_Params (DSA.Params p g q)) = s `hashWithSalt` p `hashWithSalt` g `hashWithSalt` q instance Hashable DSA_PublicKey where hashWithSalt s (DSA_PublicKey (DSA.PublicKey p y)) = s `hashWithSalt` DSA_Params p `hashWithSalt` y instance Hashable DSA_PrivateKey where hashWithSalt s (DSA_PrivateKey (DSA.PrivateKey p x)) = s `hashWithSalt` DSA_Params p `hashWithSalt` x instance Hashable RSA_PublicKey where hashWithSalt s (RSA_PublicKey (RSA.PublicKey size n e)) = s `hashWithSalt` size `hashWithSalt` n `hashWithSalt` e instance Hashable RSA_PrivateKey where hashWithSalt s (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) = s `hashWithSalt` RSA_PublicKey pub `hashWithSalt` d `hashWithSalt` p `hashWithSalt` q `hashWithSalt` dP `hashWithSalt` dQ `hashWithSalt` qinv instance Hashable ECDSA_PublicKey where hashWithSalt s (ECDSA_PublicKey (ECDSA.PublicKey curve q)) = hashWithCurve s curve `hashWithECPoint` q instance Hashable ECDSA_PrivateKey where hashWithSalt s (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) = hashWithCurve s curve `hashWithSalt` d -- Structural helpers for ECCT types that lack Hashable/Ord instances. hashWithECPoint :: Int -> ECCT.Point -> Int hashWithECPoint s ECCT.PointO = s `hashWithSalt` (0 :: Int) hashWithECPoint s (ECCT.Point x y) = s `hashWithSalt` (1 :: Int) `hashWithSalt` x `hashWithSalt` y hashWithCurveCommon :: Int -> ECCT.CurveCommon -> Int hashWithCurveCommon s cc = hashWithECPoint (s `hashWithSalt` ECCT.ecc_a cc `hashWithSalt` ECCT.ecc_b cc) (ECCT.ecc_g cc) `hashWithSalt` ECCT.ecc_n cc `hashWithSalt` ECCT.ecc_h cc hashWithCurve :: Int -> ECCT.Curve -> Int hashWithCurve s (ECCT.CurveFP (ECCT.CurvePrime p cc)) = hashWithCurveCommon (s `hashWithSalt` (0 :: Int) `hashWithSalt` p) cc hashWithCurve s (ECCT.CurveF2m (ECCT.CurveBinary poly cc)) = hashWithCurveCommon (s `hashWithSalt` (1 :: Int) `hashWithSalt` poly) cc compareECPoint :: ECCT.Point -> ECCT.Point -> Ordering compareECPoint ECCT.PointO ECCT.PointO = EQ compareECPoint ECCT.PointO _ = LT compareECPoint _ ECCT.PointO = GT compareECPoint (ECCT.Point x1 y1) (ECCT.Point x2 y2) = compare x1 x2 <> compare y1 y2 compareCurveCommon :: ECCT.CurveCommon -> ECCT.CurveCommon -> Ordering compareCurveCommon cc1 cc2 = compare (ECCT.ecc_a cc1) (ECCT.ecc_a cc2) <> compare (ECCT.ecc_b cc1) (ECCT.ecc_b cc2) <> compareECPoint (ECCT.ecc_g cc1) (ECCT.ecc_g cc2) <> compare (ECCT.ecc_n cc1) (ECCT.ecc_n cc2) <> compare (ECCT.ecc_h cc1) (ECCT.ecc_h cc2) compareCurve :: ECCT.Curve -> ECCT.Curve -> Ordering compareCurve (ECCT.CurveFP (ECCT.CurvePrime p1 cc1)) (ECCT.CurveFP (ECCT.CurvePrime p2 cc2)) = compare p1 p2 <> compareCurveCommon cc1 cc2 compareCurve (ECCT.CurveF2m (ECCT.CurveBinary poly1 cc1)) (ECCT.CurveF2m (ECCT.CurveBinary poly2 cc2)) = compare poly1 poly2 <> compareCurveCommon cc1 cc2 compareCurve (ECCT.CurveFP _) (ECCT.CurveF2m _) = LT compareCurve (ECCT.CurveF2m _) (ECCT.CurveFP _) = GT newtype ECurvePoint = ECurvePoint { unECurvepoint :: ECCT.Point } deriving (Data, Eq, Generic, Show, Typeable) instance A.ToJSON ECurvePoint where toJSON (ECurvePoint (ECCT.Point x y)) = A.toJSON (x, y) toJSON (ECurvePoint ECCT.PointO) = A.toJSON "point at infinity" instance A.FromJSON ECurvePoint where parseJSON v = case A.fromJSON v :: A.Result (Integer, Integer) of A.Success (x, y) -> pure (ECurvePoint (ECCT.Point x y)) A.Error _ -> case A.fromJSON v :: A.Result String of A.Success "point at infinity" -> pure (ECurvePoint ECCT.PointO) _ -> mzero hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs0000644000000000000000000004532207346545000022775 0ustar0000000000000000-- PKITypes.hs: OpenPGP (RFC9580) data types for public/secret keys -- 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 KindSignatures #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} 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 qualified Data.Data as DData import Data.Hashable (Hashable(..)) import Data.Ord (comparing) import Data.Typeable (Typeable) import Data.Word (Word16) import Prettyprinter (Pretty(..), (<+>)) data EdSigningCurve = Ed25519 | Ed448 deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Hashable EdSigningCurve instance Pretty EdSigningCurve where pretty Ed25519 = pretty "Ed25519" pretty Ed448 = pretty "Ed448" instance A.FromJSON EdSigningCurve instance A.ToJSON EdSigningCurve newtype EPoint = EPoint { unEPoint :: Integer } deriving (Data, Eq, Generic, Ord, Pretty, Show, Typeable) instance Hashable EPoint instance A.FromJSON EPoint instance A.ToJSON EPoint data EdPoint = 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 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) 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) 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) 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) 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) 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) data PKPayload (v :: KeyVersion) where 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 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 instance A.ToJSON (PKPayload v) where toJSON = A.toJSON . pkPayloadFields data SomePKPayload where 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] 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 instance Eq SomePKPayload where a == b = somePKPayloadFields a == somePKPayloadFields b instance Ord SomePKPayload where compare = comparing somePKPayloadFields instance Hashable SomePKPayload where 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 instance A.ToJSON SomePKPayload where toJSON = A.toJSON . somePKPayloadFields 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 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) {-# COMPLETE PKPayload #-} _keyVersion :: SomePKPayload -> KeyVersion _keyVersion (PKPayload kv _ _ _ _) = kv _timestamp :: SomePKPayload -> ThirtyTwoBitTimeStamp _timestamp (PKPayload _ ts _ _ _) = ts _v3exp :: SomePKPayload -> V3Expiration _v3exp (PKPayload _ _ v3e _ _) = v3e _pkalgo :: SomePKPayload -> PubKeyAlgorithm _pkalgo (PKPayload _ _ _ pka _) = pka _pubkey :: SomePKPayload -> PKey _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) 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 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 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) class LegacyKeyVersion (v :: KeyVersion) instance LegacyKeyVersion 'DeprecatedV3 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 deriving instance Show (SKAddendumV v) data SomeSKAddendumV where SomeSKAddendumV :: SKAddendumV v -> SomeSKAddendumV deriving instance Show SomeSKAddendumV toSKAddendum :: SKAddendumV v -> SKAddendum toSKAddendum (SKA16bit sa s2k iv bs) = SUS16bit sa s2k iv bs toSKAddendum (SKASHA1Legacy sa s2k iv bs) = SUSSHA1 sa s2k iv bs toSKAddendum (SKASHA1V6 sa s2k iv bs) = SUSSHA1 sa s2k iv bs toSKAddendum (SKAAEADV6 sa aa s2k iv bs) = SUSAEAD sa aa s2k iv bs toSKAddendum (SKAAEADLegacy sa aa s2k iv bs) = SUSAEAD sa aa s2k iv bs toSKAddendum (SKASymLegacy sa iv bs) = SUSym sa iv bs toSKAddendum (SKASymV6 sa iv bs) = SUSym sa iv bs toSKAddendum (SKAUnencryptedLegacy sk checksum) = SUUnencrypted sk checksum toSKAddendum (SKAUnencryptedV6 sk) = SUUnencrypted sk 0 fromSKAddendumForKeyVersion :: KeyVersion -> SKAddendum -> Either String SomeSKAddendumV fromSKAddendumForKeyVersion DeprecatedV3 (SUS16bit sa s2k iv bs) = 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)) fromSKAddendumForKeyVersion DeprecatedV3 (SUSym sa iv bs) = Right (SomeSKAddendumV (SKASymLegacy sa iv bs :: SKAddendumV 'DeprecatedV3)) fromSKAddendumForKeyVersion DeprecatedV3 (SUUnencrypted sk checksum) = 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)) fromSKAddendumForKeyVersion V4 (SUS16bit sa s2k iv bs) = 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)) fromSKAddendumForKeyVersion V4 (SUSym sa iv bs) = Right (SomeSKAddendumV (SKASymLegacy sa iv bs :: SKAddendumV 'V4)) fromSKAddendumForKeyVersion V4 (SUUnencrypted sk checksum) = 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)) fromSKAddendumForKeyVersion V6 (SUS16bit _ _ _ _) = 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)) fromSKAddendumForKeyVersion V6 (SUSAEAD 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)) fromSKAddendumForKeyVersion V6 (SUUnencrypted sk _) = Right (SomeSKAddendumV (SKAUnencryptedV6 sk)) fromSKAddendumForPKPayload :: SomePKPayload -> SKAddendum -> Either String SomeSKAddendumV fromSKAddendumForPKPayload pkp = fromSKAddendumForKeyVersion (_keyVersion pkp) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs0000644000000000000000000005116107346545000023520 0ustar0000000000000000-- PacketClass.hs: OpenPGP (RFC9580) data types -- 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 ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} 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 Data.List.NonEmpty (NonEmpty) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Word (Word8) import qualified Data.Kind import Prettyprinter (Pretty(..)) 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 coercionError :: String -> Pkt -> Either String a coercionError expected 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 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 instance Pretty (PKESK 'PKESKV3) where 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 instance Pretty (PKESK 'PKESKV6) where pretty = pretty . toPkt newtype Signature = Signature { _signaturePayload :: SignaturePayload } 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 instance Pretty Signature where 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 deriving instance Eq (SignatureV v) deriving instance Show (SignatureV v) data SomeSignatureV where SomeSignatureV :: SignatureV v -> SomeSignatureV 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 (SignaturePkt payload) = Right (someSignatureVFromPayload payload) fromPktEitherSomeSignatureV 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) 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 instance Pretty (SignatureV 'SigPayloadV3) where 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 instance Pretty (SignatureV 'SigPayloadV4) where 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 instance Pretty (SignatureV 'SigPayloadV6) where 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 instance Pretty (SignatureV 'SigPayloadVOther) where 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 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 instance Pretty (SKESK 'SKESKV4) where 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 instance Pretty (SKESK 'SKESKV6) where 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 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 instance Pretty (OnePassSignature 'OPSV3) where 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 instance Pretty (OnePassSignature 'OPSV6) where pretty = pretty . toPkt data SecretKey = SecretKey { _secretKeyPKPayload :: SomePKPayload , _secretKeySKAddendum :: SKAddendum } 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 instance Pretty SecretKey where pretty = pretty . toPkt newtype PublicKey = PublicKey { _publicKeyPKPayload :: SomePKPayload } 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 instance Pretty PublicKey where pretty = pretty . toPkt data SecretSubkey = SecretSubkey { _secretSubkeyPKPayload :: SomePKPayload , _secretSubkeySKAddendum :: SKAddendum } 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 instance Pretty SecretSubkey where pretty = pretty . toPkt data CompressedData = CompressedData { _compressedDataCompressionAlgorithm :: CompressionAlgorithm , _compressedDataPayload :: CompressedDataPayload } 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 instance Pretty CompressedData where pretty = pretty . toPkt newtype SymEncData = SymEncData { _symEncDataPayload :: ByteString } 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 instance Pretty SymEncData where pretty = pretty . toPkt newtype Marker = Marker { _markerPayload :: ByteString } 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 instance Pretty Marker where pretty = pretty . toPkt data LiteralData = LiteralData { _literalDataDataType :: DataType , _literalDataFileName :: FileName , _literalDataTimeStamp :: ThirtyTwoBitTimeStamp , _literalDataPayload :: ByteString } 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 instance Pretty LiteralData where pretty = pretty . toPkt newtype Trust = Trust { _trustPayload :: ByteString } 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 instance Pretty Trust where pretty = pretty . toPkt newtype UserId = UserId { _userIdPayload :: Text } 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 instance Pretty UserId where pretty = pretty . toPkt newtype PublicSubkey = PublicSubkey { _publicSubkeyPKPayload :: SomePKPayload } 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 instance Pretty PublicSubkey where pretty = pretty . toPkt newtype UserAttribute = UserAttribute { _userAttributeSubPackets :: [UserAttrSubPacket] } 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 instance Pretty UserAttribute where pretty = pretty . toPkt 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 instance Pretty SymEncIntegrityProtectedData where pretty = pretty . toPkt newtype ModificationDetectionCode = ModificationDetectionCode { _modificationDetectionCodePayload :: ByteString } 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 instance Pretty ModificationDetectionCode where pretty = pretty . toPkt data OtherPacket = OtherPacket { _otherPacketType :: Word8 , _otherPacketPayload :: ByteString } 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 instance Pretty OtherPacket where pretty = pretty . toPkt data BrokenPacket = BrokenPacket { _brokenPacketParseError :: String , _brokenPacketType :: Word8 , _brokenPacketPayload :: ByteString } 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 instance Pretty BrokenPacket where pretty = pretty . toPkt $(makeLenses ''Signature) $(makeLenses ''SecretKey) $(makeLenses ''PublicKey) $(makeLenses ''SecretSubkey) $(makeLenses ''CompressedData) $(makeLenses ''SymEncData) $(makeLenses ''Marker) $(makeLenses ''LiteralData) $(makeLenses ''Trust) $(makeLenses ''UserId) $(makeLenses ''PublicSubkey) $(makeLenses ''UserAttribute) $(makeLenses ''SymEncIntegrityProtectedData) $(makeLenses ''ModificationDetectionCode) $(makeLenses ''OtherPacket) $(makeLenses ''BrokenPacket) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs0000644000000000000000000005375207346545000022071 0ustar0000000000000000-- Pkt.hs: OpenPGP (RFC9580) Pkt data types -- 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 GeneralizedNewtypeDeriving #-} {-# 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 qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Data (Data(..), Constr, mkDataType, mkConstr, Fixity(Prefix)) import qualified Data.Data as DD 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(..), (<+>)) data PKESKPayloadVersion = PKESKV3 | PKESKV6 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 PKESKPayload = PKESKPayloadV3Packet PKESKPayloadV3 | PKESKPayloadV6Packet PKESKPayloadV6 deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data SKESKPayloadVersion = SKESKV4 | SKESKV6 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 SKESKPayload = SKESKPayloadV4Packet SKESKPayloadV4 | SKESKPayloadV6Packet SKESKPayloadV6 deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data OnePassSignatureVersion = OPSV3 | OPSV6 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 OnePassSignaturePayload = 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) data KeyPktKind = PublicPkt | SecretPkt deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data KeyPktRole = 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 deriving instance Eq (KeyPkt k) deriving instance Show (KeyPkt k) instance Ord (KeyPkt k) where compare = comparing keyPktToPkt instance Hashable (KeyPkt k) where 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 toConstr (KeyPktPublicPrimary _) = conKeyPktPublicPrimary toConstr (KeyPktPublicSubkey _) = conKeyPktPublicSubkey toConstr (KeyPktSecretPrimary _ _) = conKeyPktSecretPrimary toConstr (KeyPktSecretSubkey _ _) = conKeyPktSecretSubkey dataTypeOf _ = tyKeyPkt gunfold _ _ _ = error "KeyPkt: gunfold not supported for GADT" tyKeyPkt :: DD.DataType tyKeyPkt = mkDataType "Codec.Encryption.OpenPGP.Types.Internal.Pkt.KeyPkt" [ conKeyPktPublicPrimary , conKeyPktPublicSubkey , conKeyPktSecretPrimary , conKeyPktSecretSubkey ] conKeyPktPublicPrimary, conKeyPktPublicSubkey, conKeyPktSecretPrimary, conKeyPktSecretSubkey :: Constr conKeyPktPublicPrimary = mkConstr tyKeyPkt "KeyPktPublicPrimary" [] Prefix conKeyPktPublicSubkey = mkConstr tyKeyPkt "KeyPktPublicSubkey" [] Prefix conKeyPktSecretPrimary = mkConstr tyKeyPkt "KeyPktSecretPrimary" [] Prefix conKeyPktSecretSubkey = mkConstr tyKeyPkt "KeyPktSecretSubkey" [] Prefix data SomeKeyPkt where SomeKeyPkt :: KeyPkt k -> SomeKeyPkt deriving instance Show SomeKeyPkt instance Eq SomeKeyPkt where SomeKeyPkt left == SomeKeyPkt right = someKeyPktToPkt (SomeKeyPkt left) == someKeyPktToPkt (SomeKeyPkt right) data KeyPktCoercionError = 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) data PktWithWireRep = PktWithWireRep { _pktWireRepRef :: WireRepRef , _pktRange :: ByteRange , _pktRaw :: ByteString , _pktIndex :: Int , _pktValue :: Pkt } 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 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 wireRepOfPkt :: PktWithWireRep -> WireRepRef wireRepOfPkt = _pktWireRepRef 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) instance A.ToJSON Pkt where toJSON (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eoki pka mpis))) = object [ key "pkesk" .= 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" .= 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" .= 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" .= 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" .= 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" .= 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" .= 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" .= 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" .= object [ key "error" .= s , key "tag" .= t , key "data" .= BL.unpack bs ] ] pktTag :: Pkt -> Word8 pktTag PKESKPkt {} = 1 pktTag (SignaturePkt _) = 2 pktTag SKESKPkt {} = 3 pktTag OnePassSignaturePkt {} = 4 pktTag SecretKeyPkt {} = 5 pktTag (PublicKeyPkt _) = 6 pktTag SecretSubkeyPkt {} = 7 pktTag CompressedDataPkt {} = 8 pktTag (SymEncDataPkt _) = 9 pktTag (MarkerPkt _) = 10 pktTag LiteralDataPkt {} = 11 pktTag (TrustPkt _) = 12 pktTag (UserIdPkt _) = 13 pktTag (PublicSubkeyPkt _) = 14 pktTag (UserAttributePkt _) = 17 pktTag SymEncIntegrityProtectedDataPkt {} = 18 pktTag (ModificationDetectionCodePkt _) = 19 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) renderKeyPktCoercionError (ExpectedPublicKeyPacket pkt) = "Expected a public key packet, got tag " ++ show (pktTag pkt) renderKeyPktCoercionError (ExpectedSecretKeyPacket pkt) = "Expected a secret key packet, got tag " ++ show (pktTag pkt) keyPktRole :: KeyPkt k -> KeyPktRole keyPktRole KeyPktPublicPrimary {} = KeyPktPrimary keyPktRole KeyPktPublicSubkey {} = KeyPktSubkey keyPktRole KeyPktSecretPrimary {} = KeyPktPrimary keyPktRole KeyPktSecretSubkey {} = KeyPktSubkey keyPktPKPayload :: KeyPkt k -> SomePKPayload keyPktPKPayload (KeyPktPublicPrimary pkp) = pkp keyPktPKPayload (KeyPktPublicSubkey pkp) = pkp keyPktPKPayload (KeyPktSecretPrimary pkp _) = pkp keyPktPKPayload (KeyPktSecretSubkey pkp _) = pkp keyPktMaybeSKAddendum :: KeyPkt k -> Maybe SKAddendum keyPktMaybeSKAddendum KeyPktPublicPrimary {} = Nothing keyPktMaybeSKAddendum KeyPktPublicSubkey {} = Nothing keyPktMaybeSKAddendum (KeyPktSecretPrimary _ ska) = Just ska keyPktMaybeSKAddendum (KeyPktSecretSubkey _ ska) = Just ska keyPktTKKey :: KeyPkt k -> (SomePKPayload, Maybe SKAddendum) keyPktTKKey keyPkt = (keyPktPKPayload keyPkt, keyPktMaybeSKAddendum keyPkt) secretKeyPktSKAddendum :: KeyPkt 'SecretPkt -> SKAddendum secretKeyPktSKAddendum (KeyPktSecretPrimary _ ska) = ska secretKeyPktSKAddendum (KeyPktSecretSubkey _ ska) = ska mkPrimaryKeyPkt :: SomePKPayload -> Maybe SKAddendum -> SomeKeyPkt mkPrimaryKeyPkt pkp Nothing = SomeKeyPkt (KeyPktPublicPrimary pkp) mkPrimaryKeyPkt pkp (Just ska) = SomeKeyPkt (KeyPktSecretPrimary pkp ska) mkSubkeyKeyPkt :: SomePKPayload -> Maybe SKAddendum -> SomeKeyPkt mkSubkeyKeyPkt pkp Nothing = SomeKeyPkt (KeyPktPublicSubkey pkp) mkSubkeyKeyPkt pkp (Just ska) = SomeKeyPkt (KeyPktSecretSubkey pkp ska) keyPktToPublicView :: KeyPkt 'SecretPkt -> KeyPkt 'PublicPkt keyPktToPublicView (KeyPktSecretPrimary pkp _) = KeyPktPublicPrimary pkp keyPktToPublicView (KeyPktSecretSubkey pkp _) = KeyPktPublicSubkey pkp keyPktToPkt :: KeyPkt k -> Pkt keyPktToPkt (KeyPktPublicPrimary pkp) = PublicKeyPkt pkp keyPktToPkt (KeyPktPublicSubkey pkp) = PublicSubkeyPkt pkp keyPktToPkt (KeyPktSecretPrimary pkp ska) = SecretKeyPkt pkp ska keyPktToPkt (KeyPktSecretSubkey pkp ska) = SecretSubkeyPkt pkp ska someKeyPktToPkt :: SomeKeyPkt -> Pkt someKeyPktToPkt (SomeKeyPkt keyPkt) = keyPktToPkt keyPkt 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)) pktToSomeKeyPktEither (SecretSubkeyPkt pkp ska) = Right (SomeKeyPkt (KeyPktSecretSubkey pkp ska)) pktToSomeKeyPktEither pkt = Left (NotAKeyPacket pkt) pktToSomeKeyPkt :: Pkt -> Maybe SomeKeyPkt pktToSomeKeyPkt = either (const Nothing) Just . pktToSomeKeyPktEither pktToPublicKeyPktEither :: Pkt -> Either KeyPktCoercionError (KeyPkt 'PublicPkt) pktToPublicKeyPktEither (PublicKeyPkt pkp) = Right (KeyPktPublicPrimary pkp) pktToPublicKeyPktEither (PublicSubkeyPkt pkp) = Right (KeyPktPublicSubkey pkp) pktToPublicKeyPktEither pkt = Left (ExpectedPublicKeyPacket pkt) pktToPublicKeyPkt :: Pkt -> Maybe (KeyPkt 'PublicPkt) pktToPublicKeyPkt = either (const Nothing) Just . pktToPublicKeyPktEither 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) 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. publicKeyPacketOf :: Pkt -> Pkt publicKeyPacketOf pkt = maybe pkt (keyPktToPkt . keyPktToPublicView) (pktToSecretKeyPkt pkt) data Verification = Verification { _verificationSigner :: SomePKPayload , _verificationSignature :: SignaturePayload , _verificationWarnings :: [VerificationWarning] } data VerificationWarning = MissingSubkeyBackSignatureWarning deriving (Eq, Show) data SOPVVerification = SOPVVerification { _sopvvDateStamp :: UTCTime , _sopvvFingerprint :: Fingerprint , _sopvvPrimaryFingerprint :: Fingerprint , _sopvvMode :: String , _sopvvDescription :: String } $(makeLenses ''Verification) $(makeLenses ''SOPVVerification) $(makeLenses ''PktWithWireRep) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Types/Internal/PrettyUtils.hs0000644000000000000000000000120107346545000023621 0ustar0000000000000000-- PrettyUtils.hs: prettyprinter helpers -- Copyright © 2018-2022 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils where import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Prettyprinter (Doc, Pretty(..)) prettyBS :: B.ByteString -> Doc ann prettyBS = pretty . decodeUtf8With lenientDecode prettyLBS :: BL.ByteString -> Doc ann prettyLBS = pretty . decodeUtf8With lenientDecode . BL.toStrict hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Types/Internal/TK.hs0000644000000000000000000005520107346545000021640 0ustar0000000000000000-- TK.hs: OpenPGP (RFC9580) transferable key data type -- Copyright © 2012-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 DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Codec.Encryption.OpenPGP.Types.Internal.TK 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.Pkt import Control.Arrow ((&&&)) import Data.Bifunctor (first) import Control.Lens (makeLenses) import qualified Data.Aeson.TH as ATH import qualified Data.ByteString.Lazy as BL import Data.Data (Data) import Data.IxSet.Typed (IxSet) import qualified Data.IxSet.Typed as IxSet import Data.Kind (Type) import Data.List (sortOn) import qualified Data.List.NonEmpty as NE import Data.Ord (comparing) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Word (Word8) -- | Zipper for navigating a list of packets with position context data PacketZipper = PacketZipper { _zpBefore :: [PktWithWireRep] -- packets consumed before focus , _zpCurrent :: PktWithWireRep -- current packet under focus , _zpAfter :: [PktWithWireRep] -- packets remaining after focus } deriving (Data, Eq, Generic, Ord, Show, Typeable) -- | Create a zipper from a list, starting at the first element zFromList :: [PktWithWireRep] -> Maybe PacketZipper zFromList [] = Nothing zFromList (x:xs) = Just (PacketZipper [] x xs) -- | Extract position in packet sequence zPosition :: PacketZipper -> Int zPosition (PacketZipper before _ _) = length before -- | Move to the next packet in the sequence zMoveNext :: PacketZipper -> Maybe PacketZipper zMoveNext (PacketZipper before current []) = Nothing zMoveNext (PacketZipper before current (x:xs)) = Just (PacketZipper (before ++ [current]) x xs) -- | Get the remaining packets (current + after) zRemaining :: PacketZipper -> [PktWithWireRep] zRemaining (PacketZipper _ current after) = current : after -- | Reconstruct the full list from a zipper zToList :: PacketZipper -> [PktWithWireRep] zToList (PacketZipper before current after) = before ++ [current] ++ after data TKUnknown = TKUnknown { _tkuKey :: (SomePKPayload, Maybe SKAddendum) , _tkuRevs :: [SignaturePayload] , _tkuUIDs :: [(Text, [SignaturePayload])] , _tkuUAts :: [([UserAttrSubPacket], [SignaturePayload])] , _tkuSubs :: [(Pkt, [SignaturePayload])] } deriving (Data, Eq, Generic, Show, Typeable) data TKKind = PublicTK | SecretTK deriving (Data, Eq, Generic, Ord, Show, Typeable) type family TKKindToKeyPktKind (k :: TKKind) :: KeyPktKind where TKKindToKeyPktKind 'PublicTK = 'PublicPkt TKKindToKeyPktKind 'SecretTK = 'SecretPkt data TK (k :: TKKind) = TK { _tkPrimaryKey :: KeyPkt (TKKindToKeyPktKind k) , _tkRevs :: [SignaturePayload] , _tkUIDs :: [(Text, [SignaturePayload])] , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] , _tkSubs :: [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])] } deriving (Eq, Show) deriving instance (Typeable k, Data (KeyPkt (TKKindToKeyPktKind k))) => Data (TK k) instance Ord (TK k) where compare = comparing _tkPrimaryKey data SomeTK where SomePublicTK :: TK 'PublicTK -> SomeTK SomeSecretTK :: TK 'SecretTK -> SomeTK deriving instance Show SomeTK instance Eq SomeTK where left == right = someTKToUnknown left == someTKToUnknown right data TKConversionError = PublicSubkeyHasPrimaryRole | SecretSubkeyHasPrimaryRole | ExpectedPublicSubkeyPacket Word8 | ExpectedSecretSubkeyPacket Word8 deriving (Eq, Show) renderTKConversionError :: TKConversionError -> String renderTKConversionError PublicSubkeyHasPrimaryRole = "public subkey has primary-key role" renderTKConversionError SecretSubkeyHasPrimaryRole = "secret subkey has primary-key role" renderTKConversionError (ExpectedPublicSubkeyPacket tagValue) = "expected public subkey, got packet tag " ++ show tagValue renderTKConversionError (ExpectedSecretSubkeyPacket tagValue) = "expected secret subkey, got packet tag " ++ show tagValue tkToUnknown :: TK k -> TKUnknown tkToUnknown tk = TKUnknown { _tkuKey = keyPktTKKey (_tkPrimaryKey tk) , _tkuRevs = _tkRevs tk , _tkuUIDs = _tkUIDs tk , _tkuUAts = _tkUAts tk , _tkuSubs = map (\(kp, sigs) -> (keyPktToPkt kp, sigs)) (_tkSubs tk) } someTKToUnknown :: SomeTK -> TKUnknown someTKToUnknown (SomePublicTK tk) = tkToUnknown tk someTKToUnknown (SomeSecretTK tk) = tkToUnknown tk mkTKUnknown :: SomePKPayload -> Maybe SKAddendum -> TKUnknown mkTKUnknown pkp maybeSka = TKUnknown { _tkuKey = (pkp, maybeSka) , _tkuRevs = [] , _tkuUIDs = [] , _tkuUAts = [] , _tkuSubs = [] } fromPrimaryKeyPktToTKUnknown :: Pkt -> Either String TKUnknown fromPrimaryKeyPktToTKUnknown (PublicKeyPkt pkp) = Right (mkTKUnknown pkp Nothing) fromPrimaryKeyPktToTKUnknown (SecretKeyPkt pkp ska) = Right (mkTKUnknown pkp (Just ska)) fromPrimaryKeyPktToTKUnknown pkt = Left ("expected primary key packet, got packet tag " ++ show (pktTag pkt)) someTKToPublicTK :: SomeTK -> Maybe (TK 'PublicTK) someTKToPublicTK (SomePublicTK tk) = Just tk someTKToPublicTK (SomeSecretTK _) = Nothing someTKToSecretTK :: SomeTK -> Maybe (TK 'SecretTK) someTKToSecretTK (SomeSecretTK tk) = Just tk someTKToSecretTK (SomePublicTK _) = Nothing someTKToPublicViewTK :: SomeTK -> TK 'PublicTK someTKToPublicViewTK (SomePublicTK tk) = tk someTKToPublicViewTK (SomeSecretTK tk) = publicViewTK tk publicViewTK :: TK 'SecretTK -> TK 'PublicTK publicViewTK tk = TK { _tkPrimaryKey = keyPktToPublicView (_tkPrimaryKey tk) , _tkRevs = _tkRevs tk , _tkUIDs = _tkUIDs tk , _tkUAts = _tkUAts tk , _tkSubs = map (\(kp, sigs) -> (keyPktToPublicView kp, sigs)) (_tkSubs tk) } fromUnknownToTKEither :: TKUnknown -> Either TKConversionError SomeTK fromUnknownToTKEither tk = case _tkuKey tk of (pkp, Nothing) -> do subs <- traverse liftPublicSubkey (_tkuSubs tk) let typed :: TK 'PublicTK typed = TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = _tkuRevs tk , _tkUIDs = _tkuUIDs tk , _tkUAts = _tkuUAts tk , _tkSubs = subs } Right (SomePublicTK typed) (pkp, Just ska) -> do subs <- traverse liftSecretSubkey (_tkuSubs tk) let typed :: TK 'SecretTK typed = TK { _tkPrimaryKey = KeyPktSecretPrimary pkp ska , _tkRevs = _tkuRevs tk , _tkUIDs = _tkuUIDs tk , _tkUAts = _tkuUAts tk , _tkSubs = subs } Right (SomeSecretTK typed) where liftPublicSubkey :: (Pkt, [SignaturePayload]) -> Either TKConversionError (KeyPkt 'PublicPkt, [SignaturePayload]) liftPublicSubkey (pkt, sigs) = case pktToPublicKeyPkt pkt of Just keyPkt | keyPktRole keyPkt == KeyPktSubkey -> Right (keyPkt, sigs) | otherwise -> Left PublicSubkeyHasPrimaryRole Nothing -> Left (ExpectedPublicSubkeyPacket (pktTag pkt)) liftSecretSubkey :: (Pkt, [SignaturePayload]) -> Either TKConversionError (KeyPkt 'SecretPkt, [SignaturePayload]) liftSecretSubkey (pkt, sigs) = case pktToSecretKeyPkt pkt of Just keyPkt | keyPktRole keyPkt == KeyPktSubkey -> Right (keyPkt, sigs) | otherwise -> Left SecretSubkeyHasPrimaryRole Nothing -> Left (ExpectedSecretSubkeyPacket (pktTag pkt)) fromUnknownToTK :: TKUnknown -> Either String SomeTK fromUnknownToTK = first renderTKConversionError . fromUnknownToTKEither data TKWithWireRep = TKWithWireRep { _tkWireRepRefs :: WireRepRefs , _tkWireRepRange :: Maybe ByteRange , _tkPackets :: [PktWithWireRep] , _tkValue :: TKUnknown } deriving (Data, Eq, Generic, Ord, Show, Typeable) data PacketRefId = PacketRefId { _packetRefWireRepRef :: WireRepRef , _packetRefIndex :: Int } deriving (Data, Eq, Generic, Ord, Show, Typeable) data SignatureWithWireRef = SignatureWithWireRef { _signatureWithWireRefValue :: SignaturePayload , _signatureWithWireRefRef :: PacketRefId } deriving (Data, Eq, Generic, Ord, Show, Typeable) data UIDWithWireRefs = UIDWithWireRefs { _uidWithWireRefsValue :: Text , _uidWithWireRefsRef :: PacketRefId , _uidWithWireRefsSignatures :: [SignatureWithWireRef] } deriving (Data, Eq, Generic, Ord, Show, Typeable) data UATWithWireRefs = UATWithWireRefs { _uatWithWireRefsValue :: [UserAttrSubPacket] , _uatWithWireRefsRef :: PacketRefId , _uatWithWireRefsSignatures :: [SignatureWithWireRef] } deriving (Data, Eq, Generic, Ord, Show, Typeable) data SubkeyWithWireRefs = SubkeyWithWireRefs { _subkeyWithWireRefsValue :: Pkt , _subkeyWithWireRefsRef :: PacketRefId , _subkeyWithWireRefsSignatures :: [SignatureWithWireRef] } deriving (Data, Eq, Generic, Ord, Show, Typeable) data TKStructuredWithWireRep = TKStructuredWithWireRep { _tkStructuredWireRepRefs :: WireRepRefs , _tkStructuredWireRepRange :: Maybe ByteRange , _tkStructuredPrimaryKey :: (SomePKPayload, Maybe SKAddendum) , _tkStructuredPrimaryKeyRef :: PacketRefId , _tkStructuredDirectSignatures :: [SignatureWithWireRef] , _tkStructuredUIDs :: [UIDWithWireRefs] , _tkStructuredUAts :: [UATWithWireRefs] , _tkStructuredSubkeys :: [SubkeyWithWireRefs] , _tkStructuredPacketRefs :: [PktWithWireRep] } deriving (Data, Eq, Generic, Ord, Show, Typeable) data CanonicalizeTKWithWireRepError = CanonicalizeStructuringError String | CanonicalizeMissingPacketRef PacketRefId deriving (Data, Eq, Generic, Ord, Show, Typeable) instance Ord TKUnknown where -- TKUnknown ordering is identity-oriented: the primary key packet defines key identity, -- while revocations, UIDs, and subkeys are mergeable metadata. compare = comparing _tkuKey wireRepOfTK :: TKWithWireRep -> WireRepRef wireRepOfTK = NE.head . _tkWireRepRefs wireRepsOfTK :: TKWithWireRep -> WireRepRefs wireRepsOfTK = _tkWireRepRefs packetRefsOfTK :: TKWithWireRep -> [PktWithWireRep] packetRefsOfTK = _tkPackets packetRefIdOf :: PktWithWireRep -> PacketRefId packetRefIdOf pkt = PacketRefId (_pktWireRepRef pkt) (_pktIndex pkt) lookupPacketRef :: TKStructuredWithWireRep -> PacketRefId -> Maybe PktWithWireRep lookupPacketRef structured target = go (_tkStructuredPacketRefs structured) where go [] = Nothing go (pkt:rest) | packetRefIdOf pkt == target = Just pkt | otherwise = go rest packetWireBytesForRef :: TKStructuredWithWireRep -> PacketRefId -> Either CanonicalizeTKWithWireRepError BL.ByteString packetWireBytesForRef structured refId = case lookupPacketRef structured refId of Just pkt -> Right (_pktRaw pkt) Nothing -> Left (CanonicalizeMissingPacketRef refId) signatureWireSortKey :: TKStructuredWithWireRep -> SignatureWithWireRef -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId) signatureWireSortKey structured sig = (\raw -> (raw, _signatureWithWireRefRef sig)) <$> packetWireBytesForRef structured (_signatureWithWireRefRef sig) uidWireSortKey :: TKStructuredWithWireRep -> UIDWithWireRefs -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId) uidWireSortKey structured uid = (\raw -> (raw, _uidWithWireRefsRef uid)) <$> packetWireBytesForRef structured (_uidWithWireRefsRef uid) uatWireSortKey :: TKStructuredWithWireRep -> UATWithWireRefs -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId) uatWireSortKey structured uat = (\raw -> (raw, _uatWithWireRefsRef uat)) <$> packetWireBytesForRef structured (_uatWithWireRefsRef uat) subkeyWireSortKey :: TKStructuredWithWireRep -> SubkeyWithWireRefs -> Either CanonicalizeTKWithWireRepError (BL.ByteString, PacketRefId) subkeyWireSortKey structured sub = (\raw -> (raw, _subkeyWithWireRefsRef sub)) <$> packetWireBytesForRef structured (_subkeyWithWireRefsRef sub) compareSignatureWithWireRefCanonical :: TKStructuredWithWireRep -> SignatureWithWireRef -> SignatureWithWireRef -> Either CanonicalizeTKWithWireRepError Ordering compareSignatureWithWireRefCanonical structured a b = compare <$> signatureWireSortKey structured a <*> signatureWireSortKey structured b compareUIDWithWireRefsCanonical :: TKStructuredWithWireRep -> UIDWithWireRefs -> UIDWithWireRefs -> Either CanonicalizeTKWithWireRepError Ordering compareUIDWithWireRefsCanonical structured a b = compare <$> uidWireSortKey structured a <*> uidWireSortKey structured b compareUATWithWireRefsCanonical :: TKStructuredWithWireRep -> UATWithWireRefs -> UATWithWireRefs -> Either CanonicalizeTKWithWireRepError Ordering compareUATWithWireRefsCanonical structured a b = compare <$> uatWireSortKey structured a <*> uatWireSortKey structured b compareSubkeyWithWireRefsCanonical :: TKStructuredWithWireRep -> SubkeyWithWireRefs -> SubkeyWithWireRefs -> Either CanonicalizeTKWithWireRepError Ordering compareSubkeyWithWireRefsCanonical structured a b = compare <$> subkeyWireSortKey structured a <*> subkeyWireSortKey structured b sortCanonicalByKey :: Ord key => (a -> Either CanonicalizeTKWithWireRepError key) -> [a] -> Either CanonicalizeTKWithWireRepError [a] sortCanonicalByKey keyFn xs = map snd . sortOn fst <$> traverse (\x -> (\k -> (k, x)) <$> keyFn x) xs sortSignatureWithWireRefsCanonical :: TKStructuredWithWireRep -> [SignatureWithWireRef] -> Either CanonicalizeTKWithWireRepError [SignatureWithWireRef] sortSignatureWithWireRefsCanonical structured = sortCanonicalByKey (signatureWireSortKey structured) sortUIDWithWireRefsCanonical :: TKStructuredWithWireRep -> [UIDWithWireRefs] -> Either CanonicalizeTKWithWireRepError [UIDWithWireRefs] sortUIDWithWireRefsCanonical structured uids = do normalized <- traverse (\uid -> (\sigs -> uid {_uidWithWireRefsSignatures = sigs}) <$> sortSignatureWithWireRefsCanonical structured (_uidWithWireRefsSignatures uid)) uids sortCanonicalByKey (uidWireSortKey structured) normalized sortUATWithWireRefsCanonical :: TKStructuredWithWireRep -> [UATWithWireRefs] -> Either CanonicalizeTKWithWireRepError [UATWithWireRefs] sortUATWithWireRefsCanonical structured uats = do normalized <- traverse (\uat -> (\sigs -> uat {_uatWithWireRefsSignatures = sigs}) <$> sortSignatureWithWireRefsCanonical structured (_uatWithWireRefsSignatures uat)) uats sortCanonicalByKey (uatWireSortKey structured) normalized sortSubkeyWithWireRefsCanonical :: TKStructuredWithWireRep -> [SubkeyWithWireRefs] -> Either CanonicalizeTKWithWireRepError [SubkeyWithWireRefs] sortSubkeyWithWireRefsCanonical structured subs = do normalized <- traverse (\sub -> (\sigs -> sub {_subkeyWithWireRefsSignatures = sigs}) <$> sortSignatureWithWireRefsCanonical structured (_subkeyWithWireRefsSignatures sub)) subs sortCanonicalByKey (subkeyWireSortKey structured) normalized canonicalizeTKStructuredWithWireRep :: TKStructuredWithWireRep -> Either CanonicalizeTKWithWireRepError TKUnknown canonicalizeTKStructuredWithWireRep structured = buildTK <$> sortSignatureWithWireRefsCanonical structured (_tkStructuredDirectSignatures structured) <*> sortUIDWithWireRefsCanonical structured (_tkStructuredUIDs structured) <*> sortUATWithWireRefsCanonical structured (_tkStructuredUAts structured) <*> sortSubkeyWithWireRefsCanonical structured (_tkStructuredSubkeys structured) where buildTK directSigs uids uats subs = TKUnknown { _tkuKey = _tkStructuredPrimaryKey structured , _tkuRevs = map _signatureWithWireRefValue directSigs , _tkuUIDs = map (_uidWithWireRefsValue &&& (map _signatureWithWireRefValue . _uidWithWireRefsSignatures)) uids , _tkuUAts = map (_uatWithWireRefsValue &&& (map _signatureWithWireRefValue . _uatWithWireRefsSignatures)) uats , _tkuSubs = map (_subkeyWithWireRefsValue &&& (map _signatureWithWireRefValue . _subkeyWithWireRefsSignatures)) subs } canonicalizeTKWithWireRep :: TKWithWireRep -> Either CanonicalizeTKWithWireRepError TKUnknown canonicalizeTKWithWireRep tk = do structured <- case toStructuredTKWithWireRep tk of Left err -> Left (CanonicalizeStructuringError err) Right s -> Right s canonicalizeTKStructuredWithWireRep structured toStructuredTKWithWireRep :: TKWithWireRep -> Either String TKStructuredWithWireRep toStructuredTKWithWireRep tkWithRefs = do let tk = _tkValue tkWithRefs refs = _tkPackets tkWithRefs (pkp, mska) = _tkuKey tk primaryPkt = someKeyPktToPkt (mkPrimaryKeyPkt pkp mska) zipper <- case zFromList refs of Just z -> Right z Nothing -> Left "no packet references available for TKUnknown structuring" (primaryRef, z1') <- consumePktZ "primary key packet" primaryPkt zipper -- Move past the primary key to process its signatures and following packets z1 <- case zMoveNext z1' of Just z -> Right z Nothing -> -- Primary key is the only packet; only valid if no revisions, UIDs, UATs, or subkeys if null (_tkuRevs tk) && null (_tkuUIDs tk) && null (_tkuUAts tk) && null (_tkuSubs tk) then Right z1' else Left "missing signatures/UIDs/subkeys after primary key packet" (directSigs, z2) <- consumeSigsZ "direct-key signatures" (_tkuRevs tk) z1 (uids, z3) <- consumeUIDsZ (_tkuUIDs tk) z2 (uats, z4) <- consumeUATsZ (_tkuUAts tk) z3 (subs, z5) <- consumeSubsZ (_tkuSubs tk) z4 -- Check if there are trailing packets AFTER the current focus (not including it) case _zpAfter z5 of [] -> Right (TKStructuredWithWireRep (_tkWireRepRefs tkWithRefs) (_tkWireRepRange tkWithRefs) (_tkuKey tk) (packetRefIdOf primaryRef) directSigs uids uats subs (_tkPackets tkWithRefs)) (unexpected:_) -> Left ("unexpected trailing packet reference at position " ++ show (zPosition z5 + 1) ++ " while structuring TKUnknown provenance (tag " ++ show (pktTag (_pktValue unexpected)) ++ ")") where consumePktZ :: String -> Pkt -> PacketZipper -> Either String (PktWithWireRep, PacketZipper) consumePktZ context expected z | _pktValue (_zpCurrent z) == expected = Right (_zpCurrent z, z) | otherwise = Left ("packet/reference mismatch for " ++ context ++ " at position " ++ show (zPosition z) ++ ": expected tag " ++ show (pktTag expected) ++ ", got tag " ++ show (pktTag (_pktValue (_zpCurrent z)))) consumeSigsZ :: String -> [SignaturePayload] -> PacketZipper -> Either String ([SignatureWithWireRef], PacketZipper) consumeSigsZ context sigs z = go [] sigs z where go acc [] zipper = Right (reverse acc, zipper) go acc (sig:sigRest) zipper = do (sigPkt, z') <- consumePktZ context (SignaturePkt sig) zipper z'' <- case zMoveNext z' of Just z -> Right z Nothing -> if null sigRest then Right z' else Left ("missing signature packet at position " ++ show (zPosition z')) go (SignatureWithWireRef sig (packetRefIdOf sigPkt) : acc) sigRest z'' consumeUIDsZ :: [(Text, [SignaturePayload])] -> PacketZipper -> Either String ([UIDWithWireRefs], PacketZipper) consumeUIDsZ [] z = Right ([], z) consumeUIDsZ ((uid, sigs):rest) z = do (uidPkt, z1) <- consumePktZ "UID packet" (UserIdPkt uid) z z2 <- case zMoveNext z1 of Just z -> Right z Nothing -> if null rest && null sigs then Right z1 else Left ("missing UID at position " ++ show (zPosition z1)) (uidSigs, z3) <- consumeSigsZ "UID signature" sigs z2 (tailUIDs, z4) <- consumeUIDsZ rest z3 Right (UIDWithWireRefs uid (packetRefIdOf uidPkt) uidSigs : tailUIDs, z4) consumeUATsZ :: [([UserAttrSubPacket], [SignaturePayload])] -> PacketZipper -> Either String ([UATWithWireRefs], PacketZipper) consumeUATsZ [] z = Right ([], z) consumeUATsZ ((uat, sigs):rest) z = do (uatPkt, z1) <- consumePktZ "UAT packet" (UserAttributePkt uat) z z2 <- case zMoveNext z1 of Just z -> Right z Nothing -> if null rest && null sigs then Right z1 else Left ("missing UAT at position " ++ show (zPosition z1)) (uatSigs, z3) <- consumeSigsZ "UAT signature" sigs z2 (tailUats, z4) <- consumeUATsZ rest z3 Right (UATWithWireRefs uat (packetRefIdOf uatPkt) uatSigs : tailUats, z4) consumeSubsZ :: [(Pkt, [SignaturePayload])] -> PacketZipper -> Either String ([SubkeyWithWireRefs], PacketZipper) consumeSubsZ [] z = Right ([], z) consumeSubsZ ((subPkt, sigs):rest) z = do (subRef, z1) <- consumePktZ "subkey packet" subPkt z z2 <- case zMoveNext z1 of Just z -> Right z Nothing -> if null rest && null sigs then Right z1 else Left ("missing subkey at position " ++ show (zPosition z1)) (subSigs, z3) <- consumeSigsZ "subkey signature" sigs z2 (tailSubs, z4) <- consumeSubsZ rest z3 Right (SubkeyWithWireRefs subPkt (packetRefIdOf subRef) subSigs : tailSubs, z4) tksFromWireRep :: WireRepRef -> [TKWithWireRep] -> [TKWithWireRep] tksFromWireRep src = filter (elem src . NE.toList . wireRepsOfTK) tksContainingPacket :: PktWithWireRep -> [TKWithWireRep] -> [TKWithWireRep] tksContainingPacket pkt = filter (elem pkt . packetRefsOfTK) $(ATH.deriveToJSON ATH.defaultOptions ''TKUnknown) type KeyringIxs = '[ EightOctetKeyId, Fingerprint, Text] -- | Kinded keyrings: homogeneous collections of public or secret TKs type PublicKeyring = IxSet KeyringIxs (TK 'PublicTK) type SecretKeyring = IxSet KeyringIxs (TK 'SecretTK) -- | Parameterized kinded keyring for generic operations type family KeyringOf (k :: TKKind) :: Type where KeyringOf 'PublicTK = PublicKeyring KeyringOf 'SecretTK = SecretKeyring $(makeLenses ''TKUnknown) $(makeLenses ''TK) $(makeLenses ''TKWithWireRep) $(makeLenses ''PacketRefId) $(makeLenses ''PacketZipper) $(makeLenses ''SignatureWithWireRef) $(makeLenses ''UIDWithWireRefs) $(makeLenses ''UATWithWireRefs) $(makeLenses ''SubkeyWithWireRefs) $(makeLenses ''TKStructuredWithWireRep) hOpenPGP-3.0.2.1/Codec/Encryption/OpenPGP/Version.hs0000644000000000000000000000055707346545000020073 0ustar0000000000000000-- Version.hs: static hOpenPGP version string -- Copyright © 2024 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Version ( version ) where import Data.Version (showVersion) import qualified Paths_hOpenPGP as Paths version :: String version = showVersion Paths.version hOpenPGP-3.0.2.1/Data/Conduit/OpenPGP/0000755000000000000000000000000007346545000015212 5ustar0000000000000000hOpenPGP-3.0.2.1/Data/Conduit/OpenPGP/Compression.hs0000644000000000000000000000206307346545000020050 0ustar0000000000000000-- Compression.hs: OpenPGP (RFC9580) compression conduits -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Data.Conduit.OpenPGP.Compression ( conduitCompress , conduitDecompress ) where import Codec.Encryption.OpenPGP.Compression import Codec.Encryption.OpenPGP.Types import Control.Monad.Trans.Resource (MonadThrow, throwM) import Data.Conduit import qualified Data.Conduit.List as CL conduitCompress :: MonadThrow m => CompressionAlgorithm -> ConduitT Pkt Pkt m () conduitCompress algo = CL.consume >>= \ps -> yield (compressPkts algo ps) -- | Decompress OpenPGP Compressed Data packets. Decompression failures, -- empty payloads, zero-length results, and marker-only payloads are reported -- via 'MonadThrow' rather than silently dropped. conduitDecompress :: MonadThrow m => ConduitT Pkt Pkt m () conduitDecompress = awaitForever $ \pkt -> case decompressPkt pkt of Left err -> throwM (userError (renderCompressionError err)) Right pkts -> mapM_ yield pkts hOpenPGP-3.0.2.1/Data/Conduit/OpenPGP/Decrypt.hs0000644000000000000000000031474307346545000017174 0ustar0000000000000000-- Decrypt.hs: OpenPGP (RFC9580) recursive packet decryption -- 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] where chk = checksum16 sessionKey hOpenPGP-3.0.2.1/Data/Conduit/OpenPGP/Filter.hs0000644000000000000000000000353107346545000016775 0ustar0000000000000000-- Filter.hs: OpenPGP (RFC4880) packet filtering -- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE GADTs #-} module Data.Conduit.OpenPGP.Filter ( conduitPktFilter , conduitPktWithExtraFilter , conduitTKFilter , FilterPredicates(..) ) where import Control.Monad.Trans.Reader (Reader, runReader) import Data.Conduit (ConduitT) import qualified Data.Conduit.List as CL import Data.Void (Void) import Codec.Encryption.OpenPGP.Types data FilterPredicates r a = RTKFilterPredicate (Reader TKUnknown Bool) -- ^ fp for transferable keys | RPFilterPredicate (Reader Pkt Bool) -- ^ fp for context-less packets | RFilterPredicate (Reader a Bool) -- ^ generic filter predicate | RPairFilterPredicate (Reader (r, a) Bool) -- ^ generic filter predicate with additional context conduitPktFilter :: Monad m => FilterPredicates Void Pkt -> ConduitT Pkt Pkt m () conduitPktFilter = CL.filter . superPredicate superPredicate :: FilterPredicates Void Pkt -> Pkt -> Bool superPredicate (RPFilterPredicate e) p = runReader e p superPredicate (RFilterPredicate e) p = runReader e p superPredicate _ _ = False -- do not match incorrect type of packet conduitTKFilter :: Monad m => FilterPredicates Void TKUnknown -> ConduitT TKUnknown TKUnknown m () conduitTKFilter = CL.filter . superTKPredicate superTKPredicate :: FilterPredicates Void TKUnknown -> TKUnknown -> Bool superTKPredicate (RTKFilterPredicate e) = runReader e superTKPredicate (RFilterPredicate e) = runReader e conduitPktWithExtraFilter :: Monad m => r -> FilterPredicates r Pkt -> ConduitT Pkt Pkt m () conduitPktWithExtraFilter extra = CL.filter . superPairPredicate extra superPairPredicate :: r -> FilterPredicates r a -> a -> Bool superPairPredicate r (RPairFilterPredicate e) p = runReader e (r, p) hOpenPGP-3.0.2.1/Data/Conduit/OpenPGP/Keyring.hs0000644000000000000000000004356507346545000017173 0ustar0000000000000000-- Keyring.hs: OpenPGP (RFC9580) transferable keys parsing -- 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 import Data.Conduit import qualified Data.Conduit.List as CL import Data.Bifunctor (first) 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 ) import Codec.Encryption.OpenPGP.KeyringParser ( KeyringChunkParseError(..) , anyTK , anyTKWithWireRep , finalizeParsingEither , parseAChunkEither ) import Codec.Encryption.OpenPGP.Ontology (isSubkeyBindingSig, isTrustPkt) import Codec.Encryption.OpenPGP.SignatureQualities ( signatureHashedSubpacketsKnown ) import Codec.Encryption.OpenPGP.Signatures ( 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) 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." #-} -- | Canonical strict typed conduit with explicit parse+conversion error channel. 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." #-} -- | 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." #-} 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." #-} data AuthSecretSubkeyUID = AuthSecretSubkeyUID { authSecretSubkeyUIDValue :: Text , authSecretSubkeyUIDIsPrimary :: Bool } deriving (Eq, Show) data AuthSecretSubkeyAtTime = AuthSecretSubkeyAtTime { authSecretSubkeyPrimaryKey :: KeyPkt 'SecretPkt , authSecretSubkeyValue :: KeyPkt 'SecretPkt , authSecretSubkeyUIDs :: [AuthSecretSubkeyUID] , authSecretSubkeyPrimaryUID :: Maybe Text } deriving (Eq, Show) data AuthSecretSubkeyRejectionReason = AuthSecretSubkeyTKVerificationFailed | AuthSecretSubkeyPrimaryKeyInvalidAtTime | AuthSecretSubkeyNotSecretSubkeyPacket | AuthSecretSubkeyNotSubkeyPacket | AuthSecretSubkeySubkeyInvalidAtTime | AuthSecretSubkeyMissingAuthCapability deriving (Eq, Show) data AuthSecretSubkeyRejectedAtTime = AuthSecretSubkeyRejectedAtTime { authSecretSubkeyRejectedPrimaryKey :: KeyPkt 'SecretPkt , authSecretSubkeyRejectedValue :: Maybe (KeyPkt 'SecretPkt) , authSecretSubkeyRejectedUIDs :: [AuthSecretSubkeyUID] , authSecretSubkeyRejectedPrimaryUID :: Maybe Text , authSecretSubkeyRejectedReason :: AuthSecretSubkeyRejectionReason } deriving (Eq, Show) data AuthSecretSubkeysAtReport = AuthSecretSubkeysAtReport { authSecretSubkeysAccepted :: [AuthSecretSubkeyAtTime] , authSecretSubkeysRejected :: [AuthSecretSubkeyRejectedAtTime] } deriving (Eq, Show) conduitToAuthSecretSubkeysAtReport :: Monad m => UTCTime -> ConduitT (TK 'SecretTK) AuthSecretSubkeysAtReport m () conduitToAuthSecretSubkeysAtReport validationTime = CL.map (authSecretSubkeysAtReport validationTime) conduitToAuthSecretSubkeysAt :: Monad m => UTCTime -> ConduitT (TK 'SecretTK) AuthSecretSubkeyAtTime m () conduitToAuthSecretSubkeysAt validationTime = CL.concatMap (authSecretSubkeysAccepted . authSecretSubkeysAtReport validationTime) authSecretSubkeysAt :: UTCTime -> TK 'SecretTK -> [AuthSecretSubkeyAtTime] authSecretSubkeysAt validationTime = authSecretSubkeysAccepted . authSecretSubkeysAtReport validationTime 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 [] [ 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 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 } uidContextsAt :: UTCTime -> TKUnknown -> [AuthSecretSubkeyUID] uidContextsAt validationTime 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 validationTime uids = snd <$> newestByCreationTime candidates where candidates = [ (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) latestEffectiveBindingSignatureAt :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload latestEffectiveBindingSignatureAt validationTime sigs = snd <$> newestByCreationTime [ (createdAt, sig) | sig <- sigs , isSubkeyBindingSig sig , signatureEffectiveAt validationTime sig , createdAt <- maybeToList (signatureCreationTime sig) ] latestEffectiveCertificationAt :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload latestEffectiveCertificationAt validationTime sigs = 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) 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)) signatureMarksPrimaryUID :: SignaturePayload -> Bool signatureMarksPrimaryUID 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 = 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 = 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 = 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 = conduitToTKsWithWireRepEither' False 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' conduitDropErrorsAndNothings :: Monad m => ConduitT (Either e (Maybe a)) a m () conduitDropErrorsAndNothings = CL.mapMaybe (either (const Nothing) id) 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)) where notTrustPacket = not . isTrustPkt 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)) where notTrustPacket = not . isTrustPkt . _pktValue 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 = CL.fold (flip insert) empty -- | Lift a single typed TK into its kinded keyring publicTKToKeyring :: TK 'PublicTK -> PublicKeyring publicTKToKeyring tk = insert tk empty secretTKToKeyring :: TK 'SecretTK -> SecretKeyring secretTKToKeyring tk = insert tk empty -- | Partition a list of SomeTK into homogeneous public and secret keyrings partitionSomeTKs :: [SomeTK] -> (PublicKeyring, SecretKeyring) partitionSomeTKs = foldr step (empty, empty) where step (SomePublicTK tk) (pub, sec) = (insert tk pub, sec) step (SomeSecretTK tk) (pub, sec) = (pub, insert tk sec) hOpenPGP-3.0.2.1/Data/Conduit/OpenPGP/Keyring/0000755000000000000000000000000007346545000016622 5ustar0000000000000000hOpenPGP-3.0.2.1/Data/Conduit/OpenPGP/Keyring/Instances.hs0000644000000000000000000001421107346545000021104 0ustar0000000000000000-- Instances.hs: OpenPGP (RFC9580) additional types for transferable keys -- 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 MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} module Data.Conduit.OpenPGP.Keyring.Instances ( ) where import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Internal (issuer) import Codec.Encryption.OpenPGP.SignatureQualities (sigCT) import Codec.Encryption.OpenPGP.Types import Control.Arrow (second) import Control.Lens ((^.), (^..), _1, folded) import Data.Data.Lens (biplate) import Data.Either (rights) import Data.Function (on) import qualified Data.HashMap.Lazy as HashMap import Data.IxSet.Typed (Indexable(..), ixFun, ixList) import Data.List (nub, sort) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Data.Semigroup (Semigroup, (<>)) import Data.Text (Text) instance Indexable KeyringIxs TKUnknown where indices = ixList (ixFun getEOKIs) (ixFun getFingerprints) (ixFun getUIDs) getEOKIs :: TKUnknown -> [EightOctetKeyId] getEOKIs tk = rights (map eightOctetKeyID (tk ^.. biplate :: [SomePKPayload])) getFingerprints :: TKUnknown -> [Fingerprint] getFingerprints tk = map fingerprint (tk ^.. biplate :: [SomePKPayload]) getUIDs :: TKUnknown -> [Text] getUIDs tk = (tk ^. tkuUIDs) ^.. folded . _1 instance Semigroup TKUnknown where (<>) a b = TKUnknown (_tkuKey a) (nub . sort $ _tkuRevs a ++ _tkuRevs b) ((kvmerge `on` _tkuUIDs) a b) ((kvmerge `on` _tkuUAts) a b) ((ukvmerge `on` _tkuSubs) a b) where kvmerge x y = Map.toList (Map.unionWith nsa (Map.fromList x) (Map.fromList y)) ukvmerge x y = HashMap.toList (HashMap.unionWith nsa (HashMap.fromList x) (HashMap.fromList y)) nsa x y = nub . sort $ x ++ y instance Semigroup TKWithWireRep where (<>) a b = let mergedTK = _tkValue a <> _tkValue b mergedPackets = selectPacketRefsByValue (flattenTKPackets mergedTK) (dedupePacketRefsById (_tkPackets a ++ _tkPackets b)) in TKWithWireRep (mergeWireRepRefs (_tkWireRepRefs a) (_tkWireRepRefs b)) (mergedWireRepRange mergedPackets) mergedPackets mergedTK flattenTKPackets :: TKUnknown -> [Pkt] flattenTKPackets 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 mergeWireRepRefs :: WireRepRefs -> WireRepRefs -> WireRepRefs mergeWireRepRefs left right = case dedupe (NE.toList left ++ NE.toList right) of [] -> left (x:xs) -> x NE.:| xs where dedupe [] = [] dedupe (x:xs) = x : dedupe (filter (/= x) xs) mergedWireRepRange :: [PktWithWireRep] -> Maybe ByteRange mergedWireRepRange [] = Nothing mergedWireRepRange (pkt:rest) | all ((== _pktWireRepRef pkt) . _pktWireRepRef) rest = spanByteRanges (map _pktRange (pkt : rest)) | otherwise = Nothing dedupePacketRefsById :: [PktWithWireRep] -> [PktWithWireRep] dedupePacketRefsById = go [] where go _ [] = [] go seen (pkt:rest) = let packetRefId = packetRefIdOf pkt in if packetRefId `elem` seen then go seen rest else pkt : go (packetRefId : seen) rest selectPacketRefsByValue :: [Pkt] -> [PktWithWireRep] -> [PktWithWireRep] selectPacketRefsByValue expected available = go expected available [] where go [] _ acc = reverse acc go (pkt:pktRest) refs acc = case extractFirstByValue pkt refs of Nothing -> error ("TKWithWireRep Semigroup merge missing packet reference for tag " ++ show (pktTag pkt)) Just (matched, remaining) -> go pktRest remaining (matched : acc) extractFirstByValue :: Pkt -> [PktWithWireRep] -> Maybe (PktWithWireRep, [PktWithWireRep]) extractFirstByValue _ [] = Nothing extractFirstByValue expected (pkt:rest) | _pktValue pkt == expected = Just (pkt, rest) | otherwise = second (pkt :) <$> extractFirstByValue expected rest -- | Extract all SomePKPayloads from a TK (primary + subkeys) without biplate tkPKPayloads :: TK k -> [SomePKPayload] tkPKPayloads tk = keyPktPKPayload (_tkPrimaryKey tk) : map (keyPktPKPayload . fst) (_tkSubs tk) -- | Index public TKs by key ID, fingerprint, and UID instance Indexable KeyringIxs (TK 'PublicTK) where indices = ixList (ixFun getEOKIsPublic) (ixFun getFingerprintsPublic) (ixFun getUIDsPublic) getEOKIsPublic :: TK 'PublicTK -> [EightOctetKeyId] getEOKIsPublic tk = rights (map eightOctetKeyID (tkPKPayloads tk)) getFingerprintsPublic :: TK 'PublicTK -> [Fingerprint] getFingerprintsPublic tk = map fingerprint (tkPKPayloads tk) getUIDsPublic :: TK 'PublicTK -> [Text] getUIDsPublic tk = (tk ^. tkUIDs) ^.. folded . _1 -- | Index secret TKs by key ID, fingerprint, and UID instance Indexable KeyringIxs (TK 'SecretTK) where indices = ixList (ixFun getEOKIsSecret) (ixFun getFingerprintsSecret) (ixFun getUIDsSecret) getEOKIsSecret :: TK 'SecretTK -> [EightOctetKeyId] getEOKIsSecret tk = rights (map eightOctetKeyID (tkPKPayloads tk)) getFingerprintsSecret :: TK 'SecretTK -> [Fingerprint] getFingerprintsSecret tk = map fingerprint (tkPKPayloads tk) getUIDsSecret :: TK 'SecretTK -> [Text] getUIDsSecret tk = (tk ^. tkUIDs) ^.. folded . _1 instance Semigroup (TK k) where a <> b = TK (_tkPrimaryKey a) (nub . sort $ _tkRevs a ++ _tkRevs b) ((kvmerge `on` _tkUIDs) a b) ((kvmerge `on` _tkUAts) a b) ((ukvmerge `on` _tkSubs) a b) where kvmerge x y = Map.toList (Map.unionWith nsa (Map.fromList x) (Map.fromList y)) ukvmerge x y = HashMap.toList (HashMap.unionWith nsa (HashMap.fromList x) (HashMap.fromList y)) nsa x y = nub . sort $ x ++ y hOpenPGP-3.0.2.1/Data/Conduit/OpenPGP/Message.hs0000644000000000000000000000571607346545000017143 0ustar0000000000000000-- Message.hs: conduit-backed OpenPGP message helpers -- Copyright © 2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Data.Conduit.OpenPGP.Message ( VerificationPolicy(..) , VerificationOptions(..) , defaultVerificationOptions , verifyMessagePackets , verifyMessage , VerificationMode(..) ) where import qualified Data.ByteString.Lazy as BL import Data.Conduit ((.|), runConduitPure) import qualified Data.Conduit.List as CL import Data.Time.Clock (UTCTime) import Codec.Encryption.OpenPGP.Compression (decompressPkt) import Codec.Encryption.OpenPGP.Policy (defaultVerificationDefaults, verificationDefaultStreaming, verificationDefaultStrict) import Codec.Encryption.OpenPGP.Serialize (parsePkts) import Codec.Encryption.OpenPGP.Signatures (VerificationError) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Verify ( VerificationMode(..) , VerificationModeW(..) , verifyPacketsWithModeTyped , verifyPacketsBatch ) data VerificationPolicy = VerifyInformational | VerifyStrict deriving (Eq, Show) data VerificationOptions = VerificationOptions { verificationPolicy :: VerificationPolicy , verificationMode :: VerificationMode , verificationTime :: Maybe UTCTime } deriving (Eq, Show) defaultVerificationOptions :: VerificationOptions defaultVerificationOptions = VerificationOptions { verificationPolicy = if verificationDefaultStrict defaultVerificationDefaults then VerifyStrict else VerifyInformational , verificationMode = if verificationDefaultStreaming defaultVerificationDefaults then VerificationStreaming else VerificationBatch , verificationTime = Nothing } verifyMessagePackets :: VerificationOptions -> PublicKeyring -> [Pkt] -> [Either VerificationError Verification] verifyMessagePackets options keyring packets = applyVerificationPolicy (verificationPolicy options) rawResults where rawResults = case verificationMode options of VerificationBatch -> verifyPacketsBatch keyring (verificationTime options) packets VerificationStreaming -> runConduitPure $ CL.sourceList packets .| verifyPacketsWithModeTyped VerificationStreamingW keyring (verificationTime options) .| CL.consume verifyMessage :: VerificationOptions -> PublicKeyring -> BL.ByteString -> [Either VerificationError Verification] verifyMessage options keyring signedMessage = verifyMessagePackets options keyring (concatMap (either (const []) id . decompressPkt) (parsePkts signedMessage)) applyVerificationPolicy :: VerificationPolicy -> [Either VerificationError Verification] -> [Either VerificationError Verification] applyVerificationPolicy VerifyInformational results = results applyVerificationPolicy VerifyStrict results = either (pure . Left) (Right <$>) (sequence results) hOpenPGP-3.0.2.1/Data/Conduit/OpenPGP/Verify.hs0000644000000000000000000001140007346545000017006 0ustar0000000000000000-- Verify.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 GADTs #-} {-# LANGUAGE KindSignatures #-} module Data.Conduit.OpenPGP.Verify ( VerificationMode(..) , VerificationModeW(..) , conduitVerify , verifyPacketsBatch , verifyPacketsWithModeTyped , verifyPacketsWithMode ) where import Data.Conduit import Data.Time.Clock (UTCTime) import Data.List (foldl') import Codec.Encryption.OpenPGP.Internal (PktStreamContext(..), emptyPSC) import Codec.Encryption.OpenPGP.Signatures ( VerificationError(..) , verifyAgainstKeyring , verifySigWith ) import Codec.Encryption.OpenPGP.Types import qualified Data.Conduit.List as CL data VerificationMode = VerificationStreaming | VerificationBatch deriving (Eq, Show) data VerificationModeW (mode :: VerificationMode) where VerificationStreamingW :: VerificationModeW 'VerificationStreaming VerificationBatchW :: VerificationModeW 'VerificationBatch 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 verifyPacketsBatch :: PublicKeyring -> Maybe UTCTime -> [Pkt] -> [Either VerificationError Verification] verifyPacketsBatch kr mt = verifyPacketsBatchTyped kr mt verifyPacketsBatchTyped :: PublicKeyring -> Maybe UTCTime -> [Pkt] -> [Either VerificationError Verification] verifyPacketsBatchTyped kr mt = reverse . snd . foldl' step (emptyPSC, []) where step (state, outputs) pkt = 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 VerificationStreaming kr mt = verifyPacketsWithModeTyped VerificationStreamingW kr mt verifyPacketsWithMode VerificationBatch kr mt = verifyPacketsWithModeTyped VerificationBatchW kr mt 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 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}, []) pushPacketTyped _ _ pk@(PublicKeyPkt _) state = (state {lastPrimaryKey = pk}, []) pushPacketTyped _ _ pk@(PublicSubkeyPkt _) state = (state {lastSubkey = pk}, []) 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)]) pushPacketTyped _ _ pkt@(OnePassSignaturePkt _) state | isOpeningOnePassSignature pkt = (state, []) pushPacketTyped _ _ _ state = (state, []) 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 isOpeningOnePassSignature :: Pkt -> Bool isOpeningOnePassSignature (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 _ _ _ _ _ False))) = True isOpeningOnePassSignature (OnePassSignaturePkt (OPSPayloadV6Packet (OPSPayloadV6 _ _ _ _ _ False))) = True isOpeningOnePassSignature _ = False hOpenPGP-3.0.2.1/LICENSE0000644000000000000000000000206607346545000012475 0ustar0000000000000000Copyright © 2012-2026 Clint Adams Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. hOpenPGP-3.0.2.1/Setup.hs0000644000000000000000000000005607346545000013121 0ustar0000000000000000import Distribution.Simple main = defaultMain hOpenPGP-3.0.2.1/bench/0000755000000000000000000000000007346545000012543 5ustar0000000000000000hOpenPGP-3.0.2.1/bench/mark.hs0000644000000000000000000000611307346545000014032 0ustar0000000000000000-- mark.hs: hOpenPGP benchmark suite -- 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 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") ] , 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 (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) selfVerifyKeys fp = fmap (\ks -> mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks) (loadKeys fp) selfVerifyKeyring fp = fmap (\kr -> mapM (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) Nothing) (IxSet.toList kr)) (loadKeyring fp) sinkFromSomeTKs = IxSet.fromList . map someTKToPublicViewTK . catMaybes hOpenPGP-3.0.2.1/hOpenPGP.cabal0000644000000000000000000003170607346545000014077 0ustar0000000000000000Cabal-version: 3.4 Name: hOpenPGP Version: 3.0.2.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 License: MIT License-file: LICENSE Author: Clint Adams Maintainer: Clint Adams Copyright: 2012-2026 Clint Adams Category: Codec, Data Build-type: Simple Extra-source-files: tests/suite.hs , tests/data/000001-006.public_key , tests/data/000002-013.user_id , tests/data/000003-002.sig , tests/data/000004-012.ring_trust , tests/data/000005-002.sig , tests/data/000006-012.ring_trust , tests/data/000007-002.sig , tests/data/000008-012.ring_trust , tests/data/000009-002.sig , tests/data/000010-012.ring_trust , tests/data/000011-002.sig , tests/data/000012-012.ring_trust , tests/data/000013-014.public_subkey , tests/data/000014-002.sig , tests/data/000015-012.ring_trust , tests/data/000016-006.public_key , tests/data/000017-002.sig , tests/data/000018-012.ring_trust , tests/data/000019-013.user_id , tests/data/000020-002.sig , tests/data/000021-012.ring_trust , tests/data/000022-002.sig , tests/data/000023-012.ring_trust , tests/data/000024-014.public_subkey , tests/data/000025-002.sig , tests/data/000026-012.ring_trust , tests/data/000027-006.public_key , tests/data/000028-002.sig , tests/data/000029-012.ring_trust , tests/data/000030-013.user_id , tests/data/000031-002.sig , tests/data/000032-012.ring_trust , tests/data/000033-002.sig , tests/data/000034-012.ring_trust , tests/data/000035-006.public_key , tests/data/000036-013.user_id , tests/data/000037-002.sig , tests/data/000038-012.ring_trust , tests/data/000039-002.sig , tests/data/000040-012.ring_trust , tests/data/000041-017.attribute , tests/data/000042-002.sig , tests/data/000043-012.ring_trust , tests/data/000044-014.public_subkey , tests/data/000045-002.sig , tests/data/000046-012.ring_trust , tests/data/000047-005.secret_key , tests/data/000048-013.user_id , tests/data/000049-002.sig , tests/data/000050-012.ring_trust , tests/data/000051-007.secret_subkey , tests/data/000052-002.sig , tests/data/000053-012.ring_trust , tests/data/000054-005.secret_key , tests/data/000055-002.sig , tests/data/000056-012.ring_trust , tests/data/000057-013.user_id , tests/data/000058-002.sig , tests/data/000059-012.ring_trust , tests/data/000060-007.secret_subkey , tests/data/000061-002.sig , tests/data/000062-012.ring_trust , tests/data/000063-005.secret_key , tests/data/000064-002.sig , tests/data/000065-012.ring_trust , tests/data/000066-013.user_id , tests/data/000067-002.sig , tests/data/000068-012.ring_trust , tests/data/000069-005.secret_key , tests/data/000070-013.user_id , tests/data/000071-002.sig , tests/data/000072-012.ring_trust , tests/data/000073-017.attribute , tests/data/000074-002.sig , tests/data/000075-012.ring_trust , tests/data/000076-007.secret_subkey , tests/data/000077-002.sig , tests/data/000078-012.ring_trust , tests/data/pubring.gpg , tests/data/secring.gpg , tests/data/compressedsig.gpg , tests/data/msg1.asc , tests/data/uncompressed-ops-rsa.gpg , tests/data/uncompressed-ops-dsa.gpg , tests/data/uncompressed-ops-dsa-sha384.txt.gpg , tests/data/encryption.gpg , tests/data/compressedsig-zlib.gpg , tests/data/compressedsig-bzip2.gpg , tests/data/onepass_sig , tests/data/simple.seckey , tests/data/minimized.gpg , tests/data/subkey.gpg , tests/data/signing-subkey.gpg , tests/data/uat.gpg , tests/data/uat.jpg , tests/data/prikey-rev.gpg , tests/data/subkey-rev.gpg , tests/data/6F87040E.pubkey , tests/data/6F87040E-cr.pubkey , tests/data/v3.key , tests/data/primary-binding.gpg , tests/data/pki-password.txt , tests/data/symmetric-password.txt , tests/data/encryption-sym-aes256-s2k0.gpg , tests/data/encryption-sym-aes128-s2k0.gpg , tests/data/encryption-sym-aes128.gpg , tests/data/encryption-sym-aes256.gpg , tests/data/encryption-sym-3des-s2k0.gpg , tests/data/encryption-sym-3des.gpg , tests/data/encryption-sym-aes192-s2k0.gpg , tests/data/encryption-sym-aes192.gpg , tests/data/encryption-sym-blowfish-s2k0.gpg , tests/data/encryption-sym-blowfish.gpg , tests/data/encryption-sym-twofish-s2k0.gpg , tests/data/encryption-sym-twofish.gpg , tests/data/encryption-sym-cast5-mdc-s2k0.gpg , tests/data/encryption-sym-cast5-mdc.gpg , tests/data/encryption-sym-blowfish-mdc-s2k0.gpg , tests/data/encryption-sym-blowfish-mdc.gpg , tests/data/encryption-sym-3des-mdc-s2k0.gpg , tests/data/encryption-sym-3des-mdc.gpg , tests/data/encryption-sym-cast5.gpg , tests/data/encryption-sym-cast5-s2k0.gpg , tests/data/encryption-sym-camellia128.gpg , tests/data/encryption-sym-camellia128-s2k0.gpg , tests/data/encryption-sym-camellia192.gpg , tests/data/encryption-sym-camellia256.gpg , tests/data/16bitcksum.seckey , tests/data/aes256-sha512.seckey , tests/data/unencrypted.seckey , tests/data/v3-genericcert.sig , tests/data/revoked.pubkey , tests/data/expired.pubkey , tests/data/sigs-with-regexes , tests/data/gnu-dummy-s2k-101-secret-key.gpg , tests/data/anibal-ed25519.gpg , tests/data/nist_p-256_key.gpg , tests/data/nist_p-256_secretkey.gpg , tests/data/ecdsa-key-without-ecdh.pubkey , tests/data/sample-eddsa.pubkey , tests/data/v6-secret.pgp.aa , tests/data/v6.rev.aa , tests/data/ed25519-without-curve25519.pubkey , tests/data/ed25519.pubkey , tests/data/ed25519.secretkey , tests/data/encryption-sym-pgcrypto.pgp , tests/data/pgcrypto-passphrase.txt , tests/data/v6-secret.pgp.aa , tests/data/v6.rev.aa , tests/data/v6-encrypted-secret.pgp.aa , tests/data/v6-encrypted.rev.aa , tests/data/seipdv2.pgp.aa , tests/data/seipdv2-for-v4-key.pgp.aa , tests/data/v4-encrypted-secret.pgp.aa , tests/data/v4-encrypted.rev.aa , tests/data/seipdv2-three-recipients.pgp.aa , tests/data/seipdv2-two-recipients.pgp.aa , tests/data/encryption-sym-aes256-sha256.pgp flag use-memory description: Use the 'memory' package instead of 'ram' default: False common deps build-depends: aeson >= 2.0 && < 3 , attoparsec , base > 4.9 && < 5 , base16-bytestring , bifunctors , bytestring , binary >= 0.6.4.0 , binary-conduit >= 1.3 , bz2 , conduit >= 1.3.0 , conduit-extra >= 1.1 , containers , crypto-cipher-types , errors , hashable >= 1.3.4 && <1.6 , incremental-parser >= 0.5.1 , ixset-typed , lens >= 3.0 , monad-loops , nettle , network-uri >= 2.6 , prettyprinter >= 1.7.0 , resourcet > 0.4 , split , text , time >= 1.1 , time-locale-compat , transformers , unliftio-core , unordered-containers , zlib if flag(use-memory) build-depends: crypton < 1.1.0, memory else build-depends: crypton >= 1.1.0, ram common publicmods other-modules: Codec.Encryption.OpenPGP.Types , Codec.Encryption.OpenPGP.CFB , Codec.Encryption.OpenPGP.Message , Codec.Encryption.OpenPGP.Compression , Codec.Encryption.OpenPGP.Encrypt , Codec.Encryption.OpenPGP.Expirations , Codec.Encryption.OpenPGP.Fingerprint , Codec.Encryption.OpenPGP.KeyInfo , Codec.Encryption.OpenPGP.KeyringParser , Codec.Encryption.OpenPGP.KeySelection , Codec.Encryption.OpenPGP.Ontology , Codec.Encryption.OpenPGP.Policy , Codec.Encryption.OpenPGP.S2K , Codec.Encryption.OpenPGP.SecretKey , Codec.Encryption.OpenPGP.Serialize , Codec.Encryption.OpenPGP.Signatures , Codec.Encryption.OpenPGP.SignatureQualities , Codec.Encryption.OpenPGP.Subpackets , Data.Conduit.OpenPGP.Compression , Data.Conduit.OpenPGP.Decrypt , Data.Conduit.OpenPGP.Filter , Data.Conduit.OpenPGP.Keyring , Data.Conduit.OpenPGP.Keyring.Instances , Data.Conduit.OpenPGP.Message , Data.Conduit.OpenPGP.Verify common internalmods other-modules: Codec.Encryption.OpenPGP.Internal , Codec.Encryption.OpenPGP.Internal.CryptoAES , Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes , Codec.Encryption.OpenPGP.Internal.CryptoECDH , Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 , Codec.Encryption.OpenPGP.Internal.Crypton , Codec.Encryption.OpenPGP.Internal.HOBlockCipher , Codec.Encryption.OpenPGP.Internal.RFC7253OCB , Codec.Encryption.OpenPGP.Types.Internal.Base , Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes , Codec.Encryption.OpenPGP.Types.Internal.PKITypes , Codec.Encryption.OpenPGP.Types.Internal.PacketClass , Codec.Encryption.OpenPGP.Types.Internal.Pkt , Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils , Codec.Encryption.OpenPGP.Types.Internal.TK , Codec.Encryption.OpenPGP.BlockCipher , Codec.Encryption.OpenPGP.SerializeForSigs , Paths_hOpenPGP autogen-modules: Paths_hOpenPGP Library import: deps, internalmods Exposed-modules: Codec.Encryption.OpenPGP.Types , Codec.Encryption.OpenPGP.CFB , Codec.Encryption.OpenPGP.Message , Codec.Encryption.OpenPGP.Compression , Codec.Encryption.OpenPGP.Encrypt , Codec.Encryption.OpenPGP.Expirations , Codec.Encryption.OpenPGP.Fingerprint , Codec.Encryption.OpenPGP.KeyInfo , Codec.Encryption.OpenPGP.KeyringParser , Codec.Encryption.OpenPGP.KeySelection , Codec.Encryption.OpenPGP.Ontology , Codec.Encryption.OpenPGP.Policy , Codec.Encryption.OpenPGP.S2K , Codec.Encryption.OpenPGP.SecretKey , Codec.Encryption.OpenPGP.Serialize , Codec.Encryption.OpenPGP.Signatures , Codec.Encryption.OpenPGP.SignatureQualities , Codec.Encryption.OpenPGP.Subpackets , Codec.Encryption.OpenPGP.Version , Data.Conduit.OpenPGP.Compression , Data.Conduit.OpenPGP.Decrypt , Data.Conduit.OpenPGP.Filter , Data.Conduit.OpenPGP.Keyring , Data.Conduit.OpenPGP.Keyring.Instances , Data.Conduit.OpenPGP.Message , Data.Conduit.OpenPGP.Verify Build-depends: asn1-encoding , openpgp-asciiarmor >= 1.0 default-language: Haskell2010 Test-Suite tests import: deps, publicmods, internalmods type: exitcode-stdio-1.0 hs-source-dirs: . tests main-is: suite.hs other-modules: Codec.Encryption.OpenPGP.Arbitrary , Tests.Common , Tests.Encryption , Tests.Keys , Tests.MessageAndArmor , Tests.Properties , Tests.Serialization , Tests.Utilities Ghc-options: -Wall -with-rtsopts=-K1K Build-depends: hOpenPGP , tasty , tasty-hunit , tasty-quickcheck , QuickCheck > 2.9 , quickcheck-instances , openpgp-asciiarmor >= 1.0 default-language: Haskell2010 Benchmark benchmark import: deps, publicmods, internalmods type: exitcode-stdio-1.0 main-is: bench/mark.hs Ghc-options: -Wall Build-depends: hOpenPGP , criterion > 0.8 , openpgp-asciiarmor >= 1.0 default-language: Haskell2010 source-repository head type: git location: https://salsa.debian.org/clint/hOpenPGP.git source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git tag: v3.0.2.1 hOpenPGP-3.0.2.1/tests/Tests/0000755000000000000000000000000007346545000013730 5ustar0000000000000000hOpenPGP-3.0.2.1/tests/Tests/Common.hs0000644000000000000000000015324607346545000015527 0ustar0000000000000000-- Common.hs: hOpenPGP test suite -- 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 hOpenPGP-3.0.2.1/tests/Tests/Encryption.hs0000644000000000000000000070665107346545000016435 0ustar0000000000000000-- Encryption.hs: hOpenPGP test suite -- 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) hOpenPGP-3.0.2.1/tests/Tests/Keys.hs0000644000000000000000000021355007346545000015205 0ustar0000000000000000-- Keys.hs: hOpenPGP test suite -- 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" hOpenPGP-3.0.2.1/tests/Tests/MessageAndArmor.hs0000644000000000000000000024645507346545000017314 0ustar0000000000000000-- MessageAndArmor.hs: hOpenPGP test suite -- 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 () hOpenPGP-3.0.2.1/tests/Tests/Properties.hs0000644000000000000000000003051207346545000016421 0ustar0000000000000000-- Properties.hs: hOpenPGP test suite -- 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.Properties (propertiesTests) where import Codec.Encryption.OpenPGP.Encrypt (canonicalizePKESKRecipientId) import Codec.Encryption.OpenPGP.Policy (OpenPGPPolicy(..), OpenPGPRFC(RFC4880), defaultPolicy, policyForRFC) import Codec.Encryption.OpenPGP.KeyringParser (parseTKsWithWireRep) import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey, encryptPrivateKey) import Codec.Encryption.OpenPGP.Serialize (parsePktsEither, parsePktsWithWireRep) import Codec.Encryption.OpenPGP.Types import Control.Exception (SomeException, try) import Data.Binary (get, put) import Data.Binary.Put (runPut) import qualified Data.ByteString.Lazy as BL import qualified Data.Conduit as DC import qualified Data.Conduit.List as CL import Data.Word (Word8) import Test.Tasty (TestTree, localOption, testGroup) import qualified Test.Tasty.QuickCheck as QC import Tests.Common ( collectSecretKeyInfos , conduitDecryptWithPKESKContext , loadSEIPDv2FixtureWithV4Secret , loadV4EncryptedSecretKeyFixtureForProperty , loadV6UnencryptedSecretKeyFixtureForProperty , prependUnusableLatestPKESK , readFixtureLazy , reorderPrecedingPKESKs , reverseIf , runGet , selectRecipientKeyInfo ) propertiesTests :: TestTree propertiesTests = testGroup "Properties" [qcProps] qcProps :: TestTree qcProps = testGroup "(checked by QuickCheck)" [ QC.testProperty "PKESKv3 packet serialization-deserialization" $ \pkesk -> Right (pkesk :: PKESK 'PKESKV3) == runGet get (runPut (put pkesk)) , QC.testProperty "PKESKv6 packet serialization-deserialization" $ \pkesk -> Right (pkesk :: PKESK 'PKESKV6) == runGet get (runPut (put pkesk)) , QC.testProperty "Signature packet serialization-deserialization" $ \sig -> (case _signaturePayload (sig :: Signature) of SigVOther _ _ -> False _ -> True) QC.==> Right (sig :: Signature) == runGet get (runPut (put sig)) , QC.testProperty "UserId packet serialization-deserialization" $ \uid -> Right (uid :: UserId) == runGet get (runPut (put uid)) , QC.testProperty "decryptPrivateKey (encryptPrivateKey sk pw) pw equivalence" $ \passphraseNE -> QC.ioProperty $ do fixture <- loadV6UnencryptedSecretKeyFixtureForProperty case fixture of Left err -> pure (QC.counterexample err False) Right (pkp, ska, expectedSKey) -> do let passphraseChars = (QC.getNonEmpty passphraseNE :: String) passphrase = BL.pack (map (fromIntegral . fromEnum) passphraseChars) encryptedResult <- encryptPrivateKey defaultPolicy pkp ska passphrase pure $ case encryptedResult of Left err -> QC.counterexample ("encryptPrivateKey failed: " ++ err) False Right encryptedSKA -> case decryptPrivateKey (pkp, encryptedSKA) passphrase of Left err -> QC.counterexample ("decryptPrivateKey failed: " ++ err) False Right (SUUnencrypted skey _) -> QC.counterexample "secret key material changed across encrypt/decrypt roundtrip" (skey == expectedSKey) Right other -> QC.counterexample ("expected SUUnencrypted after decrypting encrypted key, got: " ++ show other) False , localOption (QC.QuickCheckTests 5) (QC.testProperty "decryptPrivateKey (encryptPrivateKey v4sk pw) pw equivalence" $ QC.ioProperty $ do fixture <- loadV4EncryptedSecretKeyFixtureForProperty case fixture of Left err -> pure (QC.counterexample err False) Right (pkp, ska, expectedSKey, passphrase) -> do let legacyOverridePolicy :: OpenPGPPolicy legacyOverridePolicy = (policyForRFC RFC4880) { policySecretKeyProtection = policySecretKeyProtection defaultPolicy } encryptedResult <- encryptPrivateKey legacyOverridePolicy pkp ska passphrase pure $ case encryptedResult of Left err -> QC.counterexample ("encryptPrivateKey failed under legacy override policy: " ++ err) False Right encryptedSKA -> case decryptPrivateKey (pkp, encryptedSKA) passphrase of Left err -> QC.counterexample ("decryptPrivateKey failed: " ++ err) False Right (SUUnencrypted skey _) -> QC.counterexample "v4 secret key material changed across encrypt/decrypt roundtrip" (skey == expectedSKey) Right other -> QC.counterexample ("expected SUUnencrypted after decrypting v4 encrypted key, got: " ++ show other) False) , QC.testProperty "canonicalizePKESKRecipientId idempotence on valid v4/v6 recipient ids" propertyCanonicalizePKESKRecipientIdIdempotent , localOption (QC.QuickCheckTests 10) (QC.testProperty "canonicalizeTKStructuredWithWireRep is stable across packet/sig reordering" propertyCanonicalizeTKStructuredStableAcrossReordering) , localOption (QC.QuickCheckTests 1) (QC.testProperty "recipient selection remains decryptable with extra unusable PKESK candidates" propertyRecipientSelectionMonotonicWithUnusableCandidates) , QC.testProperty "parsePktsEither does not accept truncated packet streams as intact packets" propertyParsePktsEitherRejectsTruncatedPacketStream ] propertyCanonicalizePKESKRecipientIdIdempotent :: Bool -> Bool -> [Word8] -> QC.Property propertyCanonicalizePKESKRecipientIdIdempotent useV6 prefixed seedBytes = case canonicalizePKESKRecipientId payload of Left err -> QC.counterexample ("canonicalizePKESKRecipientId unexpectedly failed: " ++ show err) False Right canonical -> QC.counterexample "canonicalizePKESKRecipientId should be idempotent" (canonicalizePKESKRecipientId canonical == Right canonical) where targetLen = if useV6 then 32 else 20 versionOctet = if useV6 then 0x06 else 0x04 ridBody = BL.pack (take targetLen (seedBytes ++ repeat 0x00)) rid | prefixed = BL.cons versionOctet ridBody | otherwise = ridBody payload = PKESKPayloadV6Packet (PKESKPayloadV6 rid RSA "esk") propertyCanonicalizeTKStructuredStableAcrossReordering :: QC.NonNegative Int -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> QC.Property propertyCanonicalizeTKStructuredStableAcrossReordering (QC.NonNegative indexSeed) reverseDirect reverseUIDs reverseUIDSigs reverseUATs reverseUATSigs reverseSubs reverseSubSigs = QC.ioProperty $ do lbs <- readFixtureLazy "pubring.gpg" let src = wireRepRef lbs parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs) if null parsed then pure (QC.counterexample "pubring.gpg parsed to no TKWithWireRep values" False) else do let tk = parsed !! (indexSeed `mod` length parsed) pure $ case toStructuredTKWithWireRep tk of Left err -> QC.counterexample ("toStructuredTKWithWireRep failed: " ++ err) False Right structured -> let shuffled = structured { _tkStructuredDirectSignatures = reverseIf reverseDirect (_tkStructuredDirectSignatures structured) , _tkStructuredUIDs = reverseIf reverseUIDs (map (\uid -> uid { _uidWithWireRefsSignatures = reverseIf reverseUIDSigs (_uidWithWireRefsSignatures uid) }) (_tkStructuredUIDs structured)) , _tkStructuredUAts = reverseIf reverseUATs (map (\uat -> uat { _uatWithWireRefsSignatures = reverseIf reverseUATSigs (_uatWithWireRefsSignatures uat) }) (_tkStructuredUAts structured)) , _tkStructuredSubkeys = reverseIf reverseSubs (map (\sub -> sub { _subkeyWithWireRefsSignatures = reverseIf reverseSubSigs (_subkeyWithWireRefsSignatures sub) }) (_tkStructuredSubkeys structured)) } in case (canonicalizeTKStructuredWithWireRep structured, canonicalizeTKStructuredWithWireRep shuffled) of (Right canonicalBase, Right canonicalShuffled) -> QC.counterexample "canonicalization should be stable under packet/sig reordering" (canonicalBase == canonicalShuffled) (Left err, _) -> QC.counterexample ("canonicalizeTKStructuredWithWireRep failed on base: " ++ show err) False (_, Left err) -> QC.counterexample ("canonicalizeTKStructuredWithWireRep failed on shuffled: " ++ show err) False propertyRecipientSelectionMonotonicWithUnusableCandidates :: QC.NonNegative Int -> Bool -> QC.Property propertyRecipientSelectionMonotonicWithUnusableCandidates (QC.NonNegative extraBogus) reorderPKESKs = QC.ioProperty $ do let applyBogus = foldr (.) id (replicate (extraBogus `mod` 5) prependUnusableLatestPKESK) transformPackets | reorderPKESKs = applyBogus . reorderPrecedingPKESKs | otherwise = applyBogus result <- (try $ do (messagePacketsRaw, encryptedSecretPackets, passphrase) <- loadSEIPDv2FixtureWithV4Secret "seipdv2-three-recipients.pgp.aa" keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase let messagePackets = transformPackets messagePacketsRaw passphraseCallback _ = pure BL.empty keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) decrypted <- DC.runConduitRes $ CL.sourceList messagePackets DC..| conduitDecryptWithPKESKContext keyContextCallback passphraseCallback DC..| CL.consume pure (any (not . BL.null) [payload | LiteralDataPkt _ _ _ payload <- decrypted])) :: IO (Either SomeException Bool) case result of Left e -> pure $ QC.counterexample ("recipient selection should remain decryptable despite added unusable candidates: " ++ show e) False Right didDecrypt -> pure $ QC.counterexample "recipient selection should still yield a non-empty decrypted literal payload" didDecrypt propertyParsePktsEitherRejectsTruncatedPacketStream :: PKESK 'PKESKV6 -> QC.Positive Int -> QC.Property propertyParsePktsEitherRejectsTruncatedPacketStream pkesk (QC.Positive cutSeed) = case parsePktsEither truncated of Left _ -> QC.property True Right parsed -> QC.counterexample ("parsePktsEither unexpectedly treated truncated packet stream as original packet: " ++ show parsed) (parsed /= [toPkt pkesk]) where encoded = runPut (put (toPkt pkesk)) cut = fromIntegral (1 + (cutSeed `mod` fromIntegral (BL.length encoded))) truncated = BL.take (BL.length encoded - cut) encoded hOpenPGP-3.0.2.1/tests/Tests/Serialization.hs0000644000000000000000000011042607346545000017105 0ustar0000000000000000-- Serialization.hs: hOpenPGP test suite -- 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 hOpenPGP-3.0.2.1/tests/Tests/Utilities.hs0000644000000000000000000014664207346545000016254 0ustar0000000000000000-- Utilities.hs: hOpenPGP test suite -- 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) hOpenPGP-3.0.2.1/tests/data/0000755000000000000000000000000007346545000013537 5ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000001-006.public_key0000644000000000000000000000025307346545000016632 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~hOpenPGP-3.0.2.1/tests/data/000003-002.sig0000644000000000000000000000016107346545000015262 0ustar0000000000000000o0OwITesting revsig ^#A2biBV#WY#-B>,[> $x yfu 38#hOpenPGP-3.0.2.1/tests/data/000004-012.ring_trust0000644000000000000000000000000407346545000016676 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000005-002.sig0000644000000000000000000000016107346545000015264 0ustar0000000000000000o0OwIDtesting revsig ^#A2b>+ #1ѽ^Qmz6!$W+6+TQeL[3Gl/hOpenPGP-3.0.2.1/tests/data/000006-012.ring_trust0000644000000000000000000000000407346545000016700 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000007-002.sig0000644000000000000000000000033407346545000015270 0ustar0000000000000000(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-3.0.2.1/tests/data/000008-012.ring_trust0000644000000000000000000000000407346545000016702 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000009-002.sig0000644000000000000000000000023607346545000015273 0ustar0000000000000000OwHw >hm´#pBjH t_%*Y/V;k.Yy7%;z(Pvn*_7JD+&*,il)c Y3n]U}aD|"[N#ahOpenPGP-3.0.2.1/tests/data/000010-012.ring_trust0000644000000000000000000000000407346545000016673 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000011-002.sig0000644000000000000000000000014007346545000015256 0ustar0000000000000000^OwI5 ^#A2bQ>&P{k-aعl nqaѡ0!Y꾹gkv0HjhOpenPGP-3.0.2.1/tests/data/000012-012.ring_trust0000644000000000000000000000000407346545000016675 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000013-014.public_subkey0000644000000000000000000000025307346545000017346 0ustar0000000000000000Ow$ພo# \X" l9Nv`x]pBA hzSX[s'S4~#{T V`;~ 'o]3U.-Psڮ>S}%Nbx%9mˣ^l":C*=hOpenPGP-3.0.2.1/tests/data/000014-002.sig0000644000000000000000000000030307346545000015262 0ustar0000000000000000Ow$  π No9R \R^mNʖlysQ%x=ӿbG"lf!%F*w͎gL#!^_ql5qWe/< 0k)sL34ʺmEy$éH#TP.f\w=j4akhOpenPGP-3.0.2.1/tests/data/000015-012.ring_trust0000644000000000000000000000000407346545000016700 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000016-006.public_key0000644000000000000000000000226107346545000016641 0ustar0000000000000000Ow m] yayT*p}GLE!SH)䃉4ŷQ,lŖF!b 4ދj;R  4<ްoz})Q6\R2y俓ܣ%}U|n;[ m @t9N\ߊW 4d*\ #KP E6)R߶l#0ӚBD`^.{{m#}gGV+ 6!b7Fa'Y J-`L4cWM9[E}U+0'3/HKfxpΞ{E*DQ:j oB&mK&_ S2B_"#0NEuFrV5m`sm렖}X4/H R-;548[,_zk\6"WLR ׁ*PieK6d*e5ͰF2HƩm&ވ0MO3e*5<*hp;gv-SIJZ8xRaZܗQDY,css9AO5 `]BQayl9J r t7sKamK . eDH Dqœ;B=zDky[dwz-ůnga5uTjgat̑LL]hOpenPGP-3.0.2.1/tests/data/000017-002.sig0000644000000000000000000000017307346545000015272 0ustar0000000000000000y!OwJ  /Z\þw2Ϙc ^#A2b& bta=0)Ҷ?9pɼRORͤ[L]ڳ,}pcï-`+LѰhOpenPGP-3.0.2.1/tests/data/000018-012.ring_trust0000644000000000000000000000000407346545000016703 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000019-013.user_id0000644000000000000000000000004607346545000016145 0ustar0000000000000000$Test Key (DSA) hOpenPGP-3.0.2.1/tests/data/000020-002.sig0000644000000000000000000000020207346545000015255 0ustar0000000000000000(Ow    ^#A2bܯgi\Q$`;! 873?wNj*rK%% Aý~uhOpenPGP-3.0.2.1/tests/data/000021-012.ring_trust0000644000000000000000000000000407346545000016675 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000022-002.sig0000644000000000000000000000027207346545000015266 0ustar0000000000000000OwH4 NowMy/]GYjZU8{Sc!Q'VJ""[zT|ĽX]`qdD+Ւ !BwR'+iDm@ (ǘQصf.^3mw8P*}(Qwrdx')mqVP2g wa mG >\$B6C;i^4RhOpenPGP-3.0.2.1/tests/data/000025-002.sig0000644000000000000000000000015107346545000015265 0ustar0000000000000000gOw   ^#A2b)$[OX`J`6\I[o?u<wGkt˨\A]gM^"߶/HhOpenPGP-3.0.2.1/tests/data/000026-012.ring_trust0000644000000000000000000000000407346545000016702 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000027-006.public_key0000644000000000000000000000064507346545000016647 0ustar0000000000000000Ow3!$}9 W̳us<,?#/ `N["cgU[In?60tw&U8j,K|7[Cb|p6.oaV1aS"oՍ)6W.=='%WgDڤDAmiԚr8h>$B/'tMZ ַk(Txg^;?Q#׻HD?HgQW-i|rKHA B,GO>G9ٓfp',6n?טYT/ ?XvT:`p/y){0ϜFw7νyV_3v }yNi[͙\zC?9A$YhOpenPGP-3.0.2.1/tests/data/000028-002.sig0000644000000000000000000000014307346545000015271 0ustar0000000000000000a!OwJ y3EY >hm w2ϘcnA_-]joyp&e2r ؠXhOpenPGP-3.0.2.1/tests/data/000029-012.ring_trust0000644000000000000000000000000407346545000016705 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000030-013.user_id0000644000000000000000000000005507346545000016136 0ustar0000000000000000+Test Key (DSA sign-only) hOpenPGP-3.0.2.1/tests/data/000031-002.sig0000644000000000000000000000020407346545000015261 0ustar0000000000000000B   OwItesting@notation w2Ϙcꆸ-&iDš$)`Sg<hOpenPGP-3.0.2.1/tests/data/000032-012.ring_trust0000644000000000000000000000000407346545000016677 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000033-002.sig0000644000000000000000000000014007346545000015262 0ustar0000000000000000^OwHT ^#A2b0$LM ɑ(;濂X/t+2f]9"W=O!}co*(:UhOpenPGP-3.0.2.1/tests/data/000034-012.ring_trust0000644000000000000000000000000407346545000016701 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000035-006.public_key0000644000000000000000000000021707346545000016641 0ustar0000000000000000Ow!ž%Jo_-0=!t֤70#M\d&KnHyI Qm PG;RLjF!"N$9t98wvW"I%/̈LNСz Ny hOpenPGP-3.0.2.1/tests/data/000036-013.user_id0000644000000000000000000000006007346545000016140 0ustar0000000000000000.Test Key (RSA sign-only) hOpenPGP-3.0.2.1/tests/data/000037-002.sig0000644000000000000000000000030007346545000015264 0ustar0000000000000000(Ow! hmAD&5Ԝjmg^y]bnKA;x˲BT[DwQ%2rwEB b;ʴY;n@%̓fZ~qᏦ8ۋjxUB*__N~v׏qk#ĸ*:` `†?'FJt)n:StƢ5Nllj::^61 6NB |]\Idg=TD@VTDŽ?S֤~O?Z{tf¢uU9uRąCH 9A̭ă_]N)0Tuڞ\_Z|Q_O>t|Tp7 ۏq@ L_mMQCQb_$$((`_Up Taohqe3d"kH& LVO"=7*R(q7JJ!q{yE+"1Rf#ĥK JE@Mԑs:\>;QZېs 6= 28`zޭXRxY;w$$-Lş6KITAQFʧ5=4 (6{ e]`"YmXqu4rj2\YFJB tB6ꞡjrTit0BUtsȹ~;v;^qRQ5->o!IH! M4vn f"d\\SfJB/S/$=RA~ܲfiuErYtw!@ ˂>NU{pVQUee R%7Zl1㟞*liuovo|c{["*QrߓC@1'ZA~mf˶<'pL؋p$Hh* %@$ň#j۲UD6ֶ$$n4hګ VTs@39yF5YN!Ч\[FuqtVorF~Q1LhS.ڊMqt ?sFoUS$3tupѧSȆE- 6ZĤ8LzjQ,_B]BIQDs4hMLOs3>d3kpS(?71<\S~8ԾNKTw@āv-NcP'S ̑][`T \ƦKOҢTT\((*$H!FXm'2` G)&cW4aKMqlE3ٲ( uАQL\Jo_~ +­Dx:sTj_hOpenPGP-3.0.2.1/tests/data/000042-002.sig0000644000000000000000000000030007346545000015260 0ustar0000000000000000(OwL hmdi!Սyǜ+d1A(}=M4 BvSu [TXq, %f8o; m *At'|Fg0]%]%yޡ UVC~d:+5 uhOpenPGP-3.0.2.1/tests/data/000043-012.ring_trust0000644000000000000000000000000407346545000016701 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000044-014.public_subkey0000644000000000000000000000042007346545000017346 0ustar0000000000000000 OwJGgC!_ZGk렂=KsxH-!*nLvXFw|#W,l;qfO^>3(@ 8hm߰yb)Qx0+G7ld:`c/ ~ڶTG̔Cr=0n~83aQ_zIN\|Sa8e`dqr#dW>}P끩hOpenPGP-3.0.2.1/tests/data/000046-012.ring_trust0000644000000000000000000000000407346545000016704 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000047-005.secret_key0000644000000000000000000000114207346545000016650 0ustar0000000000000000_Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~mW3W%O:`X~8%d\ٺ§'hOpenPGP-3.0.2.1/tests/data/000048-013.user_id0000644000000000000000000000004607346545000016147 0ustar0000000000000000$Test Key (RSA) hOpenPGP-3.0.2.1/tests/data/000049-002.sig0000644000000000000000000000033407346545000015276 0ustar0000000000000000(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-3.0.2.1/tests/data/000050-012.ring_trust0000644000000000000000000000000407346545000016677 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000051-007.secret_subkey0000644000000000000000000000114307346545000017360 0ustar0000000000000000`Ow$ພo# \X" l9Nv`x]pBA hzSX[s'S4~#{T V`;~ 'o]3U.-Psڮ>S}%Nbx%9mˣ^l":C*=emGM`A]Q$VamQX&nySRw!+ˑk^IW!4HX`5yKh4nQ?ՙthSM]$f/\Ts,FJwJ^Il2k0!xU;/̶̪a}>F7AL}ΚtP6n|iqq«VWzjkv-iV $=d/B9KʋTp%a *' : r$4* @OM2Whu}Va v< YG="ӱRf Q/swn 7 ưUl4ߕ,jLv)DÎyhl4YhOpenPGP-3.0.2.1/tests/data/000052-002.sig0000644000000000000000000000030307346545000015264 0ustar0000000000000000Ow$  π No9R \R^mNʖlysQ%x=ӿbG"lf!%F*w͎gL#!^_ql5qWe/< 0k)sL34ʺmEy$éH#TP.f\w=j4akhOpenPGP-3.0.2.1/tests/data/000053-012.ring_trust0000644000000000000000000000000407346545000016702 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000054-005.secret_key0000644000000000000000000000237307346545000016655 0ustar0000000000000000Ow m] yayT*p}GLE!SH)䃉4ŷQ,lŖF!b 4ދj;R  4<ްoz})Q6\R2y俓ܣ%}U|n;[ m @t9N\ߊW 4d*\ #KP E6)R߶l#0ӚBD`^.{{m#}gGV+ 6!b7Fa'Y J-`L4cWM9[E}U+0'3/HKfxpΞ{E*DQ:j oB&mK&_ S2B_"#0NEuFrV5m`sm렖}X4/H R-;548[,_zk\6"WLR ׁ*PieK6d*e5ͰF2HƩm&ވ0MO3e*5<*hp;gv-SIJZ8xRaZܗQDY,css9AO5 `]BQayl9J r t7sKamK . eDH Dqœ;B=zDky[dwz-ůnga5uTjgat̑LL]gׁ`vE%nOqaWqrn!`i}lw!B&{b]+GQ hOpenPGP-3.0.2.1/tests/data/000055-002.sig0000644000000000000000000000017307346545000015274 0ustar0000000000000000y!OwJ  /Z\þw2Ϙc ^#A2b& bta=0)Ҷ?9pɼRORͤ[L]ڳ,}pcï-`+LѰhOpenPGP-3.0.2.1/tests/data/000056-012.ring_trust0000644000000000000000000000000407346545000016705 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000057-013.user_id0000644000000000000000000000004607346545000016147 0ustar0000000000000000$Test Key (DSA) hOpenPGP-3.0.2.1/tests/data/000058-002.sig0000644000000000000000000000020207346545000015270 0ustar0000000000000000(Ow    ^#A2bܯgi\Q$`;! 873?wNj*rK%% Aý~uhOpenPGP-3.0.2.1/tests/data/000059-012.ring_trust0000644000000000000000000000000407346545000016710 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000060-007.secret_subkey0000644000000000000000000000127207346545000017363 0ustar0000000000000000Ow @7la Ua?a`K䠳q{Ü@H2{'2i0  D+=6h8k]NmY\}]X+%T|T̠ =%VubD;^`钘/hĢfFj㬒vA$_,G]aNz5ͽ w?

(ǘQصf.^3mw8P*}(Qwrdx')mqVP2g wa mG >\$B6C;i^4Rgׁ`A0ʭerT$fJ{y!TM{2XIסtWaʞ+hOpenPGP-3.0.2.1/tests/data/000061-002.sig0000644000000000000000000000015007346545000015264 0ustar0000000000000000fOw   ^#A2b)$ ::y!cƋI3b;@{S?bSZV9ިPMhOpenPGP-3.0.2.1/tests/data/000062-012.ring_trust0000644000000000000000000000000407346545000016702 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000063-005.secret_key0000644000000000000000000000074407346545000016655 0ustar0000000000000000Ow3!$}9 W̳us<,?#/ `N["cgU[In?60tw&U8j,K|7[Cb|p6.oaV1aS"oՍ)6W.=='%WgDڤDAmiԚr8h>$B/'tMZ ַk(Txg^;?Q#׻HD?HgQW-i|rKHA B,GO>G9ٓfp',6n?טYT/ ?XvT:`p/y){0ϜFw7νyV_3v }yNi[͙\zC?9A$YZ".ܵh``(S -lNwF5B`l m)hOpenPGP-3.0.2.1/tests/data/000064-002.sig0000644000000000000000000000014307346545000015271 0ustar0000000000000000a!OwJ y3EY >hm w2ϘcnA_-]joyp&e2r ؠXhOpenPGP-3.0.2.1/tests/data/000065-012.ring_trust0000644000000000000000000000000407346545000016705 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000066-013.user_id0000644000000000000000000000005507346545000016147 0ustar0000000000000000+Test Key (DSA sign-only) hOpenPGP-3.0.2.1/tests/data/000067-002.sig0000644000000000000000000000015207346545000015274 0ustar0000000000000000h(Ow    w2ϘczHm5YDBT!.ADs48$Q9H>jhOpenPGP-3.0.2.1/tests/data/000068-012.ring_trust0000644000000000000000000000000407346545000016710 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000069-005.secret_key0000644000000000000000000000100107346545000016646 0ustar0000000000000000Ow!ž%Jo_-0=!t֤70#M\d&KnHyI Qm PG;RLjF!"N$9t98wvW"I%/̈LNСz Ny  WA/`++oXbN,9KpPwR,l&p<ǻ\n>+;I Sl Xr Ju#ʶK&Λ_o7HBߙAzHkWp`4dl LJ"`H.lۏ'O4]4,X3܉O'q)u]hhHi'KI>1/L,ڀT R6Z7VA,,&|yrXh,@@D:7k=0sD2އFcOq~8gU;[U 4AT}G J6>?9by$(A\vծ:Qe`0*(hOpenPGP-3.0.2.1/tests/data/000070-013.user_id0000644000000000000000000000006007346545000016136 0ustar0000000000000000.Test Key (RSA sign-only) hOpenPGP-3.0.2.1/tests/data/000071-002.sig0000644000000000000000000000030007346545000015262 0ustar0000000000000000(Ow! hmAD&5Ԝjmg^y]bnKA;x˲BT[DwQ%2rwEB b;ʴY;n@%̓fZ~qᏦ8ۋjxUB*__N~v׏qk#ĸ*:` `†?'FJt)n:StƢ5Nllj::^61 6NB |]\Idg=TD@VTDŽ?S֤~O?Z{tf¢uU9uRąCH 9A̭ă_]N)0Tuڞ\_Z|Q_O>t|Tp7 ۏq@ L_mMQCQb_$$((`_Up Taohqe3d"kH& LVO"=7*R(q7JJ!q{yE+"1Rf#ĥK JE@Mԑs:\>;QZېs 6= 28`zޭXRxY;w$$-Lş6KITAQFʧ5=4 (6{ e]`"YmXqu4rj2\YFJB tB6ꞡjrTit0BUtsȹ~;v;^qRQ5->o!IH! M4vn f"d\\SfJB/S/$=RA~ܲfiuErYtw!@ ˂>NU{pVQUee R%7Zl1㟞*liuovo|c{["*QrߓC@1'ZA~mf˶<'pL؋p$Hh* %@$ň#j۲UD6ֶ$$n4hګ VTs@39yF5YN!Ч\[FuqtVorF~Q1LhS.ڊMqt ?sFoUS$3tupѧSȆE- 6ZĤ8LzjQ,_B]BIQDs4hMLOs3>d3kpS(?71<\S~8ԾNKTw@āv-NcP'S ̑][`T \ƦKOҢTT\((*$H!FXm'2` G)&cW4aKMqlE3ٲ( uАQL\Jo_~ +­Dx:sTj_hOpenPGP-3.0.2.1/tests/data/000074-002.sig0000644000000000000000000000030007346545000015265 0ustar0000000000000000(OwL hmdi!Սyǜ+d1A(}=M4 BvSu [TXq, %f8o; m *At'|Fg0]%]%yޡ UVC~d:+5 uhOpenPGP-3.0.2.1/tests/data/000075-012.ring_trust0000644000000000000000000000000407346545000016706 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/000076-007.secret_subkey0000644000000000000000000000170107346545000017367 0ustar0000000000000000OwJGgC!_ZGk렂=KsxH-!*nLvXFw|#W,l;qfO^>3(@ 8A ̇کv4'gb2R!e.}񀙱ltM?E-]5ds1\Z7_MեZC)'MB4gȇIİLJ3JX< |4NW~AG}5[BaCrj/"͒u6 t=pjZ}Eh2:ZN<NcIVPDaP6Sd ׶P(sQ+'Jy!ڿ`{? bh5׽ OaD\2Vޖtr#'dWB_'<{ O,L , hd(&%/{3F){٬m5_YStuCCb̐hOpenPGP-3.0.2.1/tests/data/000077-002.sig0000644000000000000000000000024107346545000015274 0ustar0000000000000000 OwJ >hm߰yb)Qx0+G7ld:`c/ ~ڶTG̔Cr=0n~83aQ_zIN\|Sa8e`dqr#dW>}P끩hOpenPGP-3.0.2.1/tests/data/000078-012.ring_trust0000644000000000000000000000000407346545000016711 0ustar0000000000000000hOpenPGP-3.0.2.1/tests/data/16bitcksum.seckey0000644000000000000000000000152607346545000016740 0ustar0000000000000000MOw$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~"w)So%cܵw @p m63"ّ 9f32o;e`S(wˢnù(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-3.0.2.1/tests/data/6F87040E-cr.pubkey0000644000000000000000000000161507346545000016350 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~o0OwITesting revsig ^#A2biBV#WY#-B>,[> $x yfu 38#o0OwIDtesting revsig ^#A2b>+ #1ѽ^Qmz6!$W+6+TQeL[3Gl/(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnOwHw >hm´#pBjH t_%*Y/V;k.Yy7%;z(Pvn*_7JD+&*,il)c Y3n]U}aD|"[N#a^OwI5 ^#A2bQ>&P{k-aعl nqaѡ0!Y꾹gkv0HjhOpenPGP-3.0.2.1/tests/data/6F87040E.pubkey0000644000000000000000000000125307346545000015744 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnOwHw >hm´#pBjH t_%*Y/V;k.Yy7%;z(Pvn*_7JD+&*,il)c Y3n]U}aD|"[N#a^OwI5 ^#A2bQ>&P{k-aعl nqaѡ0!Y꾹gkv0HjhOpenPGP-3.0.2.1/tests/data/aes256-sha512.seckey0000644000000000000000000000156007346545000016754 0ustar0000000000000000gOw$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~;ʹ jaVGvKޤa4CL0TyʝeL Tv1ꨃ`lumQo6ĈI~$iPsαAtz$1k:OQ-b  *YJ М1]fMȻ`r~ ڜd68џղKc77 gGݬ(s,Y YrO-FQ cE)RYgAڌhy8ܞ4Q!,t؝6(de(A=z(M\ tKjTtS i;h FSeZT5 . o6j(JpЍ }Z8])zyGsc8b'}Lc jq_X gW>(ڃ$Test Key (RSA) (Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-3.0.2.1/tests/data/anibal-ed25519.gpg0000644000000000000000000000060507346545000016461 0ustar00000000000000003Uſ +G@ޒnT0_ Yx́h7`+Anibal Monsalve Salazar y !Uſ    )@s^ =?fNK"q "!؆Mt0kA!&I-9lDx#sfc{+Anibal Monsalve Salazar y !Uſ    )@s^ Ny/}j/_lOiJ?(EE"V-;:qcbUhOpenPGP-3.0.2.1/tests/data/compressedsig-bzip2.gpg0000644000000000000000000000067207346545000020136 0ustar0000000000000000BZh61AY&SYVmns{E"ZPf(1ŷKU0LTѴFL4`Li 1CL H`ISzHt20M0`G00TD= dFFOHd4i4 cD$HAP%~":(X;.;)6Lތ̖jH0D>ḽO&BD`;M*E8 nfoeuueFdYz Y#K,H.B4hNf'0 Jg~PIr#{,RHUG#/G:[~WkUY, #JٷDp"#e'"(H+67hOpenPGP-3.0.2.1/tests/data/compressedsig-zlib.gpg0000644000000000000000000000050207346545000020040 0ustar0000000000000000xxv>5IU9Iz%%dd+Qz~f^BIBRBqfz^jBb^Bnr~nAQjq1P,3$1O!?'E7-(7D 19;D<$$SW\ T^ձ d%=1,/D]=ûu!n;,TlﯞC+Z4]кX]y/52zbQC^/XAmS$cj}ȏ%=ل)Բ(~`Rͧ~@NTnN5IE%9z%%! @PPPZ_[PKSI&($&g(gddJ R32sRK2:v00212e,\?oMbbJ?+&=K査ŭw=ySOUj9gCVb뷭Z2)vnH ޥ8M 3Ϛ՞J?:Z8]"#ӧ>]H1uMWo wQ?uug~CeJnbhOpenPGP-3.0.2.1/tests/data/ecdsa-key-without-ecdh.pubkey0000644000000000000000000000040207346545000021223 0ustar0000000000000000ROwM<*H=m-a&"4PkW Uvp;P!E쇷`RKO2dwpD)s+Test Key (NIST P-256) 'OwM< f   p2$6t1;$,ߴ k<~nr~¢MҶ>Z %edghOpenPGP-3.0.2.1/tests/data/ed25519-without-curve25519.pubkey0000644000000000000000000000034307346545000021207 0ustar00000000000000003OwMg +G@TȄ|QGh<},oF0S=E+Test Key (Curve25519) 'OwMg f   _`YnÔU4PQ&|& Wi̱UF{H/tЄz[hM hOpenPGP-3.0.2.1/tests/data/ed25519.pubkey0000644000000000000000000000060607346545000015760 0ustar00000000000000003OwMg +G@TȄ|QGh<},oF0S=E+Test Key (Curve25519) 'OwMg f   _`YnÔU4PQ&|& Wi̱UF{H/tЄz[hM 8OwMg +U@i Uyus*9% o<=w-gOwMg  f _`Y"vPU2?zA{P='$?OJavA90s۠/@hOpenPGP-3.0.2.1/tests/data/ed25519.secretkey0000644000000000000000000000105407346545000016455 0ustar0000000000000000OwMg +G@TȄ|QGh<},oF0S=ECֱT\<~W6*YK\ %M8a\'OwMg f   _`YnÔU4PQ&|& Wi̱UF{H/tЄz[hM OwMg +U@i Uyus*9% o<=w-Z"Kl$')>_J!~)yVi^@YG0F$DžG7m]8הs3YuɈgOwMg  f _`Y"vPU2?zA{P='$?OJavA90s۠/@hOpenPGP-3.0.2.1/tests/data/encryption-sym-3des-mdc-s2k0.gpg0000644000000000000000000000010307346545000021402 0ustar0000000000000000;zc^ȳEƌE%A^/JS EG~٬yn>ۼv;hOpenPGP-3.0.2.1/tests/data/encryption-sym-3des-mdc.gpg0000644000000000000000000000011407346545000020627 0ustar0000000000000000 R_(`; =]o7FJ2-O">_1"Lg <ݸ )"e0 _!ݻ CNx)hOpenPGP-3.0.2.1/tests/data/encryption-sym-3des-s2k0.gpg0000644000000000000000000000005407346545000020646 0ustar0000000000000000$3˕,A^a[#cGI\hOpenPGP-3.0.2.1/tests/data/encryption-sym-3des.gpg0000644000000000000000000000006507346545000020073 0ustar0000000000000000 H-Z%`$ל{; }:rvf2oLx coJrulh{3lhOpenPGP-3.0.2.1/tests/data/encryption-sym-aes256-s2k0.gpg0000644000000000000000000000010207346545000021007 0ustar0000000000000000 :'.-D2tl"kVBdty(f}E;| hOpenPGP-3.0.2.1/tests/data/encryption-sym-aes256-sha256.pgp0000644000000000000000000000015007346545000021254 0ustar0000000000000000.  j,KWfb4qtugs}{{%Ūt$WxM);68:}$|{"NW@rJKDM7V] hOpenPGP-3.0.2.1/tests/data/encryption-sym-aes256.gpg0000644000000000000000000000011307346545000020234 0ustar0000000000000000  ZC(`:pdT3 Ll6~d5-}Sp~=/Nt+FOh8֢hOpenPGP-3.0.2.1/tests/data/encryption-sym-blowfish-mdc-s2k0.gpg0000644000000000000000000000010307346545000022361 0ustar0000000000000000;99ayO%d.E M˳D='D!3hOpenPGP-3.0.2.1/tests/data/encryption-sym-blowfish-mdc.gpg0000644000000000000000000000011407346545000021606 0ustar0000000000000000 K`;PRtW,!mp ɄX_TsdzH8*Z^Xccݟd17Gqr hOpenPGP-3.0.2.1/tests/data/encryption-sym-blowfish-s2k0.gpg0000644000000000000000000000005407346545000021625 0ustar0000000000000000$ćEe(U@3jl0mUp phOpenPGP-3.0.2.1/tests/data/encryption-sym-blowfish.gpg0000644000000000000000000000006507346545000021052 0ustar0000000000000000 3wR+`$.X(ē"+}Q跗mק:Mw_hOpenPGP-3.0.2.1/tests/data/encryption-sym-camellia128-s2k0.gpg0000644000000000000000000000010607346545000022010 0ustar0000000000000000 >E)%NSRA9%pʤ%J_bB\z3߃'ͧ-`Dzp|,ҳ%؂hOpenPGP-3.0.2.1/tests/data/encryption-sym-camellia128.gpg0000644000000000000000000000011707346545000021235 0ustar0000000000000000   e°*`>z6ŭ0_C$:8RA58TMGN9hOpenPGP-3.0.2.1/tests/data/encryption-sym-camellia192.gpg0000644000000000000000000000011707346545000021236 0ustar0000000000000000   fS `>j1ZHW{1ҾĽFA$r2q l1+GSCY0t 3Fwi:hOpenPGP-3.0.2.1/tests/data/encryption-sym-camellia256.gpg0000644000000000000000000000011707346545000021237 0ustar0000000000000000   ek?`>_uO:I5HTor%Dy9K\ao)v%Gv{ ahOpenPGP-3.0.2.1/tests/data/encryption-sym-cast5-mdc-s2k0.gpg0000644000000000000000000000010307346545000021563 0ustar0000000000000000;7DmsΈɘXHAF O2O*QBtrᄠxF:`]hOpenPGP-3.0.2.1/tests/data/encryption-sym-cast5-mdc.gpg0000644000000000000000000000011407346545000021010 0ustar0000000000000000 HwԒX`;enu-7P :dDYoB%L!MX5!J_{LȷhOpenPGP-3.0.2.1/tests/data/encryption-sym-cast5-s2k0.gpg0000644000000000000000000000004307346545000021025 0ustar0000000000000000䞴;K<֭E'hOpenPGP-3.0.2.1/tests/data/encryption-sym-cast5.gpg0000644000000000000000000000005407346545000020252 0ustar0000000000000000 m]`ڗy2@nf<;ʪF`ODhOpenPGP-3.0.2.1/tests/data/encryption-sym-pgcrypto.pgp0000644000000000000000000000011607346545000021112 0ustar0000000000000000  ZvWi=CҲ|l+(TƉ+U.M%E4Y7nSrGpZ hOpenPGP-3.0.2.1/tests/data/encryption-sym-twofish-s2k0.gpg0000644000000000000000000000011307346545000021467 0ustar0000000000000000 Cė"D%: ]@7 E72&9v41;] ِtXIjqdɘEkUfshOpenPGP-3.0.2.1/tests/data/encryption-sym-twofish.gpg0000644000000000000000000000012407346545000020714 0ustar0000000000000000  ӻ"`C_–'3:=8HlY*-I4y%ss]!̾+q?3hOpenPGP-3.0.2.1/tests/data/encryption.gpg0000644000000000000000000000153407346545000016433 0ustar0000000000000000^.$92 ="TRxB`]3gܽ:QGHh9y#o +qWG\{Pj17ƃ@m. ˎrC~9fq8BpC5vV*݌B? ts~FE wέ\Y<:ʙ=X1\Z[7BBb\ W+x bNy<oO=rɐE) îWw;gSo'   J ^eGPG ~*]*6- F;+rYlQpC{腵en!Micah Anderson o'   J ^eGPG ~*]*|J0~Ȏ.t9-Ngl8U2$Micah Anderson l$   J ^eGPG ~*]*8?#î~vg @zZҡp~w.(p'Micah Johan Anderson d$   J ^ ~*]*Oy `o8VkK'(oM .ͺUO<3Æ1Micah Anderson (no comment) l$   J ^eGPG ~*]**mu{'%p{U=  H"౤M\GR |N;\oEΦa&ߋwb8?ŦcsYV-BЁrr~sJd) lc#u+~-X{LYL)"lKI G ~*]*;la!xQ/%@HtF1zwV!^D?X(Hƻsmartcard broke ~*]*{8>6Cmȅi؋?+8 WΉnhGR%Oio Zlne\ =Ii[BIaم4,ήX I ;(!O+HШ&-Ydӻ#>yFϏ'JmnI G ~*]*bRˎrKȚiڣ>[ HE!˜QY/X(Hƻwsmartcard broke ~*]* vFdY@@>T?L)~B+c'GIQ5> 6F3?mW/%"H<춰=(V )X vnA<{Y≔ffi{^=cT`S!,FкGhrm*X"|g's_xI GI ~*]*pT6QUu:mv +}q~%cZ(HAopenpgp key broke ~*]* .*KU53m.yӿykߩʉ\Da HP5 !t<xn Qj~3to #c7 2!_(?9  7+IP;tjsO+R(7jr:j\0`e6Dﶢh 䎛c]I HP5 ~*]*k8 zAA#!Gj7Pu:j-'X(Hksmartcard broke ~*]* c^s&1Gbk1e yöe UָGaC"ǩy\hӦXDk4XZR$Ol}&tܵHεž/HVpvܷquf do#J&%v OT7fv?HR_* }I G ~*]*a4l_QW(.CX5;1Z9umX(H&smartcard broke ~*]*FX4W^sY~ a.:% BOΛt| a=B%\ $7,,;?}BEUW-'ͥ+ O1w SOr(2H+Replaced subkey due to smartcard breakage ~*]*LX_rsI1?XGIyê/ M6zU/k[o2$Ů俐hW ܫ6cZˤ}b8vCyRRT7`zRFBzDW24*JDz+y@3Uke<8~ ![(HAyopenpgp card broke ~*]*PWVT7TJ-TpK6WJE0zvGX> GIz ~*]* GIz t\E_M5(2!sşN\=tƢ:ܕ >Lkge<ʤ4]7A=?GFXf5`$Sk71~Ĺ,pW꒖ 3`IFC`jENA"s޸T*SWj=V3< >HP5`P%**o)/Gp~CEervPyw/evq!Y͏vܸR 0cO-~T"fz/_ui>#&<)R|:Ă꺙mp{ J_г 6qI HP5` ~*]*/UwX"تE/^JAy~*cgNX(Hsmartcard broke ~*]*ЯG|@q&.p=b3U2up۩f$ cHP5eGxy&ERČ{s[3eCw]q2!?*6vQ w8'qn-+WꨁK&9ptAw(oaę2sk<ċ۠Htb'UQqmAWDj9=u m@^WI(S /Cw0eza_%mӓ&3d@ugKvp=y5t 9]R#4jJ?v+,Rԍ; i: $!,;BevE̿-}Áx RJAtcmЋA:/rQF#$喙9ZKFPȆnT:mV<rFxP@B|B+a,**3ʡC`5R 3x%:;,seilm{U=rQ1N9] ~*]*eGPG H>ƌ2N< G8DsР>2S_8*{( ;J8$4Please see: http://micah.riseup.net/key_transition ~*]*vEqjE)r?c^OpKV r:XhOpenPGP-3.0.2.1/tests/data/gnu-dummy-s2k-101-secret-key.gpg0000644000000000000000000000043007346545000021222 0ustar0000000000000000T6@^'Wd(\!M:W HE|P8h+؈m]OchLcͻ)~{B"Ы*,eY2R U9\2H}b$:WFZeA[ h6-x*;k Au.޼ІUyyGCx@IsmᗙܢQ1>=Ȳ}`!~[Q@B4Ȏ-`)0rVbUfѨeGNUhOpenPGP-3.0.2.1/tests/data/minimized.gpg0000644000000000000000000000065507346545000016231 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-3.0.2.1/tests/data/msg1.asc0000644000000000000000000000025107346545000015074 0ustar0000000000000000-----BEGIN PGP MESSAGE----- Version: OpenPrivacy 0.99 yDgBO22WxBHv7O8X7O/jygAEzol56iUKiXmV+XmpCtmpqQUKiQrFqclFqUDBovzS vBSFjNSiVHsuAA== =njUN -----END PGP MESSAGE----- hOpenPGP-3.0.2.1/tests/data/nist_p-256_key.gpg0000644000000000000000000000070307346545000016714 0ustar0000000000000000ROwM<*H=m-a&"4PkW Uvp;P!E쇷`RKO2dwpD)s+Test Key (NIST P-256) 'OwM< f   p2$6t1;$,ߴ k<~nr~¢MҶ>Z %edgVOwM<*H=U7Q>o(}/%|[RТ=\9"-"r%nC_=]+5gOwM<  f p2$RZ;eT .7W; ԒcD_{`ɪ]DJmWXDb&J ԼhOpenPGP-3.0.2.1/tests/data/nist_p-256_secretkey.gpg0000644000000000000000000000115107346545000020120 0ustar0000000000000000OwM<*H=m-a&"4PkW Uvp;P!E쇷`RKO2dwpD)s(RaIg(nZֳxorEP `q1E),HiYp/+Test Key (NIST P-256) 'OwM< f   p2$6t1;$,ߴ k<~nr~¢MҶ>Z %edgOwM<*H=U7Q>o(}/%|[RТ=\9"-"r%nC_=]+5([օ -?hNODߦ66tnӘ#3S=HWQt'+Qt?gOwM<  f p2$RZ;eT .7W; ԒcD_{`ɪ]DJmWXDb&J ԼhOpenPGP-3.0.2.1/tests/data/onepass_sig0000644000000000000000000000001707346545000015772 0ustar0000000000000000 NohOpenPGP-3.0.2.1/tests/data/pgcrypto-passphrase.txt0000644000000000000000000000000607346545000020312 0ustar0000000000000000blockshOpenPGP-3.0.2.1/tests/data/pki-password.txt0000644000000000000000000000000407346545000016715 0ustar0000000000000000testhOpenPGP-3.0.2.1/tests/data/prikey-rev.gpg0000644000000000000000000000057007346545000016335 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~EXVE+m*8QSCp x]P 0ăcas:f&`\R!tϪ3οxa_|Xq?gщʋS<꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~o0OwITesting revsig ^#A2biBV#WY#-B>,[> $x yfu 38#o0OwIDtesting revsig ^#A2b>+ #1ѽ^Qmz6!$W+6+TQeL[3Gl/(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnOwHw >hm´#pBjH t_%*Y/V;k.Yy7%;z(Pvn*_7JD+&*,il)c Y3n]U}aD|"[N#a^OwI5 ^#A2bQ>&P{k-aعl nqaѡ0!Y꾹gkv0HjOw$ພo# \X" l9Nv`x]pBA hzSX[s'S4~#{T V`;~ 'o]3U.-Psڮ>S}%Nbx%9mˣ^l":C*=Ow$  π No9R \R^mNʖlysQ%x=ӿbG"lf!%F*w͎gL#!^_ql5qWe/< 0k)sL34ʺmEy$éH#TP.f\w=j4akOw m] yayT*p}GLE!SH)䃉4ŷQ,lŖF!b 4ދj;R  4<ްoz})Q6\R2y俓ܣ%}U|n;[ m @t9N\ߊW 4d*\ #KP E6)R߶l#0ӚBD`^.{{m#}gGV+ 6!b7Fa'Y J-`L4cWM9[E}U+0'3/HKfxpΞ{E*DQ:j oB&mK&_ S2B_"#0NEuFrV5m`sm렖}X4/H R-;548[,_zk\6"WLR ׁ*PieK6d*e5ͰF2HƩm&ވ0MO3e*5<*hp;gv-SIJZ8xRaZܗQDY,css9AO5 `]BQayl9J r t7sKamK . eDH Dqœ;B=zDky[dwz-ůnga5uTjgat̑LL]y!OwJ  /Z\þw2Ϙc ^#A2b& bta=0)Ҷ?9pɼRORͤ[L]ڳ,}pcï-`+LѰ$Test Key (DSA) (Ow    ^#A2bܯgi\Q$`;! 873?wNj*rK%% Aý~uOwH4 NowMy/]GYjZU8{Sc!Q'VJ""[zT|ĽX]`qdD+Ւ !BwR'+iDm@ (ǘQصf.^3mw8P*}(Qwrdx')mqVP2g wa mG >\$B6C;i^4RgOw   ^#A2b)$[OX`J`6\I[o?u<wGkt˨\A]gM^"߶/HOw3!$}9 W̳us<,?#/ `N["cgU[In?60tw&U8j,K|7[Cb|p6.oaV1aS"oՍ)6W.=='%WgDڤDAmiԚr8h>$B/'tMZ ַk(Txg^;?Q#׻HD?HgQW-i|rKHA B,GO>G9ٓfp',6n?טYT/ ?XvT:`p/y){0ϜFw7νyV_3v }yNi[͙\zC?9A$Ya!OwJ y3EY >hm w2ϘcnA_-]joyp&e2r ؠXŰ+Test Key (DSA sign-only) B   OwItesting@notation w2Ϙcꆸ-&iDš$)`Sg<°^OwHT ^#A2b0$LM ɑ(;濂X/t+2f]9"W=O!}co*(:UOw!ž%Jo_-0=!t֤70#M\d&KnHyI Qm PG;RLjF!"N$9t98wvW"I%/̈LNСz Ny .Test Key (RSA sign-only) (Ow! hmAD&5Ԝjmg^y]bnKA;x˲BT[DwQ%2rwEB b;ʴY;n@%̓fZ~qᏦ8ۋjxUB*__N~v׏qk#ĸ*:` `†?'FJt)n:StƢ5Nllj::^61 6NB |]\Idg=TD@VTDŽ?S֤~O?Z{tf¢uU9uRąCH 9A̭ă_]N)0Tuڞ\_Z|Q_O>t|Tp7 ۏq@ L_mMQCQb_$$((`_Up Taohqe3d"kH& LVO"=7*R(q7JJ!q{yE+"1Rf#ĥK JE@Mԑs:\>;QZېs 6= 28`zޭXRxY;w$$-Lş6KITAQFʧ5=4 (6{ e]`"YmXqu4rj2\YFJB tB6ꞡjrTit0BUtsȹ~;v;^qRQ5->o!IH! M4vn f"d\\SfJB/S/$=RA~ܲfiuErYtw!@ ˂>NU{pVQUee R%7Zl1㟞*liuovo|c{["*QrߓC@1'ZA~mf˶<'pL؋p$Hh* %@$ň#j۲UD6ֶ$$n4hګ VTs@39yF5YN!Ч\[FuqtVorF~Q1LhS.ڊMqt ?sFoUS$3tupѧSȆE- 6ZĤ8LzjQ,_B]BIQDs4hMLOs3>d3kpS(?71<\S~8ԾNKTw@āv-NcP'S ̑][`T \ƦKOҢTT\((*$H!FXm'2` G)&cW4aKMqlE3ٲ( uАQL\Jo_~ +­Dx:sTj_و(OwL hmdi!Սyǜ+d1A(}=M4 BvSu [TXq, %f8o; m *At'|Fg0]%]%yޡ UVC~d:+5 u OwJGgC!_ZGk렂=KsxH-!*nLvXFw|#W,l;qfO^>3(@ 8hm߰yb)Qx0+G7ld:`c/ ~ڶTG̔Cr=0n~83aQ_zIN\|Sa8e`dqr#dW>}P끩hOpenPGP-3.0.2.1/tests/data/revoked.pubkey0000644000000000000000000000631607346545000016425 0ustar00000000000000008oM!v7w~!~$?p(QH(P5i-9όM|rhٮ @#!slm8  on5<`E2ŏxjd\ޜ'уگ\1$:dQgg!9_H>V nw`7>w C-?$Joڅ ܏ua1*SW/p$Sߥ`d91z4IC GubEּWw}RZWl ƥ|_xN"E,2G?iຆ\aeu\iekyLCVԼf~+IK&iZկ W͇hޢtK J#Jh3+ʼn-tpɁڈ MRQFsuperseded by key 4900 707D DC5C 07F2 DECB 0283 9C31 503C 6D86 6396 ʛ#PqFW `}/f64  y gʹ$Stefano Zacchiroli 0UIWN I don't use the @bononia.it address anymore, and it will bounce anytime soon ʛ#bZ+.c^Ђ(#-Y]_Ϳ1"IYk0$Stefano Zacchiroli _:@   ʛ#eGPG[> S>sUn9o*=$Stefano Zacchiroli c# Gwa/ ʛ#NӝHU![SMNB*3_aO9%Stefano Zacchiroli ` H۾  ʛ#5|,wG^of+ y]Xulv 0+.O(Stefano Zacchiroli ` H  ʛ#} ]1Æ^>jwYSfH%ǭr;7_+蜴,Stefano Zacchiroli (Zack) r02If2+getting rid of the bogus "(Zack)" comment ʛ#l'h C&:3.ԠXD-0Stefano Zacchiroli (Zack) r02If2+getting rid of the bogus "(Zack)" comment ʛ#." &h@S~i@m*+ 8Eg%tI8Pq,\хj7֪; `6zxRHN1$)O7֬pŀE |E,nitLSkJ[|szn(]0-쀖(NރgsOKu8s$=Pi멙E%KMpWϼ.{ꡙdNi;_mik CLrH΄R)qPA6,%x7bf_ i N8 ʛ#eGPG2(>KXy&0p@X[BK0?jJP*LA 7q(qH^jI've switched to a longer subkey for encryption; the ID of the new key is E5B57D13, it is 4096 bit long. ʛ#92 Bs׫8 @~;#_l8||7Om#ݜ H GT鴙Jtf`^7}se"X E RYʨJ3mgW8uOg['mbNbn&ϷN&6ʊs17/eHQqd sz*Tԉ =%Uy@q2ĥz!OI <~]Y vs tҽGK A(zK)4ǖ_\+yPgu(FɊ#HN8 {L& ٥OĤӓ!W6) +-gkD3V~I0&*DX' /ϥecE,F]އJl|F8e{OU\V@OmHb [W9"B#?I!#' u22jh?cWahWd6s <mND 7yS$82]oa$_JsI6ZkrA=͵k8שe#yֆ @nZ)RVy}Wm b;D Ot#͌(m?&2@e1B#~`I4;SCPȚ.=C< {PԷƂ(ڠ2w=nCK&7%F}d"2Hcn%"ӌ30`Shu}?Bc`h*=J]VI H ʛ#Bіl{ר\5ˏ5KNlb 6ųv2ۏIhOpenPGP-3.0.2.1/tests/data/sample-eddsa.pubkey0000644000000000000000000000006507346545000017320 0ustar00000000000000003S_  +G@? @Sy4|s:/.C;$hOpenPGP-3.0.2.1/tests/data/secring.gpg0000644000000000000000000002070407346545000015673 0ustar0000000000000000_Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~mW3W%O:`X~8%d\ٺ§'$Test Key (RSA) (Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1Υn`Ow$ພo# \X" l9Nv`x]pBA hzSX[s'S4~#{T V`;~ 'o]3U.-Psڮ>S}%Nbx%9mˣ^l":C*=emGM`A]Q$VamQX&nySRw!+ˑk^IW!4HX`5yKh4nQ?ՙthSM]$f/\Ts,FJwJ^Il2k0!xU;/̶̪a}>F7AL}ΚtP6n|iqq«VWzjkv-iV $=d/B9KʋTp%a *' : r$4* @OM2Whu}Va v< YG="ӱRf Q/swn 7 ưUl4ߕ,jLv)DÎyhl4YOw$  π No9R \R^mNʖlysQ%x=ӿbG"lf!%F*w͎gL#!^_ql5qWe/< 0k)sL34ʺmEy$éH#TP.f\w=j4akOw m] yayT*p}GLE!SH)䃉4ŷQ,lŖF!b 4ދj;R  4<ްoz})Q6\R2y俓ܣ%}U|n;[ m @t9N\ߊW 4d*\ #KP E6)R߶l#0ӚBD`^.{{m#}gGV+ 6!b7Fa'Y J-`L4cWM9[E}U+0'3/HKfxpΞ{E*DQ:j oB&mK&_ S2B_"#0NEuFrV5m`sm렖}X4/H R-;548[,_zk\6"WLR ׁ*PieK6d*e5ͰF2HƩm&ވ0MO3e*5<*hp;gv-SIJZ8xRaZܗQDY,css9AO5 `]BQayl9J r t7sKamK . eDH Dqœ;B=zDky[dwz-ůnga5uTjgat̑LL]gׁ`vE%nOqaWqrn!`i}lw!B&{b]+GQ y!OwJ  /Z\þw2Ϙc ^#A2b& bta=0)Ҷ?9pɼRORͤ[L]ڳ,}pcï-`+LѰ$Test Key (DSA) (Ow    ^#A2bܯgi\Q$`;! 873?wNj*rK%% Aý~uOw @7la Ua?a`K䠳q{Ü@H2{'2i0  D+=6h8k]NmY\}]X+%T|T̠ =%VubD;^`钘/hĢfFj㬒vA$_,G]aNz5ͽ w?

(ǘQصf.^3mw8P*}(Qwrdx')mqVP2g wa mG >\$B6C;i^4Rgׁ`A0ʭerT$fJ{y!TM{2XIסtWaʞ+fOw   ^#A2b)$ ::y!cƋI3b;@{S?bSZV9ިPMOw3!$}9 W̳us<,?#/ `N["cgU[In?60tw&U8j,K|7[Cb|p6.oaV1aS"oՍ)6W.=='%WgDڤDAmiԚr8h>$B/'tMZ ַk(Txg^;?Q#׻HD?HgQW-i|rKHA B,GO>G9ٓfp',6n?טYT/ ?XvT:`p/y){0ϜFw7νyV_3v }yNi[͙\zC?9A$YZ".ܵh``(S -lNwF5B`l m)a!OwJ y3EY >hm w2ϘcnA_-]joyp&e2r ؠXŰ+Test Key (DSA sign-only) h(Ow    w2ϘczHm5YDBT!.ADs48$Q9H>jOw!ž%Jo_-0=!t֤70#M\d&KnHyI Qm PG;RLjF!"N$9t98wvW"I%/̈LNСz Ny  WA/`++oXbN,9KpPwR,l&p<ǻ\n>+;I Sl Xr Ju#ʶK&Λ_o7HBߙAzHkWp`4dl LJ"`H.lۏ'O4]4,X3܉O'q)u]hhHi'KI>1/L,ڀT R6Z7VA,,&|yrXh,@@D:7k=0sD2އFcOq~8gU;[U 4AT}G J6>?9by$(A\vծ:Qe`0*(ƴ.Test Key (RSA sign-only) (Ow! hmAD&5Ԝjmg^y]bnKA;x˲BT[DwQ%2rwEB b;ʴY;n@%̓fZ~qᏦ8ۋjxUB*__N~v׏qk#ĸ*:` `†?'FJt)n:StƢ5Nllj::^61 6NB |]\Idg=TD@VTDŽ?S֤~O?Z{tf¢uU9uRąCH 9A̭ă_]N)0Tuڞ\_Z|Q_O>t|Tp7 ۏq@ L_mMQCQb_$$((`_Up Taohqe3d"kH& LVO"=7*R(q7JJ!q{yE+"1Rf#ĥK JE@Mԑs:\>;QZېs 6= 28`zޭXRxY;w$$-Lş6KITAQFʧ5=4 (6{ e]`"YmXqu4rj2\YFJB tB6ꞡjrTit0BUtsȹ~;v;^qRQ5->o!IH! M4vn f"d\\SfJB/S/$=RA~ܲfiuErYtw!@ ˂>NU{pVQUee R%7Zl1㟞*liuovo|c{["*QrߓC@1'ZA~mf˶<'pL؋p$Hh* %@$ň#j۲UD6ֶ$$n4hګ VTs@39yF5YN!Ч\[FuqtVorF~Q1LhS.ڊMqt ?sFoUS$3tupѧSȆE- 6ZĤ8LzjQ,_B]BIQDs4hMLOs3>d3kpS(?71<\S~8ԾNKTw@āv-NcP'S ̑][`T \ƦKOҢTT\((*$H!FXm'2` G)&cW4aKMqlE3ٲ( uАQL\Jo_~ +­Dx:sTj_و(OwL hmdi!Սyǜ+d1A(}=M4 BvSu [TXq, %f8o; m *At'|Fg0]%]%yޡ UVC~d:+5 uOwJGgC!_ZGk렂=KsxH-!*nLvXFw|#W,l;qfO^>3(@ 8A ̇کv4'gb2R!e.}񀙱ltM?E-]5ds1\Z7_MեZC)'MB4gȇIİLJ3JX< |4NW~AG}5[BaCrj/"͒u6 t=pjZ}Eh2:ZN<NcIVPDaP6Sd ׶P(sQ+'Jy!ڿ`{? bh5׽ OaD\2Vޖtr#'dWB_'<{ O,L , hd(&%/{3F){٬m5_YStuCCb̐ OwJ >hm߰yb)Qx0+G7ld:`c/ ~ڶTG̔Cr=0n~83aQ_zIN\|Sa8e`dqr#dW>}P끩hOpenPGP-3.0.2.1/tests/data/seipdv2-for-v4-key.pgp.aa0000644000000000000000000000054007346545000020103 0ustar0000000000000000-----BEGIN PGP MESSAGE----- wWwGFQTIJj/G1nYES26XOVnC8sLK4w3pCBIBB0BwOFvfLenhFHR1kdTjP/Wp+Ghn LO5VTiE7bl1W7V/wAzAlO0jypAZyu5jCTeqGKqjipkMDEbou8BKoRPUInw6jn04s P7QkQ+ZGFFlsY2frya3SagIJAgbmRJucr1ylMximFV/OaApO0g+y/AU6lJ74s6rU 5mK8o91lNZt976H0vAiqIhRNWLT18MUqd4/mPA75DVKBrkFzxoiMf+CpT6vJmHH/ K008SSmmSROTVY1XOiNxfW/Ohzj3ExR2h1k= -----END PGP MESSAGE----- hOpenPGP-3.0.2.1/tests/data/seipdv2-three-recipients.pgp.aa0000644000000000000000000000123507346545000021454 0ustar0000000000000000-----BEGIN PGP MESSAGE----- wW0GIQZPa+Qzhph44YDttKf207N15ZZ3CS8z5eTPx5Qg0amc4xl6s9436hXVOf9U lbOM7X9pn7y8WPNI0YkebVA1QApUTih6jitnR1Wpyt4/A0Vj6RErk+SdC3WiKHWI OuRShYlvNiK+CEvQD/4FwW0GIQav44SnLNNBPMT5pEw1RZY8zjlKostWz+pDmoUF +5URxRn+KP0OCEXprvbaDAmzJqDbXuVx5FW7uAGB5GVeEPt1XSjyfokGV/L4YRPU TbC2y2O6v2E/9wjR1C/7zxe6KlpDwbcJQqbFzIZzwWwGFQTIJj/G1nYES26XOVnC 8sLK4w3pCBIBB0Cq0yu1vFmBEh/u4ja1vGjGaed0nZln10mE0rxvF4kISTDRXXAE iii1x557ssJf3VW4ziIVSHPy+nOE8mAYbmfO11AtzapS5d5mZh7PfjFGt5LSdgIJ Agad51+IWqNRs2YEAz6TKjTSuLOpQDyDRmod6XKIeP7F0dX0jp1FSy0C15pu9lxS KZE4h9DRZjelsbi3MxP15uHRQkUs/JtxWVvz577/wkbHkZDg1JFD0e19k009EN5/ 7vN3KaeRKAJeOSNQnmjCqJTemkk= -----END PGP MESSAGE----- hOpenPGP-3.0.2.1/tests/data/seipdv2-two-recipients.pgp.aa0000644000000000000000000000100707346545000021153 0ustar0000000000000000-----BEGIN PGP MESSAGE----- wW0GIQav44SnLNNBPMT5pEw1RZY8zjlKostWz+pDmoUF+5URxRmPwQGf5CbZQKLE VnWosSwUCTzfssCThJ8F3ipLqGWyJyjPK9ORkR2F2mJcFaGN37sgh6YS3YDCy7M8 KtEW4sCKbPPaCi8AHyWTwWwGFQTIJj/G1nYES26XOVnC8sLK4w3pCBIBB0Cc/SaD cEivp/+lPv11uVOacGCxzAUmg3j0N7QfvpCOYDAPTgXG+2wHd4o1GCW3t/vCTnHU BsC9fym6071xys8em8YXQAMwYaxNFd1tQd9GL5zSdgIJAgbnRfhxbeKxWPQjGsCo 11qRYfinBxjBQUwI8NpwPrGstym4RvVuxDSBGMrga6FRIjAn9VD9cwDZsJ5mxWhO bsV0rVwQr/Nn2ibpJpOzVHty/6hkyf3dRDSPiaZdRQmvuWCTtyWd/ptLBX6oK0c6 JidNvfI= -----END PGP MESSAGE----- hOpenPGP-3.0.2.1/tests/data/seipdv2.pgp.aa0000644000000000000000000000054007346545000016202 0ustar0000000000000000-----BEGIN PGP MESSAGE----- wW0GIQav44SnLNNBPMT5pEw1RZY8zjlKostWz+pDmoUF+5URxRkwyaitZyn0JaLC SYnwTOoiZgF9sz6WtxJJJrT8fRJbWyiTIxpSVr0gf/BBsHqDWDma0wfYo7QI+YIC 0i291xBNy1zBewWq0U6o0moCCQIG0KgYQaeiO2e9CrpgecrqyVQdPZv2H6UMMWws DM6crtsjhM572grlZ5Kzf55ybvQh0IOS9nQGi0naPQAI7VOrBENunE79qeW3z29r vZMR+ZZL3TRbqFaBZJy8tORC8NVaA6sLnZ4I -----END PGP MESSAGE----- hOpenPGP-3.0.2.1/tests/data/signing-subkey.gpg0000644000000000000000000000172007346545000017174 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~(Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnPZl;yh}6DDdBn RVNv$.o/YP-ȑsB/blͅ &l)Fmm.z\ąU;?,<6銁>EXVE+m*8QSCp x]u P No P 0ăcas:f&`\R!tϪ3οxa_|Xq?gщʋS<9S.upr{>mBy"5n}6`}Ҍ/|,lcIyդ8iI4_l e3t%1~hOpenPGP-3.0.2.1/tests/data/sigs-with-regexes0000644000000000000000000000040007346545000017032 0ustar0000000000000000L 9 all 5zN][x(ZyqbR3|s?O{QHZc#8+The cat sat on the big mat c;(Qx0EhgqW] +7e}S%"LK >yf.* g\/[L|[hrfKiA&p` ^G+hOpenPGP-3.0.2.1/tests/data/simple.seckey0000644000000000000000000000154407346545000016241 0ustar0000000000000000_Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~mW3W%O:`X~8%d\ٺ§'$Test Key (RSA) (Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-3.0.2.1/tests/data/subkey-rev.gpg0000644000000000000000000000104307346545000016330 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~S}%Nbx%9mˣ^l":C*=(PhOpenPGP testing NoKT‚͘^Xw+Zoݙ6ݕO%^m(9)7`Wzh2꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~Ow$ພo# \X" l9Nv`x]pBA hzSX[s'S4~#{T V`;~ 'o]3U.-Psڮ>S}%Nbx%9mˣ^l":C*=Ow$  π No9R \R^mNʖlysQ%x=ӿbG"lf!%F*w͎gL#!^_ql5qWe/< 0k)sL34ʺmEy$éH#TP.f\w=j4akhOpenPGP-3.0.2.1/tests/data/symmetric-password.txt0000644000000000000000000000000607346545000020150 0ustar0000000000000000abc123hOpenPGP-3.0.2.1/tests/data/uat.gpg0000644000000000000000000000130707346545000015030 0ustar0000000000000000Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK  ?و(Py π   No~v?l̨\&]^hts|pkE)ENR&ie [ƑP<&|(PѡGZYe@L'U:-cPHį뺑0eU2G_%--by9;s-zlhOpenPGP-3.0.2.1/tests/data/uat.jpg0000644000000000000000000000045207346545000015033 0ustar0000000000000000JFIFHH hOpenPGPC    %,'..+'+*17F;14B4*+=S>BHJNON/;V\UL[FMNKC $$K2+2KKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKKK  ?hOpenPGP-3.0.2.1/tests/data/uncompressed-ops-dsa-sha384.txt.gpg0000644000000000000000000000022607346545000022137 0ustar0000000000000000  w2Ϙc=buncompressed-ops.txtO Uncompressed one-pass sig message. F O w2Ϙc*'iOYY' Kf/oXmhOpenPGP-3.0.2.1/tests/data/uncompressed-ops-dsa.gpg0000644000000000000000000000022607346545000020311 0ustar0000000000000000 w2Ϙc=buncompressed-ops.txtOz4}Uncompressed one-pass sig message. FOz4} w2Ϙc$hk-A^jYΔ0hm=buncompressed-ops.txtOz4Uncompressed one-pass sig message. Oz4 >hmu2X;DwHsP|(E\D\h]AIK FSxl o[(,s+g&T KX~.EbQ;Y"8E9Z!`_x?MMhOpenPGP-3.0.2.1/tests/data/unencrypted.seckey0000644000000000000000000000150207346545000017302 0ustar00000000000000009Ow$G4r㪼v#X5[r 6TlS) >꬙ߗGK )ϒYJJa"tuw?#4`h)PVs5U\v!J&lmI  VC4󠮀kcnT~%U k"_ٸuȲ}\``ukAIh G@5$Nn8:7qtbBwD}q͏AĤ ppb )_[ pXw yů,7ȅN`Lu$k뺻n_"ύs_h^"|ߴ2R3{ kp$-r@0Z>c$2]s g? _F0{jgD=:N(z^ }'LU. `Ju+gn$*i%9  -ppWL$Ce9PY:өw}pÁ$Test Key (RSA) (Ow$ π   No=8 \-97Ed;|̙j%`9^a M~U3pѰuhxᶱ[WkSfB)C3 %C ]h,x-fɗI Q]-liuCa$`ml5e1ΥnhOpenPGP-3.0.2.1/tests/data/v3-genericcert.sig0000644000000000000000000000023007346545000017056 0ustar0000000000000000;ޢ !V=ItAy@9&$^8 ](-1fg. Xv:PǽHG|ގq mNPBjCDD)ۮ|[Ӏu #Qu*mŀ&hOpenPGP-3.0.2.1/tests/data/v4-encrypted-secret.pgp.aa0000644000000000000000000000615707346545000020447 0ustar0000000000000000-----BEGIN PGP PRIVATE KEY BLOCK----- Comment: D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1 Comment: Comment: v4 Test User xYYEakxBgBYJKwYBBAHaRw8BAQdAP6cjID4HFp73MwUjEA/nCYXMRSItPLypDLtZ jPULW1j+CQMIBVN3fzlNeWf/NUtTI5lsyaQwJ7txmqD2DJddv9MzNrfdevWxKi6/ qZi5Pj/B2fJtowuVKubAkW8NG1Jt9unEFzkRPjITiScX1kzBod6Pz8LAEQQfFgoA gwWCakxBgAWJBaSPvQMLCQcJEIEdkkM5S3nBRxQAAAAAAB4AIHNhbHRAbm90YXRp b25zLnNlcXVvaWEtcGdwLm9yZ7fr7BFc0dXw/uIYQrhm5mpoiJ4e0mp7WnbeXyx0 bx4DAxUKCAKbAQIeCRYhBNLggek/3KLni1/EM4EdkkM5S3nBAAAEkAD+JNB39+p4 4O+r5Cj5mvh9koCA9QnkY/lpToQvDSGsP4YBANT1ActXzuojvIiLDFGOrjrazt5P b0UTIX1xe4pYyhwJzRQ8djR0ZXN0QGV4YW1wbGUub3JnPsLAEQQTFgoAgwWCakxB gAWJBaSPvQMLCQcJEIEdkkM5S3nBRxQAAAAAAB4AIHNhbHRAbm90YXRpb25zLnNl cXVvaWEtcGdwLm9yZ6pEf7QImN4zmmOa2+CA5afhgwI6rRMVVxuVJo5W1JunAxUK CAKbAQIeCRYhBNLggek/3KLni1/EM4EdkkM5S3nBAAB42AEA8RDxMFea/zKix9NK bAaeBwqOJMcscgnuuCHtyTqEJYoBAJ0OFgd23E1F4Bk36WagxQaKEm8ydT2plOoy 8heMUBQGzQx2NCBUZXN0IFVzZXLCwBQEExYKAIYFgmpMQYAFiQWkj70DCwkHCRCB HZJDOUt5wUcUAAAAAAAeACBzYWx0QG5vdGF0aW9ucy5zZXF1b2lhLXBncC5vcmcQ LUNEYWE0LcmZi084v2NCvn6yEuINrfq9OGkVy385DAMVCggCmQECmwECHgkWIQTS 4IHpP9yi54tfxDOBHZJDOUt5wQAAYOoA/RGoqHdtnZBqxUeXtUfIqoXnHn+FEphU 6CS4GHwYgSJFAP0ce+15SkJi2VvSElFqvkeIbdh7gomteMAfqIJFAW/OCMeGBGpM QYAWCSsGAQQB2kcPAQEHQE1Rjs6t3JJG2+UEf+zBg+g4pRD/ol/iOpg8P58vQR1P /gkDCBjWEF9Wp4kL/6dQC/ZJG+cMCBNObsxLap40lfTke7B9bIkvJMKG2zgQZFmD +P0Xjx54AoMCdBoD5elL4g8RHrqLfRmqEsgCX192nwZOiB7CwMUEGBYKATcFgmpM QYAFiQWkj70JEIEdkkM5S3nBRxQAAAAAAB4AIHNhbHRAbm90YXRpb25zLnNlcXVv aWEtcGdwLm9yZyPbWroy3KJpldFNV47M7QMGHQ8rQ6Ds0mJXeBzA5P5CApsgvqAE GRYKAG8FgmpMQYAJEPLqKEWf4aYJRxQAAAAAAB4AIHNhbHRAbm90YXRpb25zLnNl cXVvaWEtcGdwLm9yZ7r2xBAYhuFDFKoEDwXIgc6m3QXvzNQG/eFv2JfAS712FiEE Z++ptbFZk3QKYa7M8uooRZ/hpgkAAASFAP9o4O5pjTjH1ujo8UXb+22P69+Fcihz OzfCYrSng/pV9wEAk1WgfQCms4H20m2IPYeqLyOMfH3sIuKKTrDGjSeg1gUWIQTS 4IHpP9yi54tfxDOBHZJDOUt5wQAA4mUBANMpQNBcIb+Gi8iaiyYlMHM3Rtod/TMw prV/DbYEIpUQAP4xd2kzSQVhuUCPiq+RQLei5E3Qx9bS0GIFmt/h0raaAMeFBGpM QYAWCSsGAQQB2kcPAQEHQMNngMJd1pQ+XQ0GUbSiwS3OHZCd4dUfGAkLNB6JqbRY /gkDCMVmOyXdRurS/8c2HaPSB1jITSgg6ZAVG6V1ZxhfVce7HwSjLhKuICQi9+Y3 GDljo3ue/QFTro54AclH9rAPPlwpsbcpYOllULUoz23d/8LAxQQYFgoBNwWCakxB gAWJBaSPvQkQgR2SQzlLecFHFAAAAAAAHgAgc2FsdEBub3RhdGlvbnMuc2VxdW9p YS1wZ3Aub3JnZUbCxX8ypIkwqs0KmQ4WjsmPgyqO4agTzNiWQCDcJBQCmwK+oAQZ FgoAbwWCakxBgAkQtObvvvoWfY5HFAAAAAAAHgAgc2FsdEBub3RhdGlvbnMuc2Vx dW9pYS1wZ3Aub3JnxPnaJie9YiqdQjuk3kKU3g+U5P4LCs/9DLVbcMWxE58WIQTK yP+HQkGn71lSMmG05u+++hZ9jgAAuTwA/A1884gQ+whCdQYHqx2dRSb6ijTEID04 vNfipqkwVeMEAQDx/BDvmCjhQxvyLXwQWzwmpg9TajJ9JIX5gfQfQ+AUCBYhBNLg gek/3KLni1/EM4EdkkM5S3nBAACEGAEAhCuyvJd3xYFoy1oSfFT05SYYffEu14vV 8AZEImlbMxIBAL1VPDuFgzurhFH11uBNFZctiD0STqy3ie0FqWdu79ECx4sEakxB gBIKKwYBBAGXVQEFAQEHQGYIS0ABM7tj0fiVSRc01ubWpmamos9nmfwJjlsL2gV6 AwEIB/4JAwiTiWBEjQz6e/+8ggxoJQAReywsGp/dyXqGJKmUMzZ3Wd4JOdY/eaa/ /JXUxUFn5xQM4aQMgzNqZHhVETviatOgzGjdIYkrXk/B+9xRSCutwsAGBBgWCgB4 BYJqTEGABYkFpI+9CRCBHZJDOUt5wUcUAAAAAAAeACBzYWx0QG5vdGF0aW9ucy5z ZXF1b2lhLXBncC5vcmfsDzehKc6JLlUgf6olNquNINHH1gVHtdwJ95ebnDYTUQKb DBYhBNLggek/3KLni1/EM4EdkkM5S3nBAADqzQEA1IooYWmFopaZ0DPcEVRR4laQ 7XfFjtq6hmJHaCdy8FcBAJKK1DZchtVbUMZeiVfin/ZRC84Ex44f54THm7Xne/EC =f9e3 -----END PGP PRIVATE KEY BLOCK----- hOpenPGP-3.0.2.1/tests/data/v4-encrypted.rev.aa0000644000000000000000000000110507346545000017156 0ustar0000000000000000-----BEGIN PGP PUBLIC KEY BLOCK----- Comment: Revocation certificate for Comment: D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1 Comment: Comment: v4 Test User xjMEakxBgBYJKwYBBAHaRw8BAQdAP6cjID4HFp73MwUjEA/nCYXMRSItPLypDLtZ jPULW1jCwAsEIBYKAH0FgmpMQYAJEIEdkkM5S3nBRxQAAAAAAB4AIHNhbHRAbm90 YXRpb25zLnNlcXVvaWEtcGdwLm9yZ/hWf5apgI9nH8rb38xB9/pvNhBar7LRWmx3 nhaGr1GIDR0AVW5zcGVjaWZpZWQWIQTS4IHpP9yi54tfxDOBHZJDOUt5wQAAytsA /R0VwOa7/1datJPZxyqeF0t9xD/XUGvjxMAnDoJSWyLyAQCPOEdgir5BeKShK+Z3 J45dM+Ccv0l5tcQDqUsOUMa0AA== =ASZC -----END PGP PUBLIC KEY BLOCK----- hOpenPGP-3.0.2.1/tests/data/v6-encrypted-secret.pgp.aa0000644000000000000000000000525607346545000020450 0ustar0000000000000000-----BEGIN PGP PRIVATE KEY BLOCK----- Comment: 32CE C253 59F9 C8D6 3826 4B92 CBC6 1BD1 BBEC 7E9A AD89 E959 4733 8CF1 DA07 F058 Comment: Comment: v6 Test User xXkGakxBgBsAAAAg1oMAToYSbuWWtIzPm9PIKvJ6J98lqv+5ng49beQ9V/j9HQcC CwMIxWMMt1MYs9b/eD2S/SnKK6pbBX93VUbZWBiHJnQ3kOT2GIKUB7Vw6BmSySAN 7pQ6PK47kYOOQH//3sGc/QQkzflGDD2PjXudwqwGHxsKAAAAPQWCakxBgAWJBaSP vQMLCQcDFQoIApsBAh4JIiEGMs7CU1n5yNY4JkuSy8Yb0bvsfpqtielZRzOM8doH 8FgAAAAAJQgg45XFNDIO0nCQMPFBicBBQSGXRC7BUFXMJDh5lIl/yM+A03QIcPZz xY/SwBw/z6bDaDAK4h4NqyqtZSshWT5qr/Oa2StGhJDmweprq9Xec0NmOkSuqie5 oNpztLlxVmUIzRQ8djZ0ZXN0QGV4YW1wbGUub3JnPsKsBhMbCgAAAD0FgmpMQYAF iQWkj70DCwkHAxUKCAKbAQIeCSIhBjLOwlNZ+cjWOCZLksvGG9G77H6arYnpWUcz jPHaB/BYAAAAAAHVIPKTJfudOO4LCl6IrL5pAMfednt4pNuRdFtxndW2qnjwcWs7 kLcdaCuZA0lOTny45W4PEfd+3O/VH9xhrQAlAlqho5hSY829SVuyj8Co4g2+hsCU 7VOw50ZhiKV0e8PNCc0MdjYgVGVzdCBVc2Vywq8GExsKAAAAQAWCakxBgAWJBaSP vQMLCQcDFQoIApkBApsBAh4JIiEGMs7CU1n5yNY4JkuSy8Yb0bvsfpqtielZRzOM 8doH8FgAAAAAksogZP9HWjht+o2BizMXb3O/PY3o7xM/L4qvMVtCwefOd0pfvA/9 pzyzstibRwGt2G0dSt7Im9rPB901jx+JEQ5O1pBeeViDjjGfinfgdQGRSuXiE5Og x9beaD/zL2z2+HcIx3kGakxBgBkAAAAgLIMLb9rjPv6SuUUjetw1OjBGxgXvWFTF ukrXvjoQsCz9HQcCCwMItAVsIsB+U27/nBSTDChBkbQxSnr5CS3Bza0oFmwWPUzj 54MCdFIimTlWDZXr4lIrQ4hPzPQP5xkB8dMryUYwIyaukdPWzbPswqEGGBsKAAAA MgWCakxBgAWJBaSPvQKbDCIhBjLOwlNZ+cjWOCZLksvGG9G77H6arYnpWUczjPHa B/BYAAAAALXGIL8fipTBFSbTUs81DDZpPKHxcNA80KAS+wvmUXWnN8TaQkzOEPZG EZtCPAwxR0D44KExjz2KPLonPipUQSewywPWSnchZxsTzLwc5xg+pDGEUpauAmlI hD6ecS2Yxs2hBcd5BmpMQYAbAAAAIBoWs2hwtFW5kb6gVRzcF+eFEfg3oJLw/25t Q0KvDaVJ/R0HAgsDCPh8ObANgrr+//PXRHA8hjuSzjuyU61GExf9mKLxmh16skzt F7S6vG4+zEB+aV5P670RuJoUN6PSl3m2iYSlgyfUcCzUKGjX18LAewYYGwoAAADM BYJqTEGABYkFpI+9ApsCmaAGGRsKAAAAKQWCakxBgCIhBiniBDbl6FnIFyBqaYAh 4JQJwX4xhq8bIoMxweitygolAAAAAEz5IFg0a1XooQ5PQmXrHMIMgh0GOnUaGMBL yUh5z8qneFyCZAxiSqdHfjd0KLTeVP1g/rLhe3jSVKNKfUXJVWCtq7QJVuCaM9YT apGziuWQlfZk8Tt9a68ensqt0nLwKlR8BiIhBjLOwlNZ+cjWOCZLksvGG9G77H6a rYnpWUczjPHaB/BYAAAAALPOICs/oWmhRDQYftgppJzMa/+cpl5c7vLChFUUBR6b +NJqMZ5ylOqnlG0p+ChDHsSGUBiG+BEFXnDWUinWdFKeh+0jLuNSB5dZ9dF/OIHJ H8Tu+LhYKJk5wN6JtV9fdn8ODsd5BmpMQYAbAAAAID80a78b0QYapNdFtEnnk5Cb avGoSYfbYgsHk+jeNmwq/R0HAgsDCOmegpsLvtoM/xULeK8uDbU/i0YgyTQB1tst lNqLySUN2CbvsS8baJoZ5irdQYQeEEcDhM3IVeIYCVze+dVQmkTd4WhqFOrAtMLA ewYYGwoAAADMBYJqTEGABYkFpI+9ApsgmaAGGRsKAAAAKQWCakxBgCIhBjnUHSo8 V0evcd7pGoYWp/4mO3ECkBKpcLo5m+3PN4gHAAAAAKeGIE/NTyVwIE2aFEhGoG9D m0RwL+3/duFLe/F39cdsB3OHEqJ1rFBeMin7E1iYSr12ZhmCe64hf2RzUJST3QU6 niL6Yqyi5YioWXplby5RuPrzF299t/VQ+e/PytoEKPjCDCIhBjLOwlNZ+cjWOCZL ksvGG9G77H6arYnpWUczjPHaB/BYAAAAAPI0IMCbemT/0d/SfD4U5v9/DU/JyOrl ZJ4PH0YESj/vQzicvN6gmGfKMEJ/hveCJjVuC72ZxS6DSWYSm9nhL30yyDnK8fAD yMyuQTuXtst+Gf/pl5ztZvoojvhSleTvd6tKAA== =AIsx -----END PGP PRIVATE KEY BLOCK----- hOpenPGP-3.0.2.1/tests/data/v6-encrypted.rev.aa0000644000000000000000000000104207346545000017160 0ustar0000000000000000-----BEGIN PGP PUBLIC KEY BLOCK----- Comment: Revocation certificate for Comment: 32CE C253 59F9 C8D6 3826 4B92 CBC6 1BD1 BBEC 7E9A AD89 E959 4733 8CF1 DA07 F058 Comment: Comment: v6 Test User xioGakxBgBsAAAAg1oMAToYSbuWWtIzPm9PIKvJ6J98lqv+5ng49beQ9V/jCpgYg GwoAAAA3BYJqTEGADR0AVW5zcGVjaWZpZWQiIQYyzsJTWfnI1jgmS5LLxhvRu+x+ mq2J6VlHM4zx2gfwWAAAAADMiyDTZiqP5aC8G6/kziMKWSXqSiP61tmMyJAjvVRx byJ/d/+t+1Dr5ieijm0cR+rrGSiXFKJWtkXDAjve/+frBADmfcRloNGddxgfiSp2 Sb1r6UXgOYCo8P1+YeRQ6/mvGgw= =XR1p -----END PGP PUBLIC KEY BLOCK----- hOpenPGP-3.0.2.1/tests/data/v6-secret.pgp.aa0000644000000000000000000000466207346545000016455 0ustar0000000000000000-----BEGIN PGP PRIVATE KEY BLOCK----- Comment: 7106 CB6D B27E 4FC9 B050 B02B B316 4DBD 4BBD 7263 D4D2 9E78 A3BB 3BDB B022 2D19 Comment: Comment: v6 Test User xUsGakxBgBsAAAAgEhCa7+BbRnpktxB2tSIBG0mJGogpIGrasQBPzaPr3ekAvvBU Bu+9shdsNlXWmTsCSJwLTyNlTd31sZJUFDDlY5TCrAYfGwoAAAA9BYJqTEGABYkF pI+9AwsJBwMVCggCmwECHgkiIQZxBsttsn5PybBQsCuzFk29S71yY9TSnnijuzvb sCItGQAAAACmHSA3LXqhKrfXYDTN+XRYSybN64k3IGnh1iVuKNcV5DNiVCClQuE0 EyGOkVQOuYPUM0Q+v1ar1++ixEOvmfM2wxR7Bmyfz7awHuUhkVOU1wNBg5j+U44x XL8+C3XHGfVPcQHNFDx2NnRlc3RAZXhhbXBsZS5vcmc+wqwGExsKAAAAPQWCakxB gAWJBaSPvQMLCQcDFQoIApsBAh4JIiEGcQbLbbJ+T8mwULArsxZNvUu9cmPU0p54 o7s727AiLRkAAAAAFnQg5Hpw6Pct1YhDi0QUU9N5QujqcvM8uPTeNlGKcTzA5sEx tN+L+tZV2HosEsMvdmI50tBAU3GMfUFajy5u5sUTmQQR7gL5UPSze91ssHFl28wc ugEvWaoZHjYN6/C/qA0HzQx2NiBUZXN0IFVzZXLCrwYTGwoAAABABYJqTEGABYkF pI+9AwsJBwMVCggCmQECmwECHgkiIQZxBsttsn5PybBQsCuzFk29S71yY9TSnnij uzvbsCItGQAAAACfxiC0/6DoxjwhBGuGCvU0pnW0c6C496DRmHtoM27fafgAx2ZI cDVMbfs1JLYcdvmGY0RmM1Q0glD2tweLw/gZSQHMGd/VCTFfIhc0aK/QITSMyXYP Z69MnYo7KiMFqRJNwwTHSwZqTEGAGQAAACCWGPQ+ZHf1dXLKhGryoCONAe5BTmFe 4E14Tb+8/bR8QwCQEp+Vu6qDzICxipZHd3vLbMZP60H1o6jSqrkTK2WYScKhBhgb CgAAADIFgmpMQYAFiQWkj70CmwwiIQZxBsttsn5PybBQsCuzFk29S71yY9TSnnij uzvbsCItGQAAAAAvJiAtIVQW3AJRozbisVXgviXGZWAfM6ABw5A9ppehycuri0Me jJQ8tvOn111Mpnp1qvdqnXbAbdDNDj41MGtKVhPp26/UQoVlDf0SJOEMeB+KCMnD FtM9+wC1MYj9P/sHjArHSwZqTEGAGwAAACB/xEk095PsOqqJHlZPPLWP/V0wpvTU ta/Qp82vqp8F7wBoHVm2xtHFom3N3I95pggPSXHhugdmNtClOPJmlQl9b8LAewYY GwoAAADMBYJqTEGABYkFpI+9ApsCmaAGGRsKAAAAKQWCakxBgCIhBgS1u4kIGzgK 4Qa7pat/ZNewRH7+RW7/Hqb0n22ofkX9AAAAAKIRIAiEanRct+Zp/7csescjDWtJ Q5fa05mrHbPsVytf1rwvnwcURu4aQKjsj+/A1gYvZxUCJy6ejetmodaaJ/ck+nQs GlgwDl8++C07uTtW4jsiwLu9mnZXHH3fyb67SeujDSIhBnEGy22yfk/JsFCwK7MW Tb1LvXJj1NKeeKO7O9uwIi0ZAAAAAAIDIMdRAS2ILqPgvGm87LSNWetCJs471n0y zZgM18zaO2HmMo6LKOpyfX/ymKCauZ9WoyLPYSNYgE5LauuNdsLcf/8mO2nMgBD2 SHfUx7YlLhh+3+dIzKjUxdA+wVj+o3cJAMdLBmpMQYAbAAAAIPJBU3RXwu8lQi67 angD599mgwABnG/r3mpUCtv3tHMoAKxO0dWnL67B1QYme/+mkPg/wyxcdMBRQ8qo ExEgCwJRwsB7BhgbCgAAAMwFgmpMQYAFiQWkj70CmyCZoAYZGwoAAAApBYJqTEGA IiEGLk54ViE/tvopCjF7pB+h64Q9T8ZIO5gZzpsPnaGlHaIAAAAAAvgg51QNb+G6 x0JN4MKJRUAxQgUwKc4LeB5lprX89jyOacZFi4WOJlGnN5laFPYUoiYjNrheqWQ/ LQeVvFn0emHhJwZ80sTT3NmBsOa72LP4NrA6joVs93Wqcf/wI/xUqE8DIiEGcQbL bbJ+T8mwULArsxZNvUu9cmPU0p54o7s727AiLRkAAAAAF8Qgdmk3k4zvfV0DUoBR gX2D7RdaLZWF0FDh3f2j3VwZgzQvZ3k7Ej9SV26ppWJICDDIkN/Tiwdt1LHfabXt aD7R4srORuMXYlByXeiZvtlSDxwwlBvEFiNa1ok8m1yIW40B =AQyI -----END PGP PRIVATE KEY BLOCK----- hOpenPGP-3.0.2.1/tests/data/v6.rev.aa0000644000000000000000000000104207346545000015165 0ustar0000000000000000-----BEGIN PGP PUBLIC KEY BLOCK----- Comment: Revocation certificate for Comment: 7106 CB6D B27E 4FC9 B050 B02B B316 4DBD 4BBD 7263 D4D2 9E78 A3BB 3BDB B022 2D19 Comment: Comment: v6 Test User xioGakxBgBsAAAAgEhCa7+BbRnpktxB2tSIBG0mJGogpIGrasQBPzaPr3enCpgYg GwoAAAA3BYJqTEGADR0AVW5zcGVjaWZpZWQiIQZxBsttsn5PybBQsCuzFk29S71y Y9TSnnijuzvbsCItGQAAAACfECAsbAxOTt7OS9uh9pUoCgUqzT3zpA0u000/R07W pf9YN1eYQZPq0wpudkTUoFOdnrMFbG7qsSK9zKpsNtfBDEpMkY5XBUoBo8jBHWA0 Hpa9Y1pzxQOq6flm84IKSZtN3go= =lm+m -----END PGP PUBLIC KEY BLOCK----- hOpenPGP-3.0.2.1/tests/0000755000000000000000000000000007346545000012626 5ustar0000000000000000hOpenPGP-3.0.2.1/tests/suite.hs0000644000000000000000000000200407346545000014307 0ustar0000000000000000-- suite.hs: hOpenPGP test suite -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). import Test.Tasty (TestTree, defaultMain, localOption, testGroup) import qualified Test.Tasty.QuickCheck as QC import Test.Tasty.Runners (NumThreads(..)) import Tests.Encryption (encryptionAndCompressionTests) import Tests.Keys (keyAndVerificationTests) import Tests.MessageAndArmor (messageAndArmorTests) import Tests.Properties (propertiesTests) import Tests.Serialization (serializationTests) import Tests.Utilities (utilityTests) tests :: TestTree tests = localOption (NumThreads 4) (testGroup "Tests" [ localOption (QC.QuickCheckTests 20) propertiesTests , unitTests ]) unitTests :: TestTree unitTests = testGroup "Unit Tests" [ serializationTests , keyAndVerificationTests , encryptionAndCompressionTests , messageAndArmorTests , utilityTests ] main :: IO () main = defaultMain tests