packages feed

hOpenPGP 2.10.1.1 → 3.0.0

raw patch · 56 files changed

+30126/−3843 lines, 56 filesdep ~aesondep ~hashabledep ~openpgp-asciiarmor

Dependency ranges changed: aeson, hashable, openpgp-asciiarmor

Files

Codec/Encryption/OpenPGP/Arbitrary.hs view
@@ -1,35 +1,108 @@ -- Arbitrary.hs: QuickCheck instances--- Copyright © 2014-2019  Clint Adams+-- 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 where+instance Arbitrary (PKESK 'PKESKV3) where   arbitrary = do-    pv <- arbitrary     eoki <- arbitrary     pka <- arbitrary-    PKESK pv eoki 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 @@ -57,7 +130,7 @@         w16 <- arbitrary         SigV4 st pka ha has uhas w16 <$> arbitrary       other = do-        v <- choose (5, maxBound)+        v <- oneof [pure 5, choose (7, maxBound)]         SigVOther v <$> arbitrary  instance Arbitrary SigSubPacket where@@ -67,32 +140,34 @@  instance Arbitrary SigSubPacketPayload where   arbitrary =-    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 -}+    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@@ -105,7 +180,7 @@       rk =         arbitrary >>= \rcs ->           arbitrary >>= \pka ->-            arbitrary >>= \tof -> return (RevocationKey rcs pka tof)+            fmap (RevocationKey rcs pka . Fingerprint . BL.pack) (vector 20)       i = fmap Issuer arbitrary       nd =         arbitrary >>= \nfs ->@@ -127,19 +202,49 @@         arbitrary >>= \pka ->           arbitrary >>= \ha ->             arbitrary >>= \sh -> return (SignatureTarget pka ha sh)-      es = fmap EmbeddedSignature arbitrary -- FIXME: figure out why EmbeddedSignature fails to serialize properly+      es _ = pure (EmbeddedSignature (SigVOther 5 BL.empty))       ifp =-        choose (4, 5) >>= \v ->+        elements [IssuerFingerprintV4, IssuerFingerprintV6] >>= \v ->           fmap             (IssuerFingerprint v)-            (if v == 4-               then arbitrary-               else fmap (TwentyOctetFingerprint . BL.pack) (vector 32))+            (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 =-        choose (111, 127) >>= \a -> arbitrary >>= \b -> return (OtherSigSub a b) -- FIXME: more comprehensive range+        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@@ -148,8 +253,13 @@ instance Arbitrary EightOctetKeyId where   arbitrary = fmap (EightOctetKeyId . BL.pack) (vector 8) -instance Arbitrary TwentyOctetFingerprint where-  arbitrary = fmap (TwentyOctetFingerprint . BL.pack) (vector 20)+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@@ -176,7 +286,17 @@  instance Arbitrary HashAlgorithm where   arbitrary =-    elements [DeprecatedMD5, SHA1, RIPEMD160, SHA256, SHA384, SHA512, SHA224]+    elements+      [ DeprecatedMD5+      , SHA1+      , RIPEMD160+      , SHA256+      , SHA384+      , SHA512+      , SHA224+      , SHA3_256+      , SHA3_512+      ]  instance Arbitrary SymmetricAlgorithm where   arbitrary =@@ -201,13 +321,13 @@   arbitrary = frequency [(9, srk), (1, rco)]     where       srk = return SensitiveRK-      rco = fmap RClOther (choose (2, 7))+      rco = fmap mkRevocationClass (choose (2, 6))  instance Arbitrary NotationFlag where   arbitrary = frequency [(9, hr), (1, onf)]     where       hr = return HumanReadable-      onf = fmap OtherNF (choose (1, 31))+      onf = fmap mkNotationFlag (choose (1, 15))  instance Arbitrary CompressionAlgorithm where   arbitrary = elements [Uncompressed, ZIP, ZLIB, BZip2]@@ -241,10 +361,11 @@       ]  instance Arbitrary FeatureFlag where-  arbitrary = frequency [(9, md), (1, fo)]+  arbitrary = frequency [(8, seipdV1), (1, seipdV2), (1, fo)]     where-      md = return ModificationDetection-      fo = fmap FeatureOther (choose (8, 63))+      seipdV1 = return FeatureSEIPDv1+      seipdV2 = return FeatureSEIPDv2+      fo = fmap FeatureOther (suchThat (choose (0, 63)) (`notElem` [4, 7]))  instance Arbitrary ThirtyTwoBitTimeStamp where   arbitrary = fmap ThirtyTwoBitTimeStamp arbitrary
Codec/Encryption/OpenPGP/BlockCipher.hs view
@@ -1,11 +1,14 @@--- BlockCipher.hs: OpenPGP (RFC4880) block cipher stuff--- Copyright © 2013-2024  Clint Adams+-- 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-  ( keySize+  ( CipherError(..)+  , renderCipherError+  , keySize   , withSymmetricCipher   ) where @@ -21,53 +24,86 @@ 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 String a-withSymmetricCipher Plaintext _ _ = Left "this shouldn't have happened" -- FIXME: orphan instance?-withSymmetricCipher IDEA _ _ = Left "IDEA not yet implemented" -- FIXME: IDEA-withSymmetricCipher ReservedSAFER _ _ = Left "SAFER not implemented" -- FIXME: or not?-withSymmetricCipher ReservedDES _ _ = Left "DES not implemented" -- FIXME: or not?-withSymmetricCipher (OtherSA _) _ _ =-  Left "Unknown, unimplemented symmetric algorithm"-withSymmetricCipher CAST5 key f =-  (cipherInit key :: Either String (HOWrappedOldCCT CNC.CAST128)) >>= f-withSymmetricCipher Twofish key f =-  (cipherInit key :: Either String (HOWrappedOldCCT CNC.TWOFISH)) >>= f-withSymmetricCipher TripleDES key f =-  (cipherInit key :: Either String (HOWrappedCCT TripleDES.DES_EDE3)) >>= f-withSymmetricCipher Blowfish key f =-  (cipherInit key :: Either String (HOWrappedCCT Blowfish.Blowfish128)) >>= f-withSymmetricCipher AES128 key f =-  (cipherInit key :: Either String (HOWrappedCCT AES.AES128)) >>= f-withSymmetricCipher AES192 key f =-  (cipherInit key :: Either String (HOWrappedCCT AES.AES192)) >>= f-withSymmetricCipher AES256 key f =-  (cipherInit key :: Either String (HOWrappedCCT AES.AES256)) >>= f-withSymmetricCipher Camellia128 key f =-  (cipherInit key :: Either String (HOWrappedCCT Camellia.Camellia128)) >>= f-withSymmetricCipher Camellia192 key f =-  (cipherInit key :: Either String (HOWrappedOldCCT CNC.Camellia192)) >>= f-withSymmetricCipher Camellia256 key f =-  (cipherInit key :: Either String (HOWrappedOldCCT CNC.Camellia256)) >>= f+     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 --- in octets; FIXME: co-opt Cipher's cipherKeySize or not?-keySize :: SymmetricAlgorithm -> Int-keySize Plaintext = 0-keySize IDEA = 16 -- according to https://en.wikipedia.org/wiki/International_Data_Encryption_Algorithm-keySize TripleDES = 24 -- RFC 4880 says 168 bits (derived from 192 bits) but we don't know who does the derivation-keySize CAST5 = 16-keySize Blowfish = 16-keySize ReservedSAFER = undefined-keySize ReservedDES = undefined-keySize AES128 = 16-keySize AES192 = 24-keySize AES256 = 32-keySize Twofish = 32-keySize Camellia128 = 16-keySize Camellia192 = 24-keySize Camellia256 = 32-keySize (OtherSA _) = undefined+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))
Codec/Encryption/OpenPGP/CFB.hs view
@@ -1,33 +1,68 @@--- CFB.hs: OpenPGP (RFC4880) CFB mode--- Copyright © 2013-2019  Clint Adams+-- 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 (withSymmetricCipher)+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 String B.ByteString-decryptOpenPGPCfb Plaintext ciphertext _ = return ciphertext+  -> 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 cleartext+      then return (nonce, cleartext)       else Left "Session key quickcheck failed"   where     decrypt1 ::@@ -54,37 +89,30 @@      SymmetricAlgorithm   -> B.ByteString   -> B.ByteString-  -> Either String B.ByteString+  -> Either CipherError B.ByteString decrypt x y z = snd <$> (decryptPreservingNonce x y z)  decryptPreservingNonce ::      SymmetricAlgorithm   -> B.ByteString   -> B.ByteString-  -> Either String (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-    (nonce, cleartext) <--      fmap (B.splitAt (blockSize bc + 2)) (decrypt' ciphertext bc)+    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"-  where-    decrypt' ::-         HOBlockCipher cipher-      => B.ByteString-      -> cipher-      -> Either String B.ByteString-    decrypt' ct cipher =-      paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0) ct  decryptNoNonce ::      SymmetricAlgorithm   -> IV   -> B.ByteString   -> B.ByteString-  -> Either String B.ByteString+  -> Either CipherError B.ByteString decryptNoNonce Plaintext _ ciphertext _ = return ciphertext decryptNoNonce sa iv ciphertext keydata =   withSymmetricCipher sa keydata (decrypt' ciphertext)@@ -106,7 +134,7 @@   -> IV   -> B.ByteString   -> B.ByteString-  -> Either String B.ByteString+  -> Either CipherError B.ByteString encryptNoNonce Plaintext _ _ payload _ = return payload encryptNoNonce sa s2k iv payload keydata =   withSymmetricCipher sa keydata (encrypt' payload)@@ -117,3 +145,71 @@       -> 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
Codec/Encryption/OpenPGP/Compression.hs view
@@ -1,9 +1,12 @@--- Compression.hs: OpenPGP (RFC4880) compression and decompression--- Copyright © 2012-2015  Clint Adams+-- 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-  ( decompressPkt+  ( CompressionError(..)+  , renderCompressionError+  , decompressPkt   , compressPkts   ) where @@ -15,26 +18,81 @@ import Data.Binary (get, put) import Data.Binary.Get (runGetOrFail) import Data.Binary.Put (runPut)+import qualified Data.ByteString.Lazy as BL -decompressPkt :: Pkt -> [Pkt]-decompressPkt (CompressedDataPkt algo bs) =-  case runGetOrFail get (dfunc algo bs) of-    Left _ -> []-    Right (_, _, packs) -> unBlock packs+-- | 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 ZIP = ZlibRaw.decompress-    dfunc ZLIB = Zlib.decompress-    dfunc BZip2 = BZip.decompress-    dfunc _ = error "Compression algorithm not supported"-decompressPkt p = [p]+    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-   in CompressedDataPkt ca cbs+      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 _ = error "Compression algorithm not supported"+    cfunc _ = id++isSupportedCompressionAlgorithm :: CompressionAlgorithm -> Bool+isSupportedCompressionAlgorithm Uncompressed = True+isSupportedCompressionAlgorithm ZIP = True+isSupportedCompressionAlgorithm ZLIB = True+isSupportedCompressionAlgorithm BZip2 = True+isSupportedCompressionAlgorithm (OtherCA _) = False
+ Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -0,0 +1,2251 @@+-- 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+  , recipientEncryptionTargetsFromTKAtTimestamp+  , recipientEncryptionTargetFromTK+  , recipientEncryptionTargetsFromTK+  , 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+  , 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.Lens ((.~), ix)+import Control.Monad (when)+import Data.List (find, foldl', maximumBy)+import Data.Maybe (fromMaybe, 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 =+  case recipientEncryptionTargetsAccepted (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) of+    (target:_) -> Right target+    [] -> Left RecipientCapabilityNoEncryptableKeyMaterialInTK++recipientEncryptionTargetFromTK :: TK 'PublicTK -> Either RecipientCapabilityError RecipientEncryptionTarget+recipientEncryptionTargetFromTK tk =+  recipientEncryptionTargetFromTKAtTimestamp+    (_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++-- | 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)++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)++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, <ciphertext>]@+--+-- 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
Codec/Encryption/OpenPGP/Expirations.hs view
@@ -1,35 +1,310 @@--- Expirations.hs: OpenPGP (RFC4880) expiration checking--- Copyright © 2014-2015  Clint Adams+-- 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-  ( isTKTimeValid+  ( 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.Time.Clock (UTCTime)+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 -> TK -> Bool-isTKTimeValid ct key = ct >= keyCreationTime && ct < keyExpirationTime+isTKTimeValid :: UTCTime -> TKUnknown -> Bool+isTKTimeValid ct = keyStateValid . keyStateAt ct++keyStateAt :: UTCTime -> TKUnknown -> KeyState+keyStateAt ct tk =+  baseState {keyStateValid = keyStateValid baseState && bindingStateAllowsValidation}   where-    keyCreationTime =-      key ^. tkKey . _1 . timestamp & posixSecondsToUTCTime . realToFrac-    keyExpirationTime =-      posixSecondsToUTCTime . realToFrac .-      ((key ^. tkKey . _1 . timestamp & unThirtyTwoBitTimeStamp) +) .-      unThirtyTwoBitDuration .-      newest .-      concatMap getKeyExpirationTimesFromSignature $-      (concatMap snd (key ^. tkUIDs) ++ concatMap snd (key ^. tkUAts))-    newest [] = maxBound-    newest xs = maximum xs+    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 (SigV4 _ _ _ xs _ _ _) =-  map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ filter isKET xs+getKeyExpirationTimesFromSignature sig =+  map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $+  filter isKET (signatureHashedSubpackets sig)
Codec/Encryption/OpenPGP/Fingerprint.hs view
@@ -1,50 +1,96 @@--- Fingerprint.hs: OpenPGP (RFC4880) fingerprinting methods--- Copyright © 2012-2016  Clint Adams+-- 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)+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 :: PKPayload -> Either String EightOctetKeyId-eightOctetKeyID (PKPayload DeprecatedV3 _ _ RSA (RSAPubKey (RSA_PublicKey rp))) =-  (Right .-   EightOctetKeyId .-   BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n)-    rp-eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSAEncryptOnly (RSAPubKey (RSA_PublicKey rp))) =-  (Right .-   EightOctetKeyId .-   BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n)-    rp-eightOctetKeyID (PKPayload DeprecatedV3 _ _ DeprecatedRSASignOnly (RSAPubKey (RSA_PublicKey rp))) =-  (Right .-   EightOctetKeyId .-   BL.reverse . BL.take 4 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n)-    rp-eightOctetKeyID (PKPayload DeprecatedV3 _ _ _ _) =-  Left "Cannot calculate the key ID of a non-RSA V3 key"-eightOctetKeyID p4@(PKPayload V4 _ _ _ _) =-  (Right . EightOctetKeyId . BL.drop 12 . unTOF . fingerprint) p4+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 :: PKPayload -> TwentyOctetFingerprint-fingerprint p3@(PKPayload DeprecatedV3 _ _ _ _) =-  (TwentyOctetFingerprint .-   BL.fromStrict . BA.convert . (hashlazy :: BL.ByteString -> Digest MD5))-    (runPut $ putPKPforFingerprinting (PublicKeyPkt p3))-fingerprint p4@(PKPayload V4 _ _ _ _) =-  (TwentyOctetFingerprint .-   BL.fromStrict . BA.convert . (hashlazy :: BL.ByteString -> Digest SHA1))-    (runPut $ putPKPforFingerprinting (PublicKeyPkt p4))+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))
Codec/Encryption/OpenPGP/Internal.hs view
@@ -1,7 +1,10 @@ -- Internal.hs: private utility functions and such--- Copyright © 2012-2019  Clint Adams+-- 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@@ -10,11 +13,12 @@   , issuer   , issuerFP   , emptyPSC+  , leftPadTo   , pubkeyToMPIs   , multiplicativeInverse   , curveoidBSToCurve   , curveToCurveoidBS-  , point2BS+  , point2MBS   , curveoidBSToEdSigningCurve   , edSigningCurveToCurveoidBS   , curve2Curve@@ -34,7 +38,7 @@ import Data.List (find) import Data.Word (Word16, Word8) -import Codec.Encryption.OpenPGP.Ontology (isIssuerSSP, isIssuerFPSSP, isSigCreationTime)+import Codec.Encryption.OpenPGP.Ontology (isIssuerSSP, isSigCreationTime) import Codec.Encryption.OpenPGP.Types  countBits :: ByteString -> Word16@@ -68,16 +72,66 @@     (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 (SignaturePkt (SigV4 _ _ _ _ usubs _ _)) =-  fmap (\(SigSubPacket _ (Issuer i)) -> i) (find isIssuerSSP usubs)-issuer _ = Nothing+issuer pkt =+  case fromPktIssuerExtractionCase pkt of+    Just extractionCase ->+      find isIssuerSSP (unhashedSubpackets extractionCase) >>= issuerFromSubpacket+    Nothing -> Nothing -issuerFP :: Pkt -> Maybe TwentyOctetFingerprint-issuerFP (SignaturePkt (SigV4 _ _ _ hsubs _ _ _)) =-  fmap (\(SigSubPacket _ (IssuerFingerprint _ i)) -> i) (find isIssuerFPSSP hsubs)-issuerFP _ = 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)]@@ -91,12 +145,16 @@     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 (point2BS q))]-pubkeyToMPIs (ECDHPubKey (EdDSAPubKey _ (EPoint x)) _ _) = [MPI x]+  [MPI (os2ip (pointToBSOrError q))]+pubkeyToMPIs (ECDHPubKey (EdDSAPubKey _ ep) _ _) = [MPI (edPointInteger ep)] pubkeyToMPIs (ECDSAPubKey ((ECDSA_PublicKey (ECDSA.PublicKey _ q)))) =-  [MPI (os2ip (point2BS q))]-pubkeyToMPIs (EdDSAPubKey _ (EPoint x)) = [MPI x]+  [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@@ -111,6 +169,8 @@   | 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@@ -120,16 +180,36 @@ 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" -point2BS :: ECCT.PublicPoint -> B.ByteString-point2BS (ECCT.Point x y) = B.concat [B.singleton 0x04, i2osp x, i2osp y] -- FIXME: check for length equality?-point2BS ECCT.PointO = error "FIXME: point at infinity"+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), ")"]@@ -137,6 +217,7 @@ 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
+ Codec/Encryption/OpenPGP/Internal/CryptoAES.hs view
@@ -0,0 +1,37 @@+-- 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
+ Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs view
@@ -0,0 +1,71 @@+-- 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)
+ Codec/Encryption/OpenPGP/Internal/CryptoSEIPDv2.hs view
@@ -0,0 +1,135 @@+-- 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
+ Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs view
@@ -0,0 +1,227 @@+-- 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)
Codec/Encryption/OpenPGP/KeyInfo.hs view
@@ -1,7 +1,8 @@--- KeyInfo.hs: OpenPGP (RFC4880) fingerprinting methods--- Copyright © 2012-2018  Clint Adams+-- 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@@ -15,6 +16,7 @@ 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)@@ -26,7 +28,9 @@ 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@@ -39,16 +43,19 @@          then Nothing          else Just (True, x `shiftR` 8)) --- FIXME: redo these for hOpenPGP 3 pkalgoAbbrev :: PubKeyAlgorithm -> String-pkalgoAbbrev RSA = "R"-pkalgoAbbrev DSA = "D"-pkalgoAbbrev ElgamalEncryptOnly = "g"-pkalgoAbbrev DeprecatedRSAEncryptOnly = "-"-pkalgoAbbrev DeprecatedRSASignOnly = "_"-pkalgoAbbrev ECDH = "e"-pkalgoAbbrev ECDSA = "E"-pkalgoAbbrev ForbiddenElgamal = "f"-pkalgoAbbrev DH = "d"-pkalgoAbbrev EdDSA = "w"+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 _) = "."
Codec/Encryption/OpenPGP/KeySelection.hs view
@@ -1,7 +1,8 @@--- KeySelection.hs: OpenPGP (RFC4880) ways to ask for keys--- Copyright © 2014-2018  Clint Adams+-- 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@@ -10,7 +11,7 @@   ) where  import Codec.Encryption.OpenPGP.Types-import Control.Applicative (optional)+import Control.Applicative (optional, (<|>)) import Control.Monad ((<=<)) import Crypto.Number.Serialize (i2osp) import Data.Attoparsec.Text@@ -31,10 +32,10 @@   fmap EightOctetKeyId .   (parseOnly hexes <=< parseOnly (hexPrefix *> hexen 16)) . toUpper -parseFingerprint :: Text -> Either String TwentyOctetFingerprint+parseFingerprint :: Text -> Either String Fingerprint parseFingerprint =-  fmap TwentyOctetFingerprint .-  (parseOnly hexes <=< parseOnly (hexen 40)) . toUpper . T.filter (/= ' ')+  fmap Fingerprint .+  (parseOnly hexes <=< parseOnly (hexen 64 <|> hexen 40 <|> hexen 32)) . toUpper . T.filter (/= ' ')  hexPrefix :: Parser (Maybe Text) hexPrefix = optional (asciiCI "0x")
Codec/Encryption/OpenPGP/KeyringParser.hs view
@@ -1,46 +1,76 @@--- KeyringParser.hs: OpenPGP (RFC4880) transferable keys parsing--- Copyright © 2012-2020  Clint Adams+-- 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   , parseTKs+  , parsePublicTKs+  , parseSecretTKs+  , parseTKsWithWireRep   ) where  import Control.Applicative ((<|>), many)-import Data.Maybe (catMaybes)+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-  , completeResults   , concatMany   , failure   , feed@@ -49,35 +79,79 @@   , 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 _ a ([], Nothing) = error $ "Failure before " ++ show a-parseAChunk op a (cr, Nothing) =-#if MIN_VERSION_incremental_parser(0,4,0)-  either error (\x -> (x, map fst cr)) (inspect (feed (mconcat (map snd cr) <> a) op))-parseAChunk _ a (_, Just (_, p)) = either error (\x -> (x, [])) (inspect (feed a p))-#else-  (inspect (feed (mconcat (map snd cr) <> a) op), map fst cr)-parseAChunk _ a (_, Just (_, p)) = (inspect (feed a p), [])-#endif+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 ([], Nothing) = error "Unexpected finalization failure"-finalizeParsing (cr, Nothing) = (([], Nothing), map fst cr)-#if MIN_VERSION_incremental_parser(0,4,0)-finalizeParsing (_, Just (_, p)) = either error finalizeParsing (inspect (feedEof p))-#else-finalizeParsing (_, Just (_, p)) = finalizeParsing (inspect (feedEof p))-#endif+finalizeParsing st =+  either (error . renderChunkParseError) id (finalizeParsingEither st) -anyTK :: Bool -> Parser [Pkt] (Maybe TK)+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 @@ -102,16 +176,16 @@     unA (A x, y) = (x, y)     unA x = error $ "unA should never be called on " ++ show x -publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TK)+publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TKUnknown) publicTK intolerant = do   pkp <- pkPayload   pkpsigs <-     concatMany-      (signature intolerant [KeyRevocationSig, SignatureDirectlyOnAKey])+      (signatureWithPredicate intolerant isAllowedPrimaryKeySigType)   (uids, uats) <--    fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant+    fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant))   subs <- concatMany (pubsub intolerant)-  return $ Just (TK pkp pkpsigs uids uats subs)+  return $ Just (TKUnknown pkp pkpsigs uids uats subs)   where     pubsub True = signedOrRevokedPubSubkey True     pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey@@ -120,16 +194,16 @@   skp <- skPayload   skpsigs <-     concatMany-      (signature intolerant [KeyRevocationSig, SignatureDirectlyOnAKey])+      (signatureWithPredicate intolerant isAllowedPrimaryKeySigType)   (uids, uats) <--    fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant)) -- FIXME: require >=1 uid if intolerant?+    fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant))   subs <- concatMany (secsub intolerant)-  return $ Just (TK skp skpsigs uids uats subs)+  return $ Just (TKUnknown skp skpsigs uids uats subs)   where     secsub True = rawOrSignedOrRevokedSecSubkey True     secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey -brokenTK :: Int -> Parser [Pkt] (Maybe TK)+brokenTK :: Int -> Parser [Pkt] (Maybe TKUnknown) brokenTK 6 = do   _ <- broken 6   _ <- many (signature False [KeyRevocationSig, SignatureDirectlyOnAKey])@@ -144,18 +218,31 @@   return Nothing brokenTK _ = fail "Unexpected broken packet type" -pkPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)+pkPayload :: Parser [Pkt] (SomePKPayload, Maybe SKAddendum) pkPayload = do   pkpkts <- satisfy isPKP   case pkpkts of-    [PublicKeyPkt p] -> return (p, Nothing)+    [pkt] ->+      case pktToPublicKeyPkt pkt of+        Just keyPkt | keyPktRole keyPkt == KeyPktPrimary ->+          return (keyPktTKKey keyPkt)+        _ -> failure     _ -> failure   where-    isPKP [PublicKeyPkt _] = True+    isPKP [pkt] =+      case pktToPublicKeyPkt pkt of+        Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary+        Nothing -> False     isPKP _ = False  signature :: Bool -> [SigType] -> Parser [Pkt] [SignaturePayload]-signature intolerant rts =+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'@@ -171,13 +258,10 @@             [sp]         _ -> failure     brokensig' = const [] <$> broken 2-    isSP True [SignaturePkt sp@SigV3 {}] = isSP' sp-    isSP True [SignaturePkt sp@SigV4 {}] = isSP' sp+    isSP True [SignaturePkt sp] = isSP' sp     isSP False [SignaturePkt _] = True     isSP _ _ = False-    isSP' (SigV3 st _ _ _ _ _ _) = st `elem` rts-    isSP' (SigV4 st _ _ _ _ _ _) = st `elem` rts-    isSP' _ = False+    isSP' sigPayload = maybe False predicate (sigType sigPayload)  signedUID :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload]) signedUID intolerant = do@@ -186,14 +270,7 @@     [UserIdPkt u] -> do       sigs <-         concatMany-          (signature-             intolerant-             [ GenericCert-             , PersonaCert-             , CasualCert-             , PositiveCert-             , CertRevocationSig-             ])+          (signatureWithPredicate intolerant isAllowedUIDSigType)       return (I u, sigs)     _ -> failure   where@@ -207,14 +284,7 @@     [UserAttributePkt us] -> do       sigs <-         concatMany-          (signature-             intolerant-             [ GenericCert-             , PersonaCert-             , CasualCert-             , PositiveCert-             , CertRevocationSig-             ])+          (signatureWithPredicate intolerant isAllowedUIDSigType)       return (A us, sigs)     _ -> failure   where@@ -228,17 +298,20 @@     [p] -> do       sigs <-         concatMany-          (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])+          (signatureWithPredicate intolerant isAllowedSubkeySigType)       return [(p, sigs)]     _ -> failure   where-    isPSKP [PublicSubkeyPkt _] = True+    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 (signature False [SubkeyBindingSig, SubkeyRevocationSig])+  _ <- concatMany (signatureWithPredicate False isAllowedSubkeySigType)   return []  rawOrSignedOrRevokedSecSubkey ::@@ -249,27 +322,37 @@     [p] -> do       sigs <-         concatMany-          (signature intolerant [SubkeyBindingSig, SubkeyRevocationSig])+          (signatureWithPredicate intolerant isAllowedSubkeySigType)       return [(p, sigs)]     _ -> failure   where-    isSSKP [SecretSubkeyPkt _ _] = True+    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 (signature False [SubkeyBindingSig, SubkeyRevocationSig])+  _ <- concatMany (signatureWithPredicate False isAllowedSubkeySigType)   return [] -skPayload :: Parser [Pkt] (PKPayload, Maybe SKAddendum)+skPayload :: Parser [Pkt] (SomePKPayload, Maybe SKAddendum) skPayload = do   spkts <- satisfy isSKP   case spkts of-    [SecretKeyPkt p ska] -> return (p, Just ska)+    [pkt] ->+      case pktToSecretKeyPkt pkt of+        Just keyPkt | keyPktRole keyPkt == KeyPktPrimary ->+          return (keyPktTKKey keyPkt)+        _ -> failure     _ -> failure   where-    isSKP [SecretKeyPkt _ _] = True+    isSKP [pkt] =+      case pktToSecretKeyPkt pkt of+        Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary+        Nothing -> False     isSKP _ = False  broken :: Int -> Parser [Pkt] Pkt@@ -283,12 +366,316 @@     isBroken _ = False  -- | parse TKs from packets-parseTKs :: Bool -> [Pkt] -> [TK]-parseTKs intolerant ps =-  catMaybes-    (concatMap-       fst-       (completeResults-          (feedEof (feed (filter notTrustPacket ps) (many (anyTK intolerant))))))+parseUnknownTKs :: Bool -> [Pkt] -> [TKUnknown]+parseUnknownTKs intolerant ps =+  catMaybes $+  runIncrementalParser+    (anyTK intolerant)+    (map (: []) (filter notTrustPacket ps))   where     notTrustPacket = not . isTrustPkt++parseTKs :: Bool -> [Pkt] -> [SomeTK]+parseTKs intolerant =+  mapMaybe (either (const Nothing) Just . fromUnknownToTK) . parseUnknownTKs intolerant++parsePublicTKs :: Bool -> [Pkt] -> [TK 'PublicTK]+parsePublicTKs intolerant packets =+  mapMaybe+    (\case+       SomePublicTK tk -> Just tk+       SomeSecretTK _ -> Nothing)+    (parseTKs intolerant packets)++parseSecretTKs :: Bool -> [Pkt] -> [TK 'SecretTK]+parseSecretTKs intolerant packets =+  mapMaybe+    (\case+       SomeSecretTK tk -> Just tk+       SomePublicTK _ -> Nothing)+    (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
+ Codec/Encryption/OpenPGP/Message.hs view
@@ -0,0 +1,901 @@+-- 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
Codec/Encryption/OpenPGP/Ontology.hs view
@@ -1,9 +1,13 @@--- Ontology.hs: OpenPGP (RFC4880) "is" functions--- Copyright © 2012-2019  Clint Adams+-- 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@@ -25,30 +29,69 @@  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 (SigV4 CertRevocationSig _ _ _ _ _ _) = True-isCertRevocationSig _ = False+isCertRevocationSig = isSigTypeFor CertRevocationSig  isRevokerP :: SignaturePayload -> Bool-isRevokerP (SigV4 SignatureDirectlyOnAKey _ _ h u _ _) =-  any isRevocationKeySSP h && any isIssuerSSP u-isRevokerP _ = False+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 (SigV4 PrimaryKeyBindingSig _ _ _ _ _ _) = True-isPKBindingSig _ = False+isPKBindingSig = isSigTypeFor PrimaryKeyBindingSig  isSKBindingSig :: SignaturePayload -> Bool-isSKBindingSig (SigV4 SubkeyBindingSig _ _ _ _ _ _) = True-isSKBindingSig _ = False+isSKBindingSig = isSigTypeFor SubkeyBindingSig  isSubkeyRevocation :: SignaturePayload -> Bool-isSubkeyRevocation (SigV4 SubkeyRevocationSig _ _ _ _ _ _) = True-isSubkeyRevocation _ = False+isSubkeyRevocation = isSigTypeFor SubkeyRevocationSig  isSubkeyBindingSig :: SignaturePayload -> Bool-isSubkeyBindingSig (SigV4 SubkeyBindingSig _ _ _ _ _ _) = True-isSubkeyBindingSig _ = False+isSubkeyBindingSig = isSigTypeFor SubkeyBindingSig  isTrustPkt :: Pkt -> Bool isTrustPkt (TrustPkt _) = True
+ Codec/Encryption/OpenPGP/Policy.hs view
@@ -0,0 +1,493 @@+-- 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
Codec/Encryption/OpenPGP/S2K.hs view
@@ -1,47 +1,235 @@--- S2K.hs: OpenPGP (RFC4880) string-to-key conversion--- Copyright © 2013-2016  Clint Adams+-- 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-  ( string2Key+  ( EncodedSessionKeyError(..)+  , renderEncodedSessionKeyError+  , S2KError(..)+  , renderS2KError+  , decodeOpenPGPEncodedSessionKey+  , string2Key   , skesk2Key+  , skesk2SessionKey   ) where -import Codec.Encryption.OpenPGP.BlockCipher (keySize)+import Codec.Encryption.OpenPGP.BlockCipher (CipherError(..), keySize, withSymmetricCipher)+import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..)) import Codec.Encryption.OpenPGP.Types-import Control.Monad.Loops (untilM_)-import Control.Monad.Trans.State.Lazy (execState, get, put)-import qualified Crypto.Hash as CH-import qualified Data.ByteArray as BA+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) -string2Key :: S2K -> Int -> BL.ByteString -> B.ByteString-string2Key (Simple ha) ksz bs = B.take (fromIntegral ksz) $ hashpp ha ksz bs+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 (unSalt salt)) 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 (unSalt salt)) bs)-string2Key _ _ _ = error "FIXME: unimplemented S2K type"+     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 -> BL.ByteString -> B.ByteString-skesk2Key (SKESK 4 sa s2k Nothing) pass = string2Key s2k (keySize sa) pass-skesk2Key _ _ = error "FIXME"+skesk2Key :: SKESK 'SKESKV4 -> BL.ByteString -> Either S2KError B.ByteString+skesk2Key skesk pass = snd <$> skesk2SessionKey skesk pass -hashpp :: HashAlgorithm -> Int -> BL.ByteString -> B.ByteString+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 =-  snd (execState (hashround `untilM_` bigEnough) (0, B.empty))+  go 0 B.empty   where-    hashround =-      get >>= \(ctr, bs) ->-        put (ctr + 1, bs `B.append` hf ha (nulpad ctr `BL.append` pp))+    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-    bigEnough = get >>= \(_, bs) -> return (B.length bs >= keysize)-    hf :: HashAlgorithm -> BL.ByteString -> B.ByteString-    hf SHA1 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA1)-    hf SHA512 bs = BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA512)-    hf _ _ = error "FIXME: unimplemented S2K hash"+    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'))
Codec/Encryption/OpenPGP/SecretKey.hs view
@@ -1,113 +1,699 @@--- SecretKey.hs: OpenPGP (RFC4880) secret key encryption/decryption--- Copyright © 2013-2018  Clint Adams+-- 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+  , encryptPrivateKeyWithPolicyAndSaltAndIV   , encryptPrivateKey-  , encryptPrivateKeyIO-  , reencryptSecretKeyIO+  , changePrivateKeyPassphrase+  , changePrivateKeyPassphraseRandom+  , changeSecretKeyPassphrase+  , changeSecretKeyPassphraseRandom+  , reencryptSecretKeyRandomEither+  , reencryptPrivateKeyTyped   ) where -import Codec.Encryption.OpenPGP.BlockCipher (keySize, withSymmetricCipher)+import Codec.Encryption.OpenPGP.BlockCipher (renderCipherError, keySize) import Codec.Encryption.OpenPGP.CFB (decryptNoNonce, encryptNoNonce)-import Codec.Encryption.OpenPGP.Internal.HOBlockCipher-import Codec.Encryption.OpenPGP.S2K (skesk2Key, string2Key)-import Codec.Encryption.OpenPGP.Serialize (getSecretKey)+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.EntropyPool (createEntropyPool, getEntropyFrom)-import Data.Bifunctor (bimap)+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 (runPut)+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) -saBlockSize :: SymmetricAlgorithm -> Int-saBlockSize sa =-  either (const 0) id (withSymmetricCipher sa B.empty (Right . blockSize))+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 -decryptPrivateKey :: (PKPayload, SKAddendum) -> BL.ByteString -> SKAddendum-decryptPrivateKey (pkp, ska@SUS16bit {}) pp =-  either (error "could not decrypt SUS16bit") id (decryptSKA (pkp, ska) pp)-decryptPrivateKey (pkp, ska@SUSSHA1 {}) pp =-  either (error "could not decrypt SUSSHA1") id (decryptSKA (pkp, ska) pp)-decryptPrivateKey (_, SUSym {}) _ = error "SUSym key decryption not implemented"-decryptPrivateKey (_, ska@SUUnencrypted {}) _ = ska+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 -decryptSKA ::-     (PKPayload, SKAddendum) -> BL.ByteString -> Either String SKAddendum-decryptSKA (pkp, SUS16bit sa s2k iv payload) pp = do-  let key = skesk2Key (SKESK 4 sa s2k Nothing) pp-  p <- decryptNoNonce sa iv (BL.toStrict payload) key-  (s, cksum) <- getSecretKeyAndChecksum p -- FIXME: check the 16bit hash-  let checksum = cksum-  return $ SUUnencrypted s checksum -- FIXME: is this the correct checksum?-  where-    getSecretKeyAndChecksum p =-      bimap-        (\(_, _, x) -> x)-        (\(_, _, x) -> x)-        (runGetOrFail-           (getSecretKey pkp >>= \sk ->-              getWord16be >>= \csum -> return (sk, csum))-           (BL.fromStrict p)) -- FIXME: check the 16bit hash-decryptSKA (pkp, SUSSHA1 sa s2k iv payload) pp = do-  let key = skesk2Key (SKESK 4 sa s2k Nothing) pp-  p <- decryptNoNonce sa iv (BL.toStrict payload) key-  (s, cksum) <- getSecretKeyAndChecksum p -- FIXME: check the SHA1 hash-  let checksum =-        sum . map fromIntegral . B.unpack . B.take (B.length p - 20) $ p-  return $ SUUnencrypted s checksum -- FIXME: is this the correct checksum?-  where-    getSecretKeyAndChecksum p =-      bimap-        (\(_, _, x) -> x)-        (\(_, _, x) -> x)-        (runGetOrFail-           (getSecretKey pkp >>= \sk ->-              getRemainingLazyByteString >>= \csum -> return (sk, csum))-           (BL.fromStrict p))-decryptSKA _ _ = Left "Unexpected codepath"+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 ++ ")") --- |generates pseudo-random salt and IV-encryptPrivateKeyIO :: SKAddendum -> BL.ByteString -> IO SKAddendum-encryptPrivateKeyIO ska pp =-  saltiv >>= \(s, i) -> return (encryptPrivateKey s (IV i) ska pp)-  where-    saltiv = do-      ep <- createEntropyPool-      bb <- getEntropyFrom ep (8 + saBlockSize AES256)-      return $ B.splitAt 8 bb+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" --- |8-octet salt, IV must be length of cipher blocksize+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 ::-     B.ByteString -> IV -> SKAddendum -> BL.ByteString -> SKAddendum-encryptPrivateKey _ _ ska@SUS16bit {} _ = ska-encryptPrivateKey _ _ ska@SUSSHA1 {} _ = ska-encryptPrivateKey _ _ ska@SUSym {} _ = ska-encryptPrivateKey salt iv (SUUnencrypted skey _) pp =-  SUSSHA1 AES256 s2k iv (BL.fromStrict (encryptSKey skey s2k iv pp))-  where-    s2k = IteratedSalted SHA512 (Salt salt) 12058624+     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 -encryptSKey :: SKey -> S2K -> IV -> BL.ByteString -> B.ByteString-encryptSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) s2k iv pp =-  either error id (encryptNoNonce AES256 s2k iv (BL.toStrict payload) key)+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-    key = string2Key s2k (keySize AES256) pp-    algospecific =-      runPut $ put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)-    cksum = CH.hashlazy algospecific :: CH.Digest CH.SHA1-    payload = algospecific `BL.append` BL.fromStrict (BA.convert cksum)-    Just u = inverse p q-encryptSKey _ _ _ _ = error "Non-RSA keytypes not handled yet" -- FIXME: do DSA and ElGamal+    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 -reencryptSecretKeyIO :: SecretKey -> BL.ByteString -> IO SecretKey-reencryptSecretKeyIO sk pp =-  encryptPrivateKeyIO (_secretKeySKAddendum sk) pp >>= \n ->-    return sk {_secretKeySKAddendum = n}+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
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -1,1495 +1,2989 @@--- Serialize.hs: OpenPGP (RFC4880) serialization (using cereal)--- Copyright © 2012-2025  Clint Adams--- This software is released under the terms of the Expat license.--- (See the LICENSE file).-module Codec.Encryption.OpenPGP.Serialize-  (-  -- * Serialization functions-    putSKAddendum-  , getSecretKey-  -- * Utilities-  , parsePkts-  ) where--import Control.Applicative (many, some)-import Control.Lens ((^.), _1)-import Control.Monad (guard, replicateM, replicateM_)-import Crypto.Number.Basic (numBits)-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-  , getByteString-  , getLazyByteString-  , getRemainingLazyByteString-  , getWord16be-  , getWord16le-  , getWord32be-  , getWord8-  , 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.Foldable as F-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-  , multiplicativeInverse-  , pubkeyToMPIs-  )-import Codec.Encryption.OpenPGP.Types--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 where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary Signature where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary SKESK where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary OnePassSignature where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary SecretKey where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary PublicKey where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary SecretSubkey where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary CompressedData where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary SymEncData where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary Marker where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary LiteralData where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary Trust where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary UserId where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary PublicSubkey where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary UserAttribute where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary SymEncIntegrityProtectedData where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary ModificationDetectionCode where-  get = fmap fromPkt getPkt-  put = putPkt . toPkt--instance Binary OtherPacket where-  get = fmap fromPkt getPkt-  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 PKPayload where-  get = getPKPayload-  put = putPKPayload--instance Binary SignaturePayload where-  get = getSignaturePayload-  put = putSignaturePayload--instance Binary TK where-  get = undefined-  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 20-        return $-          SigSubPacket-            crit-            (RevocationKey-               (bsToFFSet . BL.singleton $ rclass .&. 0x7f)-               algid-               (TwentyOctetFingerprint 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-        kv <- getWord8-        fp <--          getLazyByteString-            (if kv == 4-               then 20-               else 32)-        return $-          SigSubPacket crit (IssuerFingerprint kv (TwentyOctetFingerprint 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-  putSubPacketLength 23-  putSigSubPacketType crit 12-  putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $-    Set.insert (RClOther 0) rclass-  put algid-  putLazyByteString (unTOF fp) -- 20 octets-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 fpb = unTOF fp-  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-      | Set.null ks = [] -- FIXME: should this be [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)-  | B.length (unSalt salt) == 8 =-    BL.pack [1, fromIntegral . fromFVal $ hashalgo] `BL.append`-    (BL.fromStrict . unSalt) salt-  | otherwise = error "Confusing salt size"-fromS2K (IteratedSalted hashalgo salt count)-  | B.length (unSalt salt) == 8 =-    BL.pack [3, fromIntegral . fromFVal $ hashalgo] `BL.append`-    (BL.fromStrict . unSalt) salt `BL.snoc`-    encodeIterationCount count-  | otherwise = error "Confusing salt size"-fromS2K (OtherS2K _ bs) = bs--getPacketLength :: Get Integer-getPacketLength = do-  firstOctet <- getWord8-  getPacketLength' firstOctet-  where-    getPacketLength' :: Integral a => Word8 -> Get a-    getPacketLength' 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 support missing." --FIXME--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 "partial body length support needed" -- FIXME--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) (Salt salt)-      | t == 3 = do-        ha <- getWord8-        salt <- getByteString 8-        count <- getWord8-        return $-          IteratedSalted (toFVal ha) (Salt salt) (decodeIterationCount count)-      | 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 (unSalt salt)-  putWord8 $ encodeIterationCount count-putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs--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-      len <- fmap fromIntegral getPacketLength-      bs <- getLazyByteString len-      return (tag .&. 0x3f, bs)-    _ -> error "This should never happen (getPacketTypeAndPayload/???)."--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-    getPkt' :: Word8 -> ByteOffset -> Get Pkt-    getPkt' t len-      | t == 1 = do-        pv <- getWord8-        eokeyid <- getLazyByteString 8-        pka <- getWord8-        mpib <- getRemainingLazyByteString-        case runGetOrFail (some getMPI) mpib of-          Left (_, _, e) -> fail ("PKESK MPIs " ++ e)-          Right (_, _, sk) ->-            return $-            PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pka) (NE.fromList sk)-      | 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-        symalgo <- getWord8-        s2k <- getS2K-        esk <- getRemainingLazyByteString-        return $-          SKESKPkt-            pv-            (toFVal symalgo)-            s2k-            (if BL.null esk-               then Nothing-               else Just esk)-      | t == 4 = do-        pv <- getWord8-        sigtype <- getWord8-        ha <- getWord8-        pka <- getWord8-        skeyid <- getLazyByteString 8-        nested <- getWord8-        return $-          OnePassSignaturePkt-            pv-            (toFVal sigtype)-            (toFVal ha)-            (toFVal pka)-            (EightOctetKeyId skeyid)-            (nested == 0)-      | 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 (_, _, key) -> return key-      | 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 (_, _, key) -> return key-      | 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 (_, _, key) -> return key-      | 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 -- should be 1-        b <- getLazyByteString (len - 1)-        return $ SymEncIntegrityProtectedDataPkt pv b-      | 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--putPkt :: Pkt -> Put-putPkt (PKESKPkt pv eokeyid pka mpis) = do-  putWord8 (0xc0 .|. 1)-  let bsk = runPut $ F.mapM_ put 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 (SignaturePkt sp) = do-  putWord8 (0xc0 .|. 2)-  let bs = runPut $ put sp-  putLengthThenPayload bs-putPkt (SKESKPkt pv 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 pv -- should be 4-  putWord8 $ fromIntegral . fromFVal $ symalgo-  putLazyByteString bs2k-  putLazyByteString bsk-putPkt (OnePassSignaturePkt 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 -- FIXME: what do other values mean?-  putLengthThenPayload bs-putPkt (SecretKeyPkt pkp ska) = do-  putWord8 (0xc0 .|. 5)-  let bs = runPut (putPKPayload pkp >> putSKAddendum 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 >> putSKAddendum 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 pv b) = do-  putWord8 (0xc0 .|. 18)-  putPacketLength . fromIntegral $ BL.length b + 1-  putWord8 pv -- should be 1-  putLazyByteString b-putPkt (ModificationDetectionCodePkt hash) = do-  putWord8 (0xc0 .|. 19)-  putLengthThenPayload hash-putPkt (OtherPacketPkt t payload) = do-  putWord8 (0xc0 .|. t) -- FIXME: restrict t-  putLengthThenPayload payload-putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload)--putLengthThenPayload :: ByteString -> Put-putLengthThenPayload bs = do-  putPacketLength . fromIntegral $ BL.length bs-  putLazyByteString bs--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 -- FIXME: test for 0 or 0xFF as they are reserved-  curveoid <- getByteString (fromIntegral curvelength)-  MPI mpi <- getMPI -- FIXME: check length against curve type?-  case curveoidBSToCurve curveoid of-    Left e -> fail e-    Right Curve25519 -> return $ EdDSAPubKey Ed25519 (EPoint 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 -- FIXME: should be 3, test for 0 or 0xFF as they are reserved-  one <- getWord8 -- FIXME: should be 1-  kdfHA <- get-  kdfSA <- get-  return $ ECDHPubKey ed kdfHA kdfSA-getPubkey EdDSA = do-  curvelength <- getWord8 -- FIXME: test for 0 or 0xFF as they are reserved-  curveoid <- getByteString (fromIntegral curvelength)-  MPI mpi <- getMPI -- FIXME: check length against curve type?-  case curveoidBSToEdSigningCurve curveoid of-    Left e -> fail e-    Right Ed25519 -> return . EdDSAPubKey Ed25519 $ EPoint mpi-getPubkey _ = UnknownPKey <$> getRemainingLazyByteString--bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint-bs2Point bs =-  let xy = B.drop 1 bs-   in let l = B.length xy-       in if B.head bs == 0x04-            then return-                   (uncurry-                      ECCT.Point-                      (bimap os2ip os2ip (B.splitAt (div l 2) xy)))-            else Left $ "unknown type of point: " ++ show (B.unpack bs)--putPubkey :: PKey -> Put-putPubkey (UnknownPKey bs) = putLazyByteString bs-putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) =-  let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)-   in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>-      mapM_ put (pubkeyToMPIs p) -- FIXME: do not output length 0 or 0xff-putPubkey p@(ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) kha ksa) =-  let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)-   in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>-      mapM_ put (pubkeyToMPIs p) >>-      putWord8 0x03 >>-      putWord8 0x01 >>-      put kha >>-      put ksa -- FIXME: do not output length 0 or 0xff-putPubkey p@(ECDHPubKey (EdDSAPubKey curve _) kha ksa) =-  let Right curveoidbs = curveToCurveoidBS (ed2ec curve)-   in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>-      mapM_ put (pubkeyToMPIs p) >>-      putWord8 0x03 >>-      putWord8 0x01 >>-      put kha >>-      put ksa -- FIXME: do not output length 0 or 0xff-  where-    ed2ec Ed25519 = Curve25519-putPubkey p@(EdDSAPubKey curve _) =-  let Right curveoidbs = edSigningCurveToCurveoidBS curve-   in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>-      mapM_ put (pubkeyToMPIs p) -- FIXME: do not output length 0 or 0xff-putPubkey p = mapM_ put (pubkeyToMPIs p)--getSecretKey :: PKPayload -> Get SKey-getSecretKey pkp-  | _pkalgo pkp `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do-    MPI d <- get-    MPI p <- get-    MPI q <- get-    MPI _ <- get -- u-    let dP = 0-        dQ = 0-        qinv = 0-        pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (pkp ^. pubkey)-    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-    MPI pn <- get-    let pubcurve =-          (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)-            (pkp ^. pubkey)-    return $ ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey pubcurve pn))-  | _pkalgo pkp == ECDH -- FIXME: deduplicate this and above-   = do-    MPI pn <- get-    let pubcurve =-          (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)-            (pkp ^. pubkey)-    return $ ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey pubcurve pn))--putSKey :: SKey -> Put-putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) =-  put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)-  where-    u = multiplicativeInverse q p--putMPI :: MPI -> Put-putMPI (MPI i) = do-  let bs = i2osp i-  putWord16be . fromIntegral . numBits $ i-  putByteString bs--getPKPayload :: Get PKPayload-getPKPayload = do-  version <- getWord8-  ctime <- fmap ThirtyTwoBitTimeStamp getWord32be-  if version `elem` [2, 3]-    then do-      v3e <- getWord16be-      pka <- get-      pk <- getPubkey pka-      return $! PKPayload DeprecatedV3 ctime v3e pka pk-    else do-      pka <- get-      pk <- getPubkey pka-      return $! PKPayload V4 ctime 0 pka pk--putPKPayload :: PKPayload -> Put-putPKPayload (PKPayload DeprecatedV3 ctime v3e pka pk) = do-  putWord8 3-  putWord32be . unThirtyTwoBitTimeStamp $ ctime-  putWord16be v3e-  put pka-  putPubkey pk-putPKPayload (PKPayload V4 ctime _ pka pk) = do-  putWord8 4-  putWord32be . unThirtyTwoBitTimeStamp $ ctime-  put pka-  putPubkey pk--getSKAddendum :: PKPayload -> Get SKAddendum-getSKAddendum pkp = do-  s2kusage <- getWord8-  case s2kusage of-    0 -> do-      sk <- getSecretKey pkp-      checksum <- getWord16be -- FIXME: validate checksum?-      return $ SUUnencrypted sk checksum-    255 -> do-      symenc <- getWord8-      s2k <- getS2K-      case s2k -- FIXME: this is a mess-            of-        OtherS2K _ _ -> return $ SUS16bit (toFVal symenc) s2k mempty BL.empty-        _ -> do-          iv <- getByteString (symEncBlockSize . toFVal $ symenc)-          encryptedblock <- getRemainingLazyByteString-          return $ SUS16bit (toFVal symenc) s2k (IV iv) encryptedblock-    254 -> do-      symenc <- getWord8-      s2k <- getS2K-      case s2k -- FIXME: this is a mess-            of-        OtherS2K _ _ -> return $ SUSSHA1 (toFVal symenc) s2k mempty BL.empty-        _ -> do-          iv <- getByteString (symEncBlockSize . toFVal $ symenc)-          encryptedblock <- getRemainingLazyByteString-          return $ SUSSHA1 (toFVal symenc) s2k (IV iv) encryptedblock-    symenc -> do-      iv <- getByteString (symEncBlockSize . toFVal $ symenc)-      encryptedblock <- getRemainingLazyByteString-      return $ SUSym (toFVal symenc) (IV iv) encryptedblock--putSKAddendum :: SKAddendum -> Put-putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = do-  putWord8 254-  put symenc-  put s2k-  putByteString (unIV iv)-  putLazyByteString encryptedblock-putSKAddendum (SUUnencrypted sk checksum) = do-  putWord8 0-  let skb = runPut (putSKey sk)-  putLazyByteString skb-  putWord16be-    (if checksum == 0-       then BL.foldl (\a b -> mod (a + fromIntegral b) 0xffff) (0 :: Word16) skb-       else checksum) -- FIXME: be saner-putSKAddendum _ = error "Type not supported"--symEncBlockSize :: SymmetricAlgorithm -> Int-symEncBlockSize Plaintext = 0-symEncBlockSize IDEA = 8-symEncBlockSize TripleDES = 8-symEncBlockSize CAST5 = 8-symEncBlockSize Blowfish = 8-symEncBlockSize AES128 = 16-symEncBlockSize AES192 = 16-symEncBlockSize AES256 = 16-symEncBlockSize Twofish = 16-symEncBlockSize Camellia128 = 16-symEncBlockSize _ = 8 -- FIXME--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-      pka <- get-      ha <- get-      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-      case runGetOrFail (some getMPI) mpib of-        Left (_, _, e) -> fail ("v4 sig MPIs " ++ e)-        Right (_, _, mpis) ->-          return $-          SigV4-            (toFVal st)-            (toFVal pka)-            (toFVal ha)-            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-  F.mapM_ put mpis-putSignaturePayload (SigVOther pv bs) = do-  putWord8 pv-  putLazyByteString bs--putTK :: TK -> Put-putTK key = do-  let pkp = key ^. tkKey . _1-  maybe-    (put (PublicKey pkp))-    (\ska -> put (SecretKey pkp ska))-    (snd (key ^. tkKey))-  mapM_ (put . Signature) (_tkRevs key)-  mapM_ putUid' (_tkUIDs key)-  mapM_ putUat' (_tkUAts key)-  mapM_ putSub' (_tkSubs key)-  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 lbs =-  case runGetOrFail (some getPkt) lbs of-    Left (_, _, e) -> []-    Right (_, _, p) -> p+-- 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+  , 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(..))+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+          }++armorPayload :: Armor -> ByteString+armorPayload (Armor _ _ bs) = BL.fromStrict (BLC8.toStrict bs)+armorPayload (ClearSigned _ _ inner) = armorPayload inner++dearmorIfAsciiArmored :: ByteString -> Either String (Bool, ByteString)+dearmorIfAsciiArmored bs+  | BLC8.isPrefixOf (BLC8.pack "-----BEGIN PGP ") (BLC8.dropWhile (`elem` (" \t\r\n" :: String)) bs) =+      case AA.decodeLazy bs of+        Left err -> Left err+        Right [] -> Left "ASCII armor decode succeeded but returned no blocks"+        Right (a:_) -> Right (True, armorPayload a)+  | otherwise = Right (False, bs)++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)+      WireRepInput+        { wireRepInputRef = src+        , wireRepInputPayload = payload+        } =+        either+          (const+             WireRepInput+               { wireRepInputRef = BTypes.mkWireRepRef mname False input+               , wireRepInputPayload = input+               })+          id+          (wireRepRefFromInput mname input)+   in 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+  where+    armorHeader = BLC8.toStrict (BLC8.pack "-----BEGIN PGP ")+    isLeadingArmorWhitespace w = w `elem` map (fromIntegral . fromEnum) (" \t\r\n" :: String)++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)
Codec/Encryption/OpenPGP/SerializeForSigs.hs view
@@ -1,7 +1,11 @@--- SerializeForSigs.hs: OpenPGP (RFC4880) special serialization for signature purposes--- Copyright © 2012-2020  Clint Adams+-- 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@@ -12,6 +16,7 @@   , putKeyforSigning   , putSigforSigning   , payloadForSig+  , payloadForSigWith   ) where  import Control.Lens ((^.))@@ -30,11 +35,69 @@ 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)@@ -43,6 +106,11 @@   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)" @@ -52,24 +120,16 @@    in putByteString bs  putPartialSigforSigning :: Pkt -> Put-putPartialSigforSigning (SignaturePkt (SigV4 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-putPartialSigforSigning _ =-  error "This should never happen (putPartialSigforSigning)"+putPartialSigforSigning pkt =+  case fromPktSignatureSerializationCase pkt of+    Just signatureCase -> putPartialSigforSigningCase signatureCase+    Nothing -> error ("putPartialSigforSigning: unsupported signature packet version: " ++ show (pktTag pkt))  putSigTrailer :: Pkt -> Put-putSigTrailer (SignaturePkt (SigV4 _ _ _ hs _ _ _)) = do-  putWord8 0x04-  putWord8 0xff-  putWord32be . fromIntegral . (+ 6) . BL.length $ runPut $ mapM_ put hs-            -- this +6 seems like a bug in RFC4880-putSigTrailer _ = error "This should never happen (putSigTrailer)"+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@@ -93,12 +153,10 @@ putUAtforSigning _ = error "This should never happen (putUAtforSigning)"  putSigforSigning :: Pkt -> Put-putSigforSigning (SignaturePkt (SigV4 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-putSigforSigning _ = error "Non-V4 not implemented."+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@@ -110,7 +168,12 @@     ("This should never happen (putKeyforSigning) " ++      show (pktTag x) ++ "/" ++ show x) -putKeyForSigning' :: PKPayload -> Put+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@@ -118,8 +181,12 @@   putLazyByteString bs  payloadForSig :: SigType -> PktStreamContext -> ByteString-payloadForSig BinarySig state = fromPkt (lastLD state) ^. literalDataPayload-payloadForSig CanonicalTextSig state = payloadForSig BinarySig state+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)@@ -127,7 +194,7 @@ payloadForSig CasualCert state = payloadForSig GenericCert state payloadForSig PositiveCert state = payloadForSig GenericCert state payloadForSig SubkeyBindingSig state =-  kandKPayload (lastPrimaryKey state) (lastSubkey state) -- FIXME: embedded primary key binding sig should be verified as well+  kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig PrimaryKeyBindingSig state =   kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig SignatureDirectlyOnAKey state =@@ -137,8 +204,47 @@ payloadForSig SubkeyRevocationSig state =   kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig CertRevocationSig state =-  kandUPayload (lastPrimaryKey state) (lastUIDorUAt state) -- FIXME: this doesn't handle revocation of direct key signatures-payloadForSig st _ = error ("I dunno how to " ++ show st)+  -- 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])
Codec/Encryption/OpenPGP/SignatureQualities.hs view
@@ -1,12 +1,18 @@--- SignatureQualities.hs: OpenPGP (RFC4880) signature qualities--- Copyright © 2012-2019  Clint Adams+-- 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)@@ -14,25 +20,70 @@ 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 (SigV3 st _ _ _ _ _ _) = Just st-sigType (SigV4 st _ _ _ _ _ _) = Just st-sigType _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild+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 (SigV3 _ _ _ pka _ _ _) = Just pka-sigPKA (SigV4 _ pka _ _ _ _ _) = Just pka-sigPKA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild+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 (SigV3 _ _ _ _ ha _ _) = Just ha-sigHA (SigV4 _ _ ha _ _ _ _) = Just ha-sigHA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild+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 (SigV3 _ ct _ _ _ _ _) = Just ct-sigCT (SigV4 _ _ _ hsubs _ _ _) =-  fmap-    (\(SigSubPacket _ (SigCreationTime i)) -> i)-    (find isSigCreationTime hsubs)-sigCT _ = Nothing+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
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -1,486 +1,1755 @@--- Signatures.hs: OpenPGP (RFC4880) signature verification--- Copyright © 2012-2020  Clint Adams--- This software is released under the terms of the Expat license.--- (See the LICENSE file).-module Codec.Encryption.OpenPGP.Signatures-  ( verifySigWith-  , verifyAgainstKeyring-  , verifyAgainstKeys-  , verifyTKWith-  , signUserIDwithRSA-  , crossSignSubkeyWithRSA-  , signDataWithRSA-  ) where--import Control.Applicative ((<|>))-import Control.Error.Util (hush)-import Control.Lens ((^.), _1)-import Control.Monad (liftM2)--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.RSA.PKCS15 as P15-import qualified Crypto.PubKey.RSA.Types as RSATypes--import Data.Bifunctor (first)-import Data.Binary.Put (runPut)-import qualified Data.ByteArray as BA-import qualified Data.ByteString as B-import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as BL-import Data.Either (isRight, lefts, rights)-import Data.Function (on)-import Data.IxSet.Typed ((@=))-import qualified Data.IxSet.Typed as IxSet-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NE-import Data.Text (Text)-import Data.Time.Clock (UTCTime(..), diffUTCTime)-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)--import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)-import Codec.Encryption.OpenPGP.Internal-  ( PktStreamContext(..)-  , emptyPSC-  , issuer-  , issuerFP-  )-import Codec.Encryption.OpenPGP.Ontology-  ( isRevocationKeySSP-  , isRevokerP-  , isSubkeyBindingSig-  , isSubkeyRevocation-  )--import Codec.Encryption.OpenPGP.SerializeForSigs-  ( payloadForSig-  , putKeyforSigning-  , putPartialSigforSigning-  , putSigTrailer-  , putUforSigning-  )-import Codec.Encryption.OpenPGP.Types-import Data.Conduit.OpenPGP.Keyring.Instances ()--verifySigWith ::-     (Pkt -> Maybe UTCTime -> ByteString -> Either String Verification)-  -> Pkt-  -> PktStreamContext-  -> Maybe UTCTime-  -> Either String Verification -- FIXME: check expiration here?-verifySigWith vf sig@(SignaturePkt (SigV4 st _ _ hs _ _ _)) state mt = do-  v <- vf sig mt (payloadForSig st state)-  mapM_ (checkI (v ^. verificationSigner) . _sspPayload) hs-  return v-  where-    checkI s i@Issuer {} = checkIssuer (eightOctetKeyID s) i-    checkI s i@IssuerFingerprint {} = checkIssuerFP (fingerprint s) i-    checkI _ _ = Right True-    checkIssuer ::-         Either String EightOctetKeyId-      -> SigSubPacketPayload-      -> Either String Bool-    checkIssuer (Right signer) (Issuer i) =-      if signer == i-        then Right True-        else Left "issuer subpacket does not match"-    checkIssuer (Left err) (Issuer _) =-      Left $ "issuer subpacket cannot be checked (" ++ err ++ ")"-    checkIssuer _ _ = Right True-    checkIssuerFP ::-         TwentyOctetFingerprint -> SigSubPacketPayload -> Either String Bool-    checkIssuerFP signer (IssuerFingerprint _ i) =-      if signer == i-        then Right True-        else Left "issuer fingerprint subpacket does not match"-    checkIssuerFP _ _ = Right True-verifySigWith _ _ _ _ = Left "This should never happen (verifySigWith)."--verifyTKWith ::-     (Pkt -> PktStreamContext -> Maybe UTCTime -> Either String Verification)-  -> Maybe UTCTime-  -> TK-  -> Either String TK-verifyTKWith vsf mt key = do-  revokers <- checkRevokers key-  revs <- checkKeyRevocations revokers key-  let uids = filter (not . null . snd) . checkUidSigs $ key ^. tkUIDs -- FIXME: check revocations here?-  let uats = filter (not . null . snd) . checkUAtSigs $ key ^. tkUAts -- FIXME: check revocations here?-  let subs = concatMap checkSub $ key ^. tkSubs -- FIXME: check revocations here?-  return (TK (key ^. tkKey) revs uids uats subs)-  where-    checkRevokers =-      Right . concat . rights . map verifyRevoker . filter isRevokerP . _tkRevs-    checkKeyRevocations ::-         [(PubKeyAlgorithm, TwentyOctetFingerprint)]-      -> TK-      -> Either String [SignaturePayload]-    checkKeyRevocations rs k =-      Prelude.sequence . concatMap (filterRevs rs) . rights .-      map (liftM2 fmap (,) vSig) $-      k ^.-      tkRevs-    checkUidSigs :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])]-    checkUidSigs =-      map-        (\(uid, sps) ->-           (uid, (rights . map (\sp -> fmap (const sp) (vUid (uid, sp)))) sps))-    checkUAtSigs ::-         [([UserAttrSubPacket], [SignaturePayload])]-      -> [([UserAttrSubPacket], [SignaturePayload])]-    checkUAtSigs =-      map-        (\(uat, sps) ->-           (uat, (rights . map (\sp -> fmap (const sp) (vUAt (uat, sp)))) sps))-    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 isSubkeyRevocation sigs)-    checkSub' :: Pkt -> [SignaturePayload] -> [(Pkt, [SignaturePayload])]-    checkSub' p sps =-      let goodsigs = filter (vSubSig p) (filter isSubkeyBindingSig sps)-       in if null goodsigs-            then []-            else [(p, goodsigs)]-    getHasheds (SigV4 _ _ _ ha _ _ _) = ha-    getHasheds _ = []-    filterRevs ::-         [(PubKeyAlgorithm, TwentyOctetFingerprint)]-      -> (SignaturePayload, Verification)-      -> [Either String SignaturePayload]-    filterRevs vokers spv =-      case spv of-        (s@(SigV4 SignatureDirectlyOnAKey _ _ _ _ _ _), _) -> [Right s]-        (s@(SigV4 KeyRevocationSig pka _ _ _ _ _), v) ->-          if (v ^. verificationSigner == key ^. tkKey . _1) ||-             any-               (\(p, f) ->-                  p == pka && f == fingerprint (v ^. verificationSigner))-               vokers-            then [Left "Key revoked"]-            else [Right s]-        _ -> []-    vUid :: (Text, SignaturePayload) -> Either String Verification-    vUid (uid, sp) =-      vsf-        (SignaturePkt sp)-        emptyPSC-          { lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1)-          , lastUIDorUAt = UserIdPkt uid-          }-        mt-    vUAt ::-         ([UserAttrSubPacket], SignaturePayload) -> Either String Verification-    vUAt (uat, sp) =-      vsf-        (SignaturePkt sp)-        emptyPSC-          { lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1)-          , lastUIDorUAt = UserAttributePkt uat-          }-        mt-    vSig :: SignaturePayload -> Either String Verification-    vSig sp =-      vsf-        (SignaturePkt sp)-        emptyPSC {lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1)}-        mt-    vSubSig :: Pkt -> SignaturePayload -> Bool-    vSubSig sk sp =-      isRight-        (vsf-           (SignaturePkt sp)-           emptyPSC-             { lastPrimaryKey = PublicKeyPkt (key ^. tkKey . _1)-             , lastSubkey = sk-             }-           mt)-    verifyRevoker ::-         SignaturePayload-      -> Either String [(PubKeyAlgorithm, TwentyOctetFingerprint)]-    verifyRevoker sp = do-      _ <- vSig sp-      return-        (map (\(SigSubPacket _ (RevocationKey _ pka fp)) -> (pka, fp)) .-         filter isRevocationKeySSP $-         getHasheds sp)--verifyAgainstKeyring ::-     Keyring -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification-verifyAgainstKeyring kr sig mt payload = do-  let ikeys = (kr @=) <$> issuer sig-      ifpkeys = (kr @=) <$> issuerFP sig-  keyset <- maybe (Left "issuer not found") Right (ifpkeys <|> ikeys)-  potentialmatches <--    if IxSet.null keyset-      then Left "pubkey not found"-      else Right keyset-  verifyAgainstKeys (IxSet.toList potentialmatches) sig mt payload--verifyAgainstKeys ::-     [TK] -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification-verifyAgainstKeys ks sig mt payload = do-  let allrelevantpkps =-        filter-          (\x ->-             (((fingerprint x ==) <$> issuerFP sig) == Just True) ||-             ((==) <$> issuer sig <*> hush (eightOctetKeyID x)) ==-             Just True)-          (concatMap (\x -> (x ^. tkKey . _1) : map subPKP (_tkSubs x)) ks)-  let results =-        map-          (\pkp ->-             verifyAgainstKey'-               pkp-               sig-               mt-               payload)-          allrelevantpkps-  case rights results of-    [] -> Left (concatMap (++ "/") (lefts results))-    [r] -> do-      _ <- isSignatureExpired sig mt-      return r-    _ -> Left "multiple successes; unexpected condition"-  where-    subPKP (pack, _) = subPKP' pack-    subPKP' (PublicSubkeyPkt p) = p-    subPKP' (SecretSubkeyPkt p _) = p-    subPKP' _ = error "This should never happen (subPKP')"--verifyAgainstKey' ::-     PKPayload -> Pkt -> Maybe UTCTime -> ByteString -> Either String Verification-verifyAgainstKey' pkp sig mt payload = do---  FIXME: check flags---  FIXME: check expiration time-      r <- verify'-               sig-               pkp-               (hashalgo sig)-               (BL.toStrict (finalPayload sig payload))---  FIXME: check signature hash against policy---  FIXME: check pka against policy-      return (Verification r ((_signaturePayload . fromPkt) sig))-  where-    verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA1 pl =-      verify'' (pkaAndMPIs s) CHA.SHA1 pub pkey pl-    verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) RIPEMD160 pl =-      verify'' (pkaAndMPIs s) CHA.RIPEMD160 pub pkey pl-    verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA256 pl =-      verify'' (pkaAndMPIs s) CHA.SHA256 pub pkey pl-    verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA384 pl =-      verify'' (pkaAndMPIs s) CHA.SHA384 pub pkey pl-    verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA512 pl =-      verify'' (pkaAndMPIs s) CHA.SHA512 pub pkey pl-    verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) SHA224 pl =-      verify'' (pkaAndMPIs s) CHA.SHA224 pub pkey pl-    verify' (SignaturePkt s) pub@(PKPayload V4 _ _ _ pkey) DeprecatedMD5 pl =-      verify'' (pkaAndMPIs s) CHA.MD5 pub pkey pl-    verify' _ _ _ _ = error "This should never happen (verify')."-    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'' (EdDSA, mpis) hd pub (EdDSAPubKey Ed25519 pkey) bs =-      ed25519Verify pub mpis hd (i2osp (unEPoint pkey)) bs-    verify'' (RSA, mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs =-      rsaVerify pub mpis hd pkey bs-    verify'' _ _ _ _ _ = Left "unimplemented key type"-    dsaVerify pub (r :| [s]) hd pkey bs =-      if DSA.verify hd pkey (dsaMPIsToSig r s) bs-        then Right pub-        else Left ("DSA verification failed: " ++ show (hd, pkey, r, s, bs))-    dsaVerify _ _ _ _ _ = Left "cannot verify DSA signature of wrong shape"-    ecdsaVerify pub (r :| [s]) hd pkey bs =-      if ECDSA.verify hd pkey (ecdsaMPIsToSig r s) bs-        then Right pub-        else Left ("ECDSA verification failed: " ++ show (hd, pkey, r, s, bs))-    ecdsaVerify _ _ _ _ _ = Left "cannot verify ECDSA signature of wrong shape"-    ed25519Verify pub (r :| [s]) hd pkey bs =-      either-        (Left .-         (("Ed25519 verification failed: " ++ show (hd, pkey, r, s, bs) ++ ": ") ++) .-         show)-        return $ do-        ep <- cf2es (Ed25519.publicKey (B.drop 1 pkey)) -- drop the 0x40-        es <- cf2es (Ed25519.signature ((B.append `on` i2osp . unMPI) r s))-        let prehash = crazyHash hd bs :: B.ByteString-        if Ed25519.verify ep prehash es-          then Right pub-          else Left "does not verify"-    ed25519Verify _ _ _ _ _ =-      Left "cannot verify Ed25519 signature of wrong shape"-    cf2es = either (Left . show) return . eitherCryptoError-    rsaVerify pub mpis hd pkey bs =-      if P15.verify (Just hd) pkey bs (rsaMPItoSig mpis)-        then Right pub-        else Left ("DSA verification failed: " ++ show (hd, pkey, mpis, bs))-    dsaMPIsToSig r s = DSA.Signature (unMPI r) (unMPI s)-    ecdsaMPIsToSig r s = ECDSA.Signature (unMPI r) (unMPI s)-    rsaMPItoSig (s :| []) = i2osp (unMPI s)-    hashalgo :: Pkt -> HashAlgorithm-    hashalgo (SignaturePkt (SigV4 _ _ ha _ _ _ _)) = ha-    hashalgo _ = error "This should never happen (hashalgo)."-    pkaAndMPIs (SigV4 _ pka _ _ _ _ mpis) = (pka, mpis)-    pkaAndMPIs _ = error "This should never happen (pkaAndMPIs)."-    crazyHash h = BA.convert . hashWith h--isSignatureExpired :: Pkt -> Maybe UTCTime -> Either String Bool-isSignatureExpired _ Nothing = return False-isSignatureExpired s (Just t) =-      if any-           (expiredBefore t)-           ((\(SigV4 _ _ _ h _ _ _) -> h) . _signaturePayload . fromPkt $ s)-        then Left "signature expired"-        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 SigV4 {}) = runPut $ putSigTrailer s-    trailer _ = BL.empty--signUserIDwithRSA ::-     PKPayload -- ^ 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 String SignaturePayload-signUserIDwithRSA pkp uid hsigsubs usigsubs prv = do-  uidsig <--    first-      show-      (P15.sign-         Nothing-         (Just CHA.SHA512)-         prv-         (BL.toStrict (finalPayload (SignaturePkt uidsigp) uidpayload)))-  return (uidsigp' uidsig)-  where-    uidpayload =-      runPut-        (sequence_-           [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)])-    uidsigp =-      SigV4 PositiveCert RSA SHA512 hsigsubs usigsubs 0 (NE.fromList [MPI 0])-    uidsigp' us =-      SigV4-        PositiveCert-        RSA-        SHA512-        hsigsubs-        usigsubs-        (fromIntegral (os2ip (B.take 2 us)))-        (NE.fromList [MPI (os2ip us)])--crossSignSubkeyWithRSA ::-     PKPayload -- ^ public key "payload" of key being signed-  -> PKPayload -- ^ 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 String SignaturePayload-crossSignSubkeyWithRSA pkp subpkp subhsigsubs subusigsubs embhsigsubs embusigsubs prv ssb = do-  embsig <--    first-      show-      (P15.sign-         Nothing-         (Just CHA.SHA512)-         ssb-         (BL.toStrict (finalPayload (SignaturePkt embsigp) subkeypayload)))-  subsig <--    first-      show-      (P15.sign-         Nothing-         (Just CHA.SHA512)-         prv-         (BL.toStrict (finalPayload (SignaturePkt subsigp) subkeypayload)))-  return (subsigp' (embsigp' embsig) subsig)-  where-    subkeypayload =-      runPut-        (sequence_-           [ putKeyforSigning (PublicKeyPkt pkp)-           , putKeyforSigning (PublicSubkeyPkt subpkp)-           ])-    embsigp =-      SigV4-        PrimaryKeyBindingSig-        RSA-        SHA512-        embhsigsubs-        embusigsubs-        0-        (NE.fromList [MPI 0])-    embsigp' es =-      SigV4-        PrimaryKeyBindingSig-        RSA-        SHA512-        embhsigsubs-        embusigsubs-        (fromIntegral (os2ip (B.take 2 es)))-        (NE.fromList [MPI (os2ip es)])-    subsigp =-      SigV4 SubkeyBindingSig RSA SHA512 subhsigsubs [] 0 (NE.fromList [MPI 0])-    sspes es = SigSubPacket False (EmbeddedSignature es)-    subsigp' es ss =-      SigV4-        SubkeyBindingSig-        RSA-        SHA512-        subhsigsubs-        (sspes es : subusigsubs)-        (fromIntegral (os2ip (B.take 2 ss)))-        (NE.fromList [MPI (os2ip ss)])--signDataWithRSA ::-     SigType-  -> RSATypes.PrivateKey-  -> [SigSubPacket]-  -> [SigSubPacket]-  -> ByteString-  -> Either String SignaturePayload-signDataWithRSA st prv has uhas payload =-  sp st <$>-  first-    show-    (P15.sign-       Nothing-       (Just CHA.SHA512)-       prv-       (BL.toStrict (finalPayload (SignaturePkt (sp0 st)) payload)))-  where-    sp0 st = SigV4 st RSA SHA512 has [] 0 (NE.fromList [MPI 0])-    sp st ss =-      SigV4-        st-        RSA-        SHA512-        has-        uhas-        (fromIntegral (os2ip (B.take 2 ss)))-        (NE.fromList [MPI (os2ip ss)])+-- 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+  , 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++ed25519Params :: (String, Int, Int, PubKeyAlgorithm)+ed25519Params = ("Ed25519", 64, 32, PKA.Ed25519)++ed448Params :: (String, Int, Int, PubKeyAlgorithm)+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++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
+ Codec/Encryption/OpenPGP/Subpackets.hs view
@@ -0,0 +1,503 @@+-- 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
Codec/Encryption/OpenPGP/Types.hs view
@@ -1,12 +1,13 @@--- Types.hs: OpenPGP (RFC4880) data types--- Copyright © 2012-2024  Clint Adams+-- 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+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
Codec/Encryption/OpenPGP/Types/Internal/Base.hs view
@@ -1,14 +1,20 @@--- Base.hs: OpenPGP (RFC4880) data types--- Copyright © 2012-2022  Clint Adams+-- 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@@ -20,11 +26,10 @@ 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-#if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.Key as AK-#endif import qualified Data.Aeson.TH as ATH import Data.ByteArray (ByteArrayAccess) import qualified Data.ByteString as B@@ -35,6 +40,8 @@ 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@@ -53,6 +60,8 @@ 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 @@ -82,6 +91,88 @@  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@@ -173,9 +264,16 @@  data NotationFlag   = HumanReadable-  | OtherNF Word8 -- FIXME: this should be constrained to 4 bits?+  | 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 @@ -184,9 +282,9 @@  instance FutureFlag NotationFlag where   fromFFlag HumanReadable = 0-  fromFFlag (OtherNF o) = fromIntegral o+  fromFFlag (OtherNF o) = fromIntegral (o .&. 0x0f)   toFFlag 0 = HumanReadable-  toFFlag o = OtherNF (fromIntegral o)+  toFFlag o = mkNotationFlag (fromIntegral o)  instance Hashable NotationFlag @@ -259,9 +357,16 @@  data RevocationClass   = SensitiveRK-  | RClOther Word8 -- FIXME: this should be constrained to 3 bits+  | 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 @@ -270,9 +375,9 @@  instance FutureFlag RevocationClass where   fromFFlag SensitiveRK = 1-  fromFFlag (RClOther i) = fromIntegral i+  fromFFlag (RClOther i) = fromIntegral (i .&. 0x07)   toFFlag 1 = SensitiveRK-  toFFlag i = RClOther (fromIntegral i)+  toFFlag i = mkRevocationClass (fromIntegral i)  instance Hashable RevocationClass @@ -293,6 +398,10 @@   | ForbiddenElgamal   | DH   | EdDSA+  | X25519+  | X448+  | Ed25519+  | Ed448   | OtherPKA Word8   deriving (Show, Data, Generic, Typeable) @@ -313,6 +422,10 @@   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@@ -324,6 +437,10 @@   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@@ -339,46 +456,49 @@   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) -newtype TwentyOctetFingerprint =-  TwentyOctetFingerprint-    { unTOF :: ByteString+-- | 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 TwentyOctetFingerprint+instance Wrapped Fingerprint --- FIXME: read-show-instance Read TwentyOctetFingerprint where-  readsPrec _ =-    map ((TwentyOctetFingerprint . BL.pack *** concat) . unzip) .-    chunksOf 20 . hexToW8s . filter (/= ' ')+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 TwentyOctetFingerprint+instance Hashable Fingerprint -instance Pretty TwentyOctetFingerprint where-  pretty = pretty . take 40 . bsToHexUpper . unTOF+instance Pretty Fingerprint where+  pretty = pretty . bsToHexUpper . unFingerprint -#if MIN_VERSION_aeson(2,0,0) key :: String -> AK.Key key = AK.fromText . T.pack-#else-key = T.pack-#endif -instance A.ToJSON TwentyOctetFingerprint where+instance A.ToJSON Fingerprint where   toJSON e = object [key "fpr" .= (A.toJSON . show . pretty) e] -instance A.FromJSON TwentyOctetFingerprint where-  parseJSON (A.Object v) = TwentyOctetFingerprint . read <$> v A..: key "fpr"+instance A.FromJSON Fingerprint where+  parseJSON (A.Object v) = Fingerprint . read <$> v A..: key "fpr"   parseJSON _ = mzero  newtype SpacedFingerprint =   SpacedFingerprint-    { unSpacedFingerprint :: TwentyOctetFingerprint+    { unSpacedFingerprint :: Fingerprint     }   deriving (Data, Eq, Generic, Ord, Show, Typeable) @@ -390,7 +510,7 @@     punctuate space .     map hsep .     chunksOf 5 .-    map pretty . chunksOf 4 . take 40 . bsToHexUpper . unTOF . op SpacedFingerprint+    map pretty . chunksOf 4 . bsToHexUpper . unFingerprint . op SpacedFingerprint  bsToHexUpper :: ByteString -> String bsToHexUpper = map toUpper . BLC8.unpack . B16L.encode@@ -402,14 +522,16 @@   EightOctetKeyId     { unEOKI :: ByteString     }-  deriving (Data, Eq, Generic, Ord, Show, Typeable)+  deriving (Data, Eq, Generic, Ord, Typeable)  instance Wrapped EightOctetKeyId  instance Pretty EightOctetKeyId where   pretty = pretty . bsToHexUpper . op EightOctetKeyId --- FIXME: read-show+instance Show EightOctetKeyId where+  show = bsToHexUpper . op EightOctetKeyId+ instance Read EightOctetKeyId where   readsPrec _ =     map ((EightOctetKeyId . BL.pack *** concat) . unzip) . chunksOf 8 . hexToW8s@@ -423,6 +545,30 @@   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@@ -468,6 +614,8 @@   | SHA384   | SHA512   | SHA224+  | SHA3_256+  | SHA3_512   | OtherHA Word8   deriving (Data, Generic, Show, Typeable) @@ -485,6 +633,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@@ -493,6 +643,8 @@   toFVal 9 = SHA384   toFVal 10 = SHA512   toFVal 11 = SHA224+  toFVal 12 = SHA3_256+  toFVal 14 = SHA3_512   toFVal o = OtherHA o  instance Hashable HashAlgorithm@@ -505,6 +657,8 @@   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)@@ -547,6 +701,39 @@  $(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@@ -664,7 +851,8 @@ $(ATH.deriveJSON ATH.defaultOptions ''RevocationCode)  data FeatureFlag-  = ModificationDetection+  = FeatureSEIPDv1+  | FeatureSEIPDv2   | FeatureOther Int   deriving (Data, Generic, Show, Typeable) @@ -675,20 +863,18 @@   compare = comparing fromFFlag  instance FutureFlag FeatureFlag where-  fromFFlag ModificationDetection = 7+  fromFFlag FeatureSEIPDv1 = 7+  fromFFlag FeatureSEIPDv2 = 4   fromFFlag (FeatureOther i) = fromIntegral i-  toFFlag 7 = ModificationDetection+  toFFlag 7 = FeatureSEIPDv1+  toFFlag 4 = FeatureSEIPDv2   toFFlag i = FeatureOther (fromIntegral i)  instance Hashable FeatureFlag -#if !MIN_VERSION_hashable(1,3,4)-instance Hashable a => Hashable (Set a) where-  hashWithSalt salt = hashWithSalt salt . Set.toList-#endif- instance Pretty FeatureFlag where-  pretty ModificationDetection = pretty "modification-detection"+  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)@@ -807,6 +993,9 @@  instance Wrapped MPI +instance Ord MPI where+  compare (MPI a) (MPI b) = compare a b+ instance Hashable MPI  instance Pretty MPI where@@ -814,6 +1003,122 @@  $(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@@ -831,11 +1136,50 @@       [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 ':' <+>@@ -849,6 +1193,13 @@     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)@@ -858,8 +1209,47 @@     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@@ -869,7 +1259,7 @@   | Revocable Revocability   | KeyExpirationTime ThirtyTwoBitDuration   | PreferredSymmetricAlgorithms [SymmetricAlgorithm]-  | RevocationKey (Set RevocationClass) PubKeyAlgorithm TwentyOctetFingerprint+  | RevocationKey (Set RevocationClass) PubKeyAlgorithm Fingerprint   | Issuer EightOctetKeyId   | NotationData (Set NotationFlag) NotationName NotationValue   | PreferredHashAlgorithms [HashAlgorithm]@@ -884,10 +1274,10 @@   | Features (Set FeatureFlag)   | SignatureTarget PubKeyAlgorithm HashAlgorithm SignatureHash   | EmbeddedSignature SignaturePayload-  | IssuerFingerprint Word8 TwentyOctetFingerprint+  | IssuerFingerprint IssuerFingerprintVersion Fingerprint   | UserDefinedSigSub Word8 ByteString   | OtherSigSub Word8 ByteString-  deriving (Data, Eq, Generic, Show, Typeable) -- FIXME+  deriving (Data, Eq, Generic, Ord, Show, Typeable)  instance Hashable SigSubPacketPayload @@ -1007,6 +1397,10 @@     }   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@@ -1021,9 +1415,45 @@  $(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@@ -1031,6 +1461,7 @@ instance Pretty KeyVersion where   pretty DeprecatedV3 = pretty "(deprecated) v3"   pretty V4 = pretty "v4"+  pretty V6 = pretty "v6"  $(ATH.deriveJSON ATH.defaultOptions ''KeyVersion) @@ -1051,6 +1482,9 @@  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 @@ -1090,6 +1524,17 @@  $(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@@ -1098,12 +1543,65 @@  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@@ -1131,19 +1629,49 @@  data S2K   = Simple HashAlgorithm-  | Salted HashAlgorithm Salt-  | IteratedSalted HashAlgorithm Salt IterationCount+  | 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) @@ -1151,6 +1679,7 @@   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@@ -1221,6 +1750,7 @@   | NISTP384   | NISTP521   | Curve25519+  | Curve448   deriving (Data, Eq, Generic, Ord, Show, Typeable)  instance Pretty ECCCurve where@@ -1228,11 +1758,13 @@   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]-    } -- so we can override cereal instance+    } -- intentionally not encoded as a list length prefix   deriving (Show, Eq)
Codec/Encryption/OpenPGP/Types/Internal/CryptonNewtypes.hs view
@@ -1,7 +1,8 @@ -- CryptonNewtypes.hs: OpenPGP (RFC4880) newtype wrappers for some crypton types--- Copyright © 2012-2024  Clint Adams+-- Copyright © 2012-2026  Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).+ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} @@ -26,7 +27,9 @@     }   deriving (Data, Eq, Generic, Show, Typeable) -instance Ord DSA_PublicKey+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)@@ -41,7 +44,9 @@     }   deriving (Data, Eq, Generic, Show, Typeable) -instance Ord RSA_PublicKey+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)@@ -56,7 +61,9 @@     }   deriving (Data, Eq, Generic, Show, Typeable) -instance Ord ECDSA_PublicKey+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)) =@@ -72,7 +79,9 @@     }   deriving (Data, Eq, Generic, Show, Typeable) -instance Ord DSA_PrivateKey+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)@@ -86,7 +95,12 @@     }   deriving (Data, Eq, Generic, Show, Typeable) -instance Ord RSA_PrivateKey+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)) =@@ -102,7 +116,9 @@     }   deriving (Data, Eq, Generic, Show, Typeable) -instance Ord ECDSA_PrivateKey+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)) =@@ -118,6 +134,10 @@     }   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) @@ -150,12 +170,54 @@  instance Hashable ECDSA_PublicKey where   hashWithSalt s (ECDSA_PublicKey (ECDSA.PublicKey curve q)) =-    s `hashWithSalt` show curve `hashWithSalt` show q -- FIXME: don't use show+    hashWithCurve s curve `hashWithECPoint` q  instance Hashable ECDSA_PrivateKey where   hashWithSalt s (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) =-    s `hashWithSalt` show curve `hashWithSalt` show d -- FIXME: don't use show+    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@@ -167,5 +229,10 @@   toJSON (ECurvePoint ECCT.PointO) = A.toJSON "point at infinity"  instance A.FromJSON ECurvePoint where-  parseJSON (A.Object v) = error "FIXME: whatsit"-  parseJSON _ = mzero+  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
Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs view
@@ -1,10 +1,17 @@--- PKITypes.hs: OpenPGP (RFC4880) data types for public/secret keys--- Copyright © 2012-2024  Clint Adams+-- 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 #-} @@ -12,15 +19,15 @@  import GHC.Generics (Generic) -import Codec.Encryption.OpenPGP.Types.Internal.Base+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.Aeson.TH as ATH import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL-import Data.Data (Data)+import Data.Data (Data(..))+import qualified Data.Data as DData import Data.Hashable (Hashable(..)) import Data.Ord (comparing) import Data.Typeable (Typeable)@@ -29,12 +36,14 @@  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 @@ -52,13 +61,28 @@  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 EPoint+  | EdDSAPubKey EdSigningCurve EdPoint   | UnknownPKey ByteString   deriving (Data, Eq, Generic, Ord, Show, Typeable) @@ -91,11 +115,90 @@   | 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@@ -104,6 +207,8 @@   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 "<unknown>" <+> pretty (bsToHexUpper bs)  instance A.ToJSON SKey where@@ -113,41 +218,162 @@   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 =-  PKPayload-    { _keyVersion :: KeyVersion-    , _timestamp :: ThirtyTwoBitTimeStamp-    , _v3exp :: V3Expiration-    , _pkalgo :: PubKeyAlgorithm-    , _pubkey :: PKey-    }-  deriving (Data, Eq, Generic, Show, Typeable)+data PKPayload (v :: KeyVersion) where+  PKPayloadV3 ::+       ThirtyTwoBitTimeStamp+    -> V3Expiration+    -> PubKeyAlgorithm+    -> PKey+    -> PKPayload 'DeprecatedV3+  PKPayloadV4 ::+       ThirtyTwoBitTimeStamp+    -> PubKeyAlgorithm+    -> PKey+    -> PKPayload 'V4+  PKPayloadV6 ::+       ThirtyTwoBitTimeStamp+    -> PubKeyAlgorithm+    -> PKey+    -> PKPayload 'V6 -instance Ord PKPayload where-  compare =-    comparing _keyVersion <> comparing _timestamp <> comparing _v3exp <>-    comparing _pkalgo <>-    comparing _pubkey+deriving instance Eq (PKPayload v)+deriving instance Ord (PKPayload v)+deriving instance Show (PKPayload v) -instance Hashable PKPayload+instance Hashable (PKPayload v) where+  hashWithSalt s = hashWithSalt s . pkPayloadFields -instance Pretty PKPayload where+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 -$(ATH.deriveToJSON ATH.defaultOptions ''PKPayload)+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 a b = show a `compare` show b -- FIXME: this is ridiculous+  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 @@ -158,6 +384,10 @@   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) =@@ -166,5 +396,128 @@ 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)
Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs view
@@ -1,12 +1,16 @@--- PacketClass.hs: OpenPGP (RFC4880) data types--- Copyright © 2012-2022  Clint Adams+-- 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 #-} @@ -31,32 +35,70 @@   data PacketType a :: Data.Kind.Type   packetType :: a -> PacketType a   packetCode :: PacketType a -> Word8+  dynamicPacketCode :: a -> Word8   toPkt :: a -> Pkt-  fromPkt :: Pkt -> a+  fromPktMaybe :: Pkt -> Maybe a+  fromPktEither :: Pkt -> Either String a+  +  fromPktMaybe = either (const Nothing) Just . fromPktEither+  dynamicPacketCode = packetCode . packetType -data PKESK =-  PKESK-    { _pkeskPacketVersion :: PacketVersion-    , _pkeskEightOctetKeyId :: EightOctetKeyId-    , _pkeskPubKeyAlgorithm :: PubKeyAlgorithm-    , _pkeskMPIs :: NonEmpty MPI-    }-  deriving (Data, Eq, Show, Typeable)+coercionError :: String -> Pkt -> Either String a+coercionError expected pkt =+  Left+    ("Cannot coerce non-" +++     expected ++ " packet (tag " ++ show (pktTag pkt) ++ ")") -instance Packet PKESK where-  data PacketType PKESK = PKESKType-                          deriving (Show, Eq)+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 (PKESK a b c d) = PKESKPkt a b c d-  fromPkt (PKESKPkt a b c d) = PKESK a b c d-  fromPkt _ = error "Cannot coerce non-PKESK packet"+  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 where+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 -- FIXME?+  Signature     { _signaturePayload :: SignaturePayload     }   deriving (Data, Eq, Show, Typeable)@@ -67,59 +109,204 @@   packetType _ = SignatureType   packetCode _ = 2   toPkt (Signature a) = SignaturePkt a-  fromPkt (SignaturePkt a) = Signature a-  fromPkt _ = error "Cannot coerce non-Signature packet"+  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 SKESK =-  SKESK-    { _skeskPacketVersion :: PacketVersion-    , _skeskSymmetricAlgorithm :: SymmetricAlgorithm-    , _skeskS2K :: S2K-    , _skeskESK :: Maybe BL.ByteString-    }-  deriving (Data, Eq, Show, Typeable)+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 -instance Packet SKESK where-  data PacketType SKESK = SKESKType-                          deriving (Show, Eq)+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 (SKESK a b c d) = SKESKPkt a b c d-  fromPkt (SKESKPkt a b c d) = SKESK a b c d-  fromPkt _ = error "Cannot coerce non-SKESK packet"+  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 where+instance Pretty (SKESK 'SKESKV4) where   pretty = pretty . toPkt -data OnePassSignature =-  OnePassSignature-    { _onePassSignaturePacketVersion :: PacketVersion-    , _onePassSignatureSigType :: SigType-    , _onePassSignatureHashAlgorithm :: HashAlgorithm-    , _onePassSignaturePubKeyAlgorithm :: PubKeyAlgorithm-    , _onePassSignatureEightOctetKeyId :: EightOctetKeyId-    , _onePassSignatureNestedFlag :: NestedFlag-    }-  deriving (Data, Eq, Show, Typeable)+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 Packet OnePassSignature where-  data PacketType OnePassSignature = OnePassSignatureType-                                     deriving (Show, Eq)+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 (OnePassSignature a b c d e f) = OnePassSignaturePkt a b c d e f-  fromPkt (OnePassSignaturePkt a b c d e f) = OnePassSignature a b c d e f-  fromPkt _ = error "Cannot coerce non-OnePassSignature packet"+  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 where+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 :: PKPayload+    { _secretKeyPKPayload :: SomePKPayload     , _secretKeySKAddendum :: SKAddendum     }   deriving (Data, Eq, Show, Typeable)@@ -130,15 +317,15 @@   packetType _ = SecretKeyType   packetCode _ = 5   toPkt (SecretKey a b) = SecretKeyPkt a b-  fromPkt (SecretKeyPkt a b) = SecretKey a b-  fromPkt _ = error "Cannot coerce non-SecretKey packet"+  fromPktEither (SecretKeyPkt a b) = Right (SecretKey a b)+  fromPktEither pkt = coercionError "SecretKey" pkt  instance Pretty SecretKey where   pretty = pretty . toPkt  newtype PublicKey =   PublicKey-    { _publicKeyPKPayload :: PKPayload+    { _publicKeyPKPayload :: SomePKPayload     }   deriving (Data, Eq, Show, Typeable) @@ -148,15 +335,15 @@   packetType _ = PublicKeyType   packetCode _ = 6   toPkt (PublicKey a) = PublicKeyPkt a-  fromPkt (PublicKeyPkt a) = PublicKey a-  fromPkt _ = error "Cannot coerce non-PublicKey packet"+  fromPktEither (PublicKeyPkt a) = Right (PublicKey a)+  fromPktEither pkt = coercionError "PublicKey" pkt  instance Pretty PublicKey where   pretty = pretty . toPkt  data SecretSubkey =   SecretSubkey-    { _secretSubkeyPKPayload :: PKPayload+    { _secretSubkeyPKPayload :: SomePKPayload     , _secretSubkeySKAddendum :: SKAddendum     }   deriving (Data, Eq, Show, Typeable)@@ -167,8 +354,8 @@   packetType _ = SecretSubkeyType   packetCode _ = 7   toPkt (SecretSubkey a b) = SecretSubkeyPkt a b-  fromPkt (SecretSubkeyPkt a b) = SecretSubkey a b-  fromPkt _ = error "Cannot coerce non-SecretSubkey packet"+  fromPktEither (SecretSubkeyPkt a b) = Right (SecretSubkey a b)+  fromPktEither pkt = coercionError "SecretSubkey" pkt  instance Pretty SecretSubkey where   pretty = pretty . toPkt@@ -186,8 +373,8 @@   packetType _ = CompressedDataType   packetCode _ = 8   toPkt (CompressedData a b) = CompressedDataPkt a b-  fromPkt (CompressedDataPkt a b) = CompressedData a b-  fromPkt _ = error "Cannot coerce non-CompressedData packet"+  fromPktEither (CompressedDataPkt a b) = Right (CompressedData a b)+  fromPktEither pkt = coercionError "CompressedData" pkt  instance Pretty CompressedData where   pretty = pretty . toPkt@@ -204,8 +391,8 @@   packetType _ = SymEncDataType   packetCode _ = 9   toPkt (SymEncData a) = SymEncDataPkt a-  fromPkt (SymEncDataPkt a) = SymEncData a-  fromPkt _ = error "Cannot coerce non-SymEncData packet"+  fromPktEither (SymEncDataPkt a) = Right (SymEncData a)+  fromPktEither pkt = coercionError "SymEncData" pkt  instance Pretty SymEncData where   pretty = pretty . toPkt@@ -222,8 +409,8 @@   packetType _ = MarkerType   packetCode _ = 10   toPkt (Marker a) = MarkerPkt a-  fromPkt (MarkerPkt a) = Marker a-  fromPkt _ = error "Cannot coerce non-Marker packet"+  fromPktEither (MarkerPkt a) = Right (Marker a)+  fromPktEither pkt = coercionError "Marker" pkt  instance Pretty Marker where   pretty = pretty . toPkt@@ -243,8 +430,8 @@   packetType _ = LiteralDataType   packetCode _ = 11   toPkt (LiteralData a b c d) = LiteralDataPkt a b c d-  fromPkt (LiteralDataPkt a b c d) = LiteralData a b c d-  fromPkt _ = error "Cannot coerce non-LiteralData packet"+  fromPktEither (LiteralDataPkt a b c d) = Right (LiteralData a b c d)+  fromPktEither pkt = coercionError "LiteralData" pkt  instance Pretty LiteralData where   pretty = pretty . toPkt@@ -261,8 +448,8 @@   packetType _ = TrustType   packetCode _ = 12   toPkt (Trust a) = TrustPkt a-  fromPkt (TrustPkt a) = Trust a-  fromPkt _ = error "Cannot coerce non-Trust packet"+  fromPktEither (TrustPkt a) = Right (Trust a)+  fromPktEither pkt = coercionError "Trust" pkt  instance Pretty Trust where   pretty = pretty . toPkt@@ -279,15 +466,15 @@   packetType _ = UserIdType   packetCode _ = 13   toPkt (UserId a) = UserIdPkt a-  fromPkt (UserIdPkt a) = UserId a-  fromPkt _ = error "Cannot coerce non-UserId packet"+  fromPktEither (UserIdPkt a) = Right (UserId a)+  fromPktEither pkt = coercionError "UserId" pkt  instance Pretty UserId where   pretty = pretty . toPkt  newtype PublicSubkey =   PublicSubkey-    { _publicSubkeyPKPayload :: PKPayload+    { _publicSubkeyPKPayload :: SomePKPayload     }   deriving (Data, Eq, Show, Typeable) @@ -297,8 +484,8 @@   packetType _ = PublicSubkeyType   packetCode _ = 14   toPkt (PublicSubkey a) = PublicSubkeyPkt a-  fromPkt (PublicSubkeyPkt a) = PublicSubkey a-  fromPkt _ = error "Cannot coerce non-PublicSubkey packet"+  fromPktEither (PublicSubkeyPkt a) = Right (PublicSubkey a)+  fromPktEither pkt = coercionError "PublicSubkey" pkt  instance Pretty PublicSubkey where   pretty = pretty . toPkt@@ -315,8 +502,8 @@   packetType _ = UserAttributeType   packetCode _ = 17   toPkt (UserAttribute a) = UserAttributePkt a-  fromPkt (UserAttributePkt a) = UserAttribute a-  fromPkt _ = error "Cannot coerce non-UserAttribute packet"+  fromPktEither (UserAttributePkt a) = Right (UserAttribute a)+  fromPktEither pkt = coercionError "UserAttribute" pkt  instance Pretty UserAttribute where   pretty = pretty . toPkt@@ -326,6 +513,12 @@     { _symEncIntegrityProtectedDataPacketVersion :: PacketVersion     , _symEncIntegrityProtectedDataPayload :: ByteString     }+  | SymEncIntegrityProtectedDataV2+      SymmetricAlgorithm+      AEADAlgorithm+      Word8+      Salt+      ByteString   deriving (Data, Eq, Show, Typeable)  instance Packet SymEncIntegrityProtectedData where@@ -334,10 +527,14 @@                                         deriving (Show, Eq)   packetType _ = SymEncIntegrityProtectedDataType   packetCode _ = 18-  toPkt (SymEncIntegrityProtectedData a b) = SymEncIntegrityProtectedDataPkt a b-  fromPkt (SymEncIntegrityProtectedDataPkt a b) =-    SymEncIntegrityProtectedData a b-  fromPkt _ = error "Cannot coerce non-SymEncIntegrityProtectedData packet"+  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@@ -355,8 +552,8 @@   packetType _ = ModificationDetectionCodeType   packetCode _ = 19   toPkt (ModificationDetectionCode a) = ModificationDetectionCodePkt a-  fromPkt (ModificationDetectionCodePkt a) = ModificationDetectionCode a-  fromPkt _ = error "Cannot coerce non-ModificationDetectionCode packet"+  fromPktEither (ModificationDetectionCodePkt a) = Right (ModificationDetectionCode a)+  fromPktEither pkt = coercionError "ModificationDetectionCode" pkt  instance Pretty ModificationDetectionCode where   pretty = pretty . toPkt@@ -372,10 +569,11 @@   data PacketType OtherPacket = OtherPacketType                                 deriving (Show, Eq)   packetType _ = OtherPacketType-  packetCode _ = undefined -- FIXME+  packetCode _ = error "OtherPacket has no static packet type code"+  dynamicPacketCode = _otherPacketType   toPkt (OtherPacket a b) = OtherPacketPkt a b-  fromPkt (OtherPacketPkt a b) = OtherPacket a b-  fromPkt _ = error "Cannot coerce non-OtherPacket packet"+  fromPktEither (OtherPacketPkt a b) = Right (OtherPacket a b)+  fromPktEither pkt = coercionError "OtherPacket" pkt  instance Pretty OtherPacket where   pretty = pretty . toPkt@@ -392,25 +590,18 @@   data PacketType BrokenPacket = BrokenPacketType                                  deriving (Show, Eq)   packetType _ = BrokenPacketType-  packetCode _ = undefined+  packetCode _ = error "BrokenPacket has no static packet type code"+  dynamicPacketCode = _brokenPacketType   toPkt (BrokenPacket a b c) = BrokenPacketPkt a b c-  fromPkt (BrokenPacketPkt a b c) = BrokenPacket a b c-  fromPkt _ = error "Cannot coerce non-BrokenPacket packet"+  fromPktEither (BrokenPacketPkt a b c) = Right (BrokenPacket a b c)+  fromPktEither pkt = coercionError "BrokenPacket" pkt  instance Pretty BrokenPacket where   pretty = pretty . toPkt -$(makeLenses ''PKESK)- $(makeLenses ''Signature) -$(makeLenses ''SKESK)--$(makeLenses ''OnePassSignature)- $(makeLenses ''SecretKey)--$(makeLenses ''PKPayload)  $(makeLenses ''PublicKey)
Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs view
@@ -1,13 +1,18 @@--- Pkt.hs: OpenPGP (RFC4880) Pkt data types--- Copyright © 2012-2022  Clint Adams+-- 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@@ -23,7 +28,8 @@ import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL-import Data.Data (Data)+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@@ -35,51 +41,264 @@ 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 PacketVersion EightOctetKeyId PubKeyAlgorithm (NonEmpty MPI)+  = PKESKPkt PKESKPayload   | SignaturePkt SignaturePayload-  | SKESKPkt PacketVersion SymmetricAlgorithm S2K (Maybe BL.ByteString)-  | OnePassSignaturePkt-      PacketVersion-      SigType-      HashAlgorithm-      PubKeyAlgorithm-      EightOctetKeyId-      NestedFlag-  | SecretKeyPkt PKPayload SKAddendum-  | PublicKeyPkt PKPayload-  | SecretSubkeyPkt PKPayload SKAddendum+  | 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 PKPayload+  | PublicSubkeyPkt SomePKPayload   | UserAttributePkt [UserAttrSubPacket]-  | SymEncIntegrityProtectedDataPkt PacketVersion ByteString+  | SymEncIntegrityProtectedDataPkt SEIPDPayload   | ModificationDetectionCodePkt ByteString   | OtherPacketPkt Word8 ByteString   | BrokenPacketPkt String Word8 ByteString-  deriving (Data, Eq, Generic, Show, Typeable) -- FIXME+  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 = comparing pktTag <> comparing hash -- FIXME: is there something saner?+  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 pv eoki pka mpis) =+  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 pv sa s2k mbs) =-    pretty "SKESK v" <> pretty pv <> pretty ':' <+>+  pretty (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k mbs))) =+    pretty "SKESK v4:" <+>     pretty sa <+> pretty s2k <+> pretty (fmap bsToHexUpper mbs)-  pretty (OnePassSignaturePkt pv st ha pka eoki nestedflag) =+  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@@ -97,10 +316,14 @@   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 pv bs) =+  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) =@@ -111,7 +334,7 @@     pretty t <> pretty ':' <+> pretty (bsToHexUpper bs)  instance A.ToJSON Pkt where-  toJSON (PKESKPkt pv eoki pka mpis) =+  toJSON (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eoki pka mpis))) =     object       [ key "pkesk" .=         object@@ -121,19 +344,41 @@           , 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 pv sa s2k mbs) =+  toJSON (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k mbs))) =     object       [ key "skesk" .=         object-          [ key "version" .= pv+          [ key "version" .= (4 :: PacketVersion)           , key "symalgo" .= sa           , key "s2k" .= s2k           , key "data" .= maybe mempty BL.unpack mbs           ]       ]-  toJSON (OnePassSignaturePkt pv st ha pka eoki nestedflag) =+  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@@ -144,6 +389,19 @@           , 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" .=@@ -176,11 +434,22 @@   toJSON (UserIdPkt u) = object [key "userid" .= u]   toJSON (PublicSubkeyPkt pkp) = object [key "publicsubkkey" .= pkp]   toJSON (UserAttributePkt us) = object [key "userattribute" .= us]-  toJSON (SymEncIntegrityProtectedDataPkt pv bs) =+  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) =@@ -219,20 +488,112 @@ 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 :: PKPayload+    { _verificationSigner :: SomePKPayload     , _verificationSignature :: SignaturePayload+    , _verificationWarnings :: [VerificationWarning]     } +data VerificationWarning+  = MissingSubkeyBackSignatureWarning+  deriving (Eq, Show)+ data SOPVVerification =   SOPVVerification     { _sopvvDateStamp :: UTCTime-    , _sopvvFingerprint :: TwentyOctetFingerprint-    , _sopvvPrimaryFingerprint :: TwentyOctetFingerprint+    , _sopvvFingerprint :: Fingerprint+    , _sopvvPrimaryFingerprint :: Fingerprint     , _sopvvMode :: String     , _sopvvDescription :: String     }  $(makeLenses ''Verification) $(makeLenses ''SOPVVerification)+$(makeLenses ''PktWithWireRep)
Codec/Encryption/OpenPGP/Types/Internal/TK.hs view
@@ -1,11 +1,18 @@--- TK.hs: OpenPGP (RFC4880) transferable key data type--- Copyright © 2012-2016  Clint Adams+-- 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 @@ -15,31 +22,575 @@ import Codec.Encryption.OpenPGP.Types.Internal.PKITypes import Codec.Encryption.OpenPGP.Types.Internal.Pkt +import Control.Arrow ((&&&)) 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) -data TK =+-- | 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-    { _tkKey :: (PKPayload, Maybe SKAddendum)+    { _tkPrimaryKey :: KeyPkt (TKKindToKeyPktKind k)     , _tkRevs :: [SignaturePayload]     , _tkUIDs :: [(Text, [SignaturePayload])]     , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])]-    , _tkSubs :: [(Pkt, [SignaturePayload])]+    , _tkSubs :: [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]     }-  deriving (Data, Eq, Generic, Show, Typeable)+  deriving (Eq, Show) -instance Ord TK where-  compare = comparing _tkKey -- FIXME: is this ridiculous?+deriving instance (Typeable k, Data (KeyPkt (TKKindToKeyPktKind k))) => Data (TK k) -$(ATH.deriveToJSON ATH.defaultOptions ''TK)+instance Ord (TK k) where+  compare = comparing _tkPrimaryKey -type KeyringIxs = '[ EightOctetKeyId, TwentyOctetFingerprint, Text]+data SomeTK where+  SomePublicTK :: TK 'PublicTK -> SomeTK+  SomeSecretTK :: TK 'SecretTK -> SomeTK -type Keyring = IxSet KeyringIxs TK+deriving instance Show SomeTK +instance Eq SomeTK where+  left == right = someTKToUnknown left == someTKToUnknown right++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++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)+    }++fromUnknownToTK :: TKUnknown -> Either String SomeTK+fromUnknownToTK 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 String (KeyPkt 'PublicPkt, [SignaturePayload])+    liftPublicSubkey (pkt, sigs) =+      case pktToPublicKeyPkt pkt of+        Just keyPkt+          | keyPktRole keyPkt == KeyPktSubkey ->+              Right (keyPkt, sigs)+          | otherwise ->+              Left "public subkey has primary-key role"+        Nothing ->+          Left ("expected public subkey, got packet tag " ++ show (pktTag pkt))++    liftSecretSubkey ::+         (Pkt, [SignaturePayload])+      -> Either String (KeyPkt 'SecretPkt, [SignaturePayload])+    liftSecretSubkey (pkt, sigs) =+      case pktToSecretKeyPkt pkt of+        Just keyPkt+          | keyPktRole keyPkt == KeyPktSubkey ->+              Right (keyPkt, sigs)+          | otherwise ->+              Left "secret subkey has primary-key role"+        Nothing ->+          Left ("expected secret subkey, got packet tag " ++ show (pktTag pkt))++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)+
Data/Conduit/OpenPGP/Compression.hs view
@@ -1,7 +1,8 @@--- Compression.hs: OpenPGP (RFC4880) compression conduits--- Copyright © 2012-2018  Clint Adams+-- 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@@ -9,12 +10,18 @@  import Codec.Encryption.OpenPGP.Compression import Codec.Encryption.OpenPGP.Types-import Control.Monad.Trans.Resource (MonadThrow)+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 = CL.concatMap decompressPkt+conduitDecompress = awaitForever $ \pkt ->+  case decompressPkt pkt of+    Left err   -> throwM (userError (renderCompressionError err))+    Right pkts -> mapM_ yield pkts
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -1,152 +1,2484 @@--- Decrypt.hs: OpenPGP (RFC4880) recursive packet decryption--- Copyright © 2013-2020  Clint Adams--- This software is released under the terms of the Expat license.--- (See the LICENSE file).-{-# LANGUAGE FlexibleContexts #-}--module Data.Conduit.OpenPGP.Decrypt-  ( conduitDecrypt-  ) where--import Control.Monad (when)-import Control.Monad.Fail (MonadFail)-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.IO.Unlift (MonadUnliftIO)-import Control.Monad.Trans.Resource (MonadResource, MonadThrow)-import qualified Crypto.Hash as CH-import qualified Crypto.Hash.Algorithms as CHA-import Data.Binary (get)-import qualified Data.ByteArray as BA-import qualified Data.ByteString as B-import qualified Data.ByteString.Base16.Lazy as B16L-import qualified Data.ByteString.Lazy as BL-import Data.Conduit-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.Combinators as CC-import qualified Data.Conduit.List as CL-import Data.Conduit.OpenPGP.Compression (conduitDecompress)-import Data.Conduit.Serialization.Binary (conduitGet)-import Data.Maybe (fromJust, isNothing)--import Codec.Encryption.OpenPGP.CFB (decryptOpenPGPCfb, decryptPreservingNonce)-import Codec.Encryption.OpenPGP.S2K (skesk2Key)-import Codec.Encryption.OpenPGP.Types--data RecursorState =-  RecursorState-    { _depth :: Int-    , _lastPKESK :: Maybe PKESK-    , _lastSKESK :: Maybe SKESK-    , _lastNonce :: Maybe B.ByteString-    , _lastClearText :: Maybe B.ByteString-    }-  deriving (Eq, Show)--def :: RecursorState-def = RecursorState 0 Nothing Nothing Nothing Nothing--type InputCallback m = String -> m BL.ByteString--conduitDecrypt ::-     (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m)-  => InputCallback IO-  -> ConduitT Pkt Pkt m ()-conduitDecrypt = conduitDecrypt' def--conduitDecrypt' ::-     (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m)-  => RecursorState-  -> InputCallback IO-  -> ConduitT Pkt Pkt m ()-conduitDecrypt' rs cb = CC.concatMapAccumM push rs-  where-    push ::-         (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m)-      => Pkt-      -> RecursorState-      -> m (RecursorState, [Pkt])-    push i s-      | _depth s > 42 = fail "I think we've been quine-attacked"-      | otherwise =-        case i of-          SKESKPkt {} -> return (s {_lastSKESK = Just (fromPkt i)}, [])-          (SymEncDataPkt bs) -> do-            d <- decryptSEDP s cb (fromJust . _lastSKESK $ s) bs-            return (s, d)-          (SymEncIntegrityProtectedDataPkt _ bs) -> do-            d <- decryptSEIPDP s cb (fromJust . _lastSKESK $ s) bs-            return (s, d)-          m@(ModificationDetectionCodePkt mdc) -> do-            when (isNothing (_lastClearText s)) $ fail "MDC with no referent"-            let mcalculated = calculateMDC <$> _lastNonce s <*> _lastClearText s-            when (mcalculated /= Just mdc) $-              fail $-              "MDC indicates tampering: " ++-              show (B16L.encode mdc) ++-              " versus " ++-              maybe "<empty>" (show . B16L.encode) mcalculated ++-              "  ... " ++-              show (_lastNonce s) ++ " / " ++ show (_lastClearText s)-            return (s, [m])-          p -> return (s, [p])--decryptSEDP ::-     (MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m)-  => RecursorState-  -> InputCallback IO-  -> SKESK-  -> BL.ByteString-  -> m [Pkt]-decryptSEDP rs cb skesk bs -- FIXME: this shouldn't pass the whole SKESK- = do-  passphrase <- liftIO $ cb "Input the passphrase I want"-  let key = skesk2Key skesk passphrase-      decrypted =-        case decryptOpenPGPCfb-               (_skeskSymmetricAlgorithm skesk)-               (BL.toStrict bs)-               key of-          Left e -> error e-          Right x -> x-  runConduitRes $-    CB.sourceLbs (BL.fromStrict decrypted) .| conduitGet get .|-    conduitDecompress .|-    conduitDecrypt' rs {_depth = _depth rs + 1} cb .|-    CL.consume--decryptSEIPDP ::-     (MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m)-  => RecursorState-  -> InputCallback IO-  -> SKESK-  -> BL.ByteString-  -> m [Pkt]-decryptSEIPDP rs cb skesk bs -- FIXME: this shouldn't pass the whole SKESK- = do-  passphrase <- liftIO $ cb "Input the passphrase I want"-  let key = skesk2Key skesk passphrase-      (nonce, decrypted) =-        case decryptPreservingNonce-               (_skeskSymmetricAlgorithm skesk)-               (BL.toStrict bs)-               key of-          Left e -> error e-          Right x -> x-  runConduitRes $-    CB.sourceLbs (BL.fromStrict decrypted) .| conduitGet get .|-    conduitDecompress .|-    conduitDecrypt'-      rs-        { _depth = _depth rs + 1-        , _lastNonce = Just nonce-        , _lastClearText = Just decrypted-        }-      cb .|-    CL.consume--calculateMDC :: B.ByteString -> B.ByteString -> BL.ByteString-calculateMDC nonce garbage-  | B.length garbage < 23 = mempty -- FIXME: this is horrible-  | otherwise =-    BL.fromStrict . BA.convert . (CH.hash :: B.ByteString -> CH.Digest CHA.SHA1) $-    nonce <> B.take (B.length garbage - 22) garbage <> B.pack [211, 20]+-- 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 "<empty>" 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
Data/Conduit/OpenPGP/Filter.hs view
@@ -1,7 +1,8 @@ -- Filter.hs: OpenPGP (RFC4880) packet filtering--- Copyright © 2014-2020  Clint Adams+-- 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@@ -19,7 +20,7 @@ import Codec.Encryption.OpenPGP.Types  data FilterPredicates r a-  = RTKFilterPredicate (Reader TK Bool) -- ^ fp for transferable keys+  = 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@@ -33,10 +34,10 @@ superPredicate (RFilterPredicate e) p = runReader e p superPredicate _ _ = False -- do not match incorrect type of packet -conduitTKFilter :: Monad m => FilterPredicates Void TK -> ConduitT TK TK m ()+conduitTKFilter :: Monad m => FilterPredicates Void TKUnknown -> ConduitT TKUnknown TKUnknown m () conduitTKFilter = CL.filter . superTKPredicate -superTKPredicate :: FilterPredicates Void TK -> TK -> Bool+superTKPredicate :: FilterPredicates Void TKUnknown -> TKUnknown -> Bool superTKPredicate (RTKFilterPredicate e) = runReader e superTKPredicate (RFilterPredicate e) = runReader e
Data/Conduit/OpenPGP/Keyring.hs view
@@ -1,23 +1,74 @@--- Keyring.hs: OpenPGP (RFC4880) transferable keys parsing--- Copyright © 2012-2018  Clint Adams+-- 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-  ( conduitToTKs+  ( conduitToUnknownTKs+  , conduitToTKs+  , conduitToPublicTKs+  , conduitToPublicViewTKs+  , conduitToSecretTKs+  , AuthSecretSubkeyUID(..)+  , AuthSecretSubkeyAtTime(..)+  , AuthSecretSubkeyRejectionReason(..)+  , AuthSecretSubkeyRejectedAtTime(..)+  , AuthSecretSubkeysAtReport(..)+  , authSecretSubkeysAt+  , authSecretSubkeysAtReport+  , conduitToAuthSecretSubkeysAt+  , conduitToAuthSecretSubkeysAtReport   , conduitToTKsDropping-  , sinkKeyringMap+  , 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.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-  ( anyTK-  , finalizeParsing-  , parseAChunk+  ( KeyringChunkParseError(..)+  , anyTK+  , anyTKWithWireRep+  , finalizeParsingEither+  , parseAChunkEither   )-import Codec.Encryption.OpenPGP.Ontology (isTrustPkt)+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 () @@ -30,37 +81,382 @@   | SkippingBroken   deriving (Eq, Ord, Show) -conduitToTKs :: Monad m => ConduitT Pkt TK m ()-conduitToTKs = conduitToTKs' True+conduitToUnknownTKs :: Monad m => ConduitT Pkt TKUnknown m ()+conduitToUnknownTKs =+  conduitToTKsEither .|+  conduitDropErrorsAndNothings -conduitToTKsDropping :: Monad m => ConduitT Pkt TK m ()-conduitToTKsDropping = conduitToTKs' False+conduitToTKs :: Monad m => ConduitT Pkt SomeTK m ()+conduitToTKs =+  conduitToUnknownTKs .|+  CL.mapMaybe (either (const Nothing) Just . fromUnknownToTK) -fakecmAccum ::+conduitToPublicTKs :: Monad m => ConduitT Pkt (TK 'PublicTK) m ()+conduitToPublicTKs =+  conduitToTKs .|+  CL.mapMaybe+    (\stk ->+       case stk of+         SomePublicTK tk -> Just tk+         SomeSecretTK _ -> Nothing)++-- | 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+    (\stk ->+       case stk of+         SomePublicTK tk -> tk+         SomeSecretTK tk -> publicViewTK tk)++conduitToSecretTKs :: Monad m => ConduitT Pkt (TK 'SecretTK) m ()+conduitToSecretTKs =+  conduitToTKs .|+  CL.mapMaybe+    (\stk ->+       case stk of+         SomeSecretTK tk -> Just tk+         SomePublicTK _ -> Nothing)++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-  => (accum -> (accum, [b]))-  -> (a -> accum -> (accum, [b]))+  => 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++conduitToTKsDropping :: Monad m => ConduitT Pkt TKUnknown m ()+conduitToTKsDropping =+  conduitToTKsDroppingEither .|+  conduitDropErrorsAndNothings++conduitToTKsDroppingEither ::+     Monad m => ConduitT Pkt (Either KeyringChunkParseError (Maybe TKUnknown)) m ()+conduitToTKsDroppingEither = conduitToTKsEither' False++conduitToTKsWithWireRep :: Monad m => ConduitT PktWithWireRep TKWithWireRep m ()+conduitToTKsWithWireRep =+  conduitToTKsWithWireRepEither .|+  conduitDropErrorsAndNothings++conduitToTKsWithWireRepEither ::+     Monad m+  => ConduitT+      PktWithWireRep+      (Either KeyringChunkParseError (Maybe TKWithWireRep))+      m+      ()+conduitToTKsWithWireRepEither = conduitToTKsWithWireRepEither' True++conduitToTKsDroppingWithWireRep ::+     Monad m => ConduitT PktWithWireRep TKWithWireRep m ()+conduitToTKsDroppingWithWireRep =+  conduitToTKsDroppingWithWireRepEither .|+  conduitDropErrorsAndNothings++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 b m ()-fakecmAccum finalizer f = loop+  -> ConduitT a (Either e b) m ()+fakecmAccumEither finalizer f initialAccum = loop initialAccum   where-    loop accum = await >>= maybe (mapM_ yield (snd (finalizer accum))) go-      where-        go a = do-          let (accum', bs) = f a accum-          mapM_ yield bs-          loop accum'+    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' -conduitToTKs' :: Monad m => Bool -> ConduitT Pkt TK m ()-conduitToTKs' intolerant =+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 (: []) .|-  fakecmAccum-    finalizeParsing-    (parseAChunk (anyTK intolerant))-    ([], Just (Nothing, anyTK intolerant)) .|-  CL.catMaybes+  fakecmAccumEither+    finalizeParsingEither+    (parseAChunkEither (anyTK intolerant))+    ([], Just (Nothing, anyTK intolerant))   where     notTrustPacket = not . isTrustPkt -sinkKeyringMap :: Monad m => ConduitT TK Void m Keyring-sinkKeyringMap = CL.fold (flip insert) empty+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)
Data/Conduit/OpenPGP/Keyring/Instances.hs view
@@ -1,7 +1,9 @@--- Instances.hs: OpenPGP (RFC4880) additional types for transferable keys--- Copyright © 2012-2019  Clint Adams+-- 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 #-}@@ -14,6 +16,7 @@ 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)@@ -21,41 +24,146 @@ 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 TK where-  indices = ixList (ixFun getEOKIs) (ixFun getTOFs) (ixFun getUIDs)+instance Indexable KeyringIxs TKUnknown where+  indices = ixList (ixFun getEOKIs) (ixFun getFingerprints) (ixFun getUIDs) -getEOKIs :: TK -> [EightOctetKeyId]-getEOKIs tk = rights (map eightOctetKeyID (tk ^.. biplate :: [PKPayload]))+getEOKIs :: TKUnknown -> [EightOctetKeyId]+getEOKIs tk = rights (map eightOctetKeyID (tk ^.. biplate :: [SomePKPayload])) -getTOFs :: TK -> [TwentyOctetFingerprint]-getTOFs tk = map fingerprint (tk ^.. biplate :: [PKPayload])+getFingerprints :: TKUnknown -> [Fingerprint]+getFingerprints tk = map fingerprint (tk ^.. biplate :: [SomePKPayload]) -getUIDs :: TK -> [Text]-getUIDs tk = (tk ^. tkUIDs) ^.. folded . _1+getUIDs :: TKUnknown -> [Text]+getUIDs tk = (tk ^. tkuUIDs) ^.. folded . _1 -instance Ord SignaturePayload where-  compare s1@(SigV3 st1 ct1 eoki1 pka1 ha1 left16_1 mpis1) s2@(SigV3 st2 ct2 eoki2 pka2 ha2 left16_2 mpis2) =-    compare ct1 ct2 <> compare st1 st2 <> compare eoki1 eoki2 -- FIXME: nondeterministic-  compare s1@(SigV4 st1 pka1 ha1 has1 uhas1 left16_1 mpis1) s2@(SigV4 st2 pka2 ha2 has2 uhas2 left16_2 mpis2) =-    compare (sigCT s1) (sigCT s2) <> compare st1 st2 <>-    compare (issuer (SignaturePkt s1)) (issuer (SignaturePkt s2)) -- FIXME: nondeterministic-  compare s1@(SigVOther sv1 bs1) s2@(SigVOther sv2 bs2) =-    compare sv1 sv2 <> compare bs1 bs2-  compare SigV3 {} SigV4 {} = LT-  compare SigV3 {} SigVOther {} = LT-  compare SigV4 {} SigV3 {} = GT-  compare SigV4 {} SigVOther {} = LT-  compare SigVOther {} SigV3 {} = GT-  compare SigVOther {} SigV4 {} = GT+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 TK where+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-      (_tkKey a)+      (_tkPrimaryKey a)       (nub . sort $ _tkRevs a ++ _tkRevs b)       ((kvmerge `on` _tkUIDs) a b)       ((kvmerge `on` _tkUAts) a b)
+ Data/Conduit/OpenPGP/Message.hs view
@@ -0,0 +1,95 @@+-- 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)
Data/Conduit/OpenPGP/Verify.hs view
@@ -1,36 +1,138 @@--- Verify.hs: OpenPGP (RFC4880) signature verification--- Copyright © 2012-2016  Clint Adams+-- 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-  ( conduitVerify+  ( 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 (verifyAgainstKeyring, verifySigWith)+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-  => Keyring+  => PublicKeyring   -> Maybe UTCTime-  -> ConduitT Pkt (Either String Verification) m ()-conduitVerify kr mt = CL.concatMapAccum (flip push) emptyPSC+  -> 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-    push state ld@LiteralDataPkt {} = (state {lastLD = ld}, [])-    push state uid@(UserIdPkt _) = (state {lastUIDorUAt = uid}, [])-    push state uat@(UserAttributePkt _) = (state {lastUIDorUAt = uat}, [])-    push state pk@(PublicKeyPkt _) = (state {lastPrimaryKey = pk}, [])-    push state pk@(PublicSubkeyPkt _) = (state {lastSubkey = pk}, [])-    push state sk@(SecretKeyPkt _ _) = (state {lastPrimaryKey = sk}, [])-    push state sk@(SecretSubkeyPkt _ _) = (state {lastSubkey = sk}, [])-    push state sig@(SignaturePkt SigV4 {}) =+    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])-    push state (OnePassSignaturePkt _ _ _ _ _ False) = (state, [])-    push state _ = (state, [])-    normLineEndings = id -- FIXME+      , [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
LICENSE view
@@ -1,4 +1,4 @@-Copyright © 2012-2014 Clint Adams <clint@debian.org>+Copyright © 2012-2026 Clint Adams <clint@debian.org>  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the@@ -6,15 +6,15 @@ 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 following conditions:  The above copyright notice and this permission notice shall be-included in all copies or substantial portions of the Software. +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 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.
bench/mark.hs view
@@ -1,22 +1,36 @@ -- mark.hs: hOpenPGP benchmark suite--- Copyright © 2014-2018  Clint Adams+-- 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 (wireRepRef)  import Data.Binary (get)-import Data.Conduit.OpenPGP.Keyring (conduitToTKs, sinkKeyringMap)+import Data.Conduit.OpenPGP.Keyring+ ( conduitToPublicViewTKs+ , conduitToUnknownTKs+ , sinkPublicKeyringMap+ ) import Data.Conduit.Serialization.Binary (conduitGet) import qualified Data.IxSet.Typed as IxSet+import qualified Data.ByteString.Lazy as BL  import qualified Data.Conduit as DC import qualified Data.Conduit.Binary as CB@@ -34,19 +48,41 @@         , 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 =       DC.runConduitRes $-      CB.sourceFile fp DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume+      CB.sourceFile fp DC..| conduitGet get DC..| conduitToUnknownTKs DC..| CL.consume     loadKeyring fp =       DC.runConduitRes $-      CB.sourceFile fp DC..| conduitGet get DC..| conduitToTKs DC..|-      sinkKeyringMap+      CB.sourceFile fp DC..| conduitGet get DC..| conduitToPublicViewTKs DC..|+      sinkPublicKeyringMap     selfVerifyKeys fp =       fmap         (\ks ->-           mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks)+           mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks)         (loadKeys fp)     selfVerifyKeyring fp =       fmap
hOpenPGP.cabal view
@@ -1,8 +1,8 @@ Cabal-version:       3.4 Name:                hOpenPGP-Version:             2.10.1.1-Synopsis:            native Haskell implementation of OpenPGP (RFC4880)-Description:         native Haskell implementation of OpenPGP (RFC4880), plus Camellia (RFC5581), plus ECC (RFC6637)+Version:             3.0.0+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@@ -151,6 +151,8 @@   , 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@@ -161,13 +163,19 @@   , 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+  build-depends: aeson                 >= 2.0     && < 3                , attoparsec                , base                   > 4.9     && < 5                , base16-bytestring@@ -181,7 +189,7 @@                , containers                , crypto-cipher-types                , errors-               , hashable+               , hashable              >= 1.3.4   && <1.6                , incremental-parser    >= 0.5.1                , ixset-typed                , lens                  >= 3.0@@ -206,30 +214,39 @@ 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@@ -246,34 +263,47 @@   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    >= 0.1+               , openpgp-asciiarmor    >= 1.0   default-language: Haskell2010  Test-Suite tests   import:     deps, publicmods, internalmods   type:       exitcode-stdio-1.0-  main-is:    tests/suite.hs+  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@@ -281,6 +311,7 @@                , tasty-quickcheck                , QuickCheck            > 2.9                , quickcheck-instances+               , openpgp-asciiarmor    >= 1.0   default-language: Haskell2010  Benchmark benchmark@@ -290,6 +321,7 @@   Ghc-options: -Wall   Build-depends: hOpenPGP                , criterion             > 0.8+               , openpgp-asciiarmor    >= 1.0   default-language: Haskell2010  source-repository head@@ -299,4 +331,4 @@ source-repository this   type:     git   location: https://salsa.debian.org/clint/hOpenPGP.git-  tag:      v2.10.1.1+  tag:      v3.0.0
+ tests/Tests/Common.hs view
@@ -0,0 +1,1539 @@+-- 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 fromUnknownToTK 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++
+ tests/Tests/Encryption.hs view
@@ -0,0 +1,4918 @@+-- 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(..)+  , EncryptCompatibilityProfile(..)+  , RecipientCapabilities(..)+  , RecipientEncryptionTargetRejected(..)+  , RecipientEncryptionTargetsReport(..)+  , RecipientTargetRejectionReason(..)+  , RecipientPKESKVersionStrategy(..)+  , RecipientEncryptionTarget(..)+  , RecipientPayloadShape(..)+  , RecipientEncryptRequest(..)+  , RecipientEncryptRequestOverrides(..)+  , defaultRecipientPayloadShape+  , RecipientEncryptResult(..)+  , PKESKVersionPolicy(..)+  , pkeskSessionAlgorithm+  , pkeskV3SessionMaterial+  , buildPKESKv3PayloadForRecipient+  , buildPKESKPayloadForRecipient+  , canonicalizePKESKRecipientId+  , encryptSEIPDv2Payload+  , encryptForRecipients+  , encryptForRecipientsLegacy+  , encryptForRecipientsWithCapabilityNegotiation+  , recipientCapabilitiesFromSubpacketPayloads+  , recipientEncryptionTargetFromTKAtTimestamp+  , 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 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+  ( 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")+  ]++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+            "conduitToTKsEither reports parse failures"+            testConduitToTKsEitherReportsParseFailure+        , testCase+            "conduitToTKsDroppingEither reports parse failures"+            testConduitToTKsDroppingEitherReportsParseFailure+        ]+    , 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+            "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 "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)++-- 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+  (recipientPub, recipientPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1)+  let 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+  (recipientPub, _) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1)+  let 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)++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+  (recipientPub, _) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1)+  let 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+  (recipientPub, recipientPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1)+  (ephPub, ephPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1)+  let 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+  (recipientPub, recipientPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1)+  (ephPub, ephPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1)+  let 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 21+      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 21+      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+  (recipientPub, recipientPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1)+  (ephPub, ephPriv) <- ECCGen.generate (ECCT.getCurveByName ECCT.SEC_p256r1)+  let 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 21+    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 21+      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"++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)
+ tests/Tests/Keys.hs view
@@ -0,0 +1,1677 @@+-- 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+  )+import Codec.Encryption.OpenPGP.Serialize+  ( getSecretKey+  , parsePkts+  )+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+  , 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 "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+
+ tests/Tests/MessageAndArmor.hs view
@@ -0,0 +1,1847 @@+-- 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 (parsePkts, parsePktsEither)+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 (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+            "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", "<v4test@example.org>")+    , ("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"+    ["<v4test@example.org>", "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", "<v4test@example.org>")+    , ("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 ""))))++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 ()++
+ tests/Tests/Properties.hs view
@@ -0,0 +1,274 @@+-- 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+
+ tests/Tests/Serialization.hs view
@@ -0,0 +1,956 @@+-- 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
+ tests/Tests/Utilities.hs view
@@ -0,0 +1,1234 @@+-- 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 qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA+import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)+import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev)+import Codec.Encryption.OpenPGP.KeyringParser+  ( parsePublicTKs+  , parseSecretTKs+  , parseTKs+  , parseTKsWithWireRep+  , parseUnknownTKs+  )+import Codec.Encryption.OpenPGP.Serialize+  ( PktParseError(..)+  , WireRepInput(..)+  , conduitParsePktsWithWireRep+  , 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+  , conduitToAuthSecretSubkeysAt+  , conduitToAuthSecretSubkeysAtReport+  , conduitToPublicTKs+  , conduitToSecretTKs+  , conduitToTKs+  , conduitToTKsWithWireRep+  , conduitToUnknownTKs+  )+import Data.Conduit.Serialization.Binary (conduitGet)+import Data.List (nub, sortOn)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Set as Set+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase)+import Tests.Common+  ( addTimestampSeconds+  , armorPayload+  , 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+        "typed TKUnknown conduit partitioning"+        (testConduitToTKsTypedUtil "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+        "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)++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)++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)))++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+    armors <-+      case AA.decodeLazy armored of+        Left err ->+          assertFailure ("failed to decode v6-secret fixture: " ++ err) >> fail "unreachable"+        Right as -> pure as+    armor <-+      case armors of+        (a:_) -> pure a+        [] -> assertFailure "v6-secret.pgp.aa should contain one armored payload" >> fail "unreachable"+    case parseUnknownTKs True (parsePkts (armorPayload armor)) 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)++
+ tests/data/encryption-sym-aes256-sha256.pgp view
@@ -0,0 +1,1 @@+Ã.	j,KWfb‚ÿ4q¯õ¸ïtugs«}«{{%Ū»ˆ¡t$WxMÜó)¬ÿ;Ò6˜8:µâş}$•¯ñ|{ˆ™°±Ê"ÅNWã¹Å@˜ör¯†JÖK…êDM7V£] ‹€õ
+ tests/data/seipdv2-for-v4-key.pgp.aa view
@@ -0,0 +1,8 @@+-----BEGIN PGP MESSAGE-----++wWwGFQTIJj/G1nYES26XOVnC8sLK4w3pCBIBB0BwOFvfLenhFHR1kdTjP/Wp+Ghn+LO5VTiE7bl1W7V/wAzAlO0jypAZyu5jCTeqGKqjipkMDEbou8BKoRPUInw6jn04s+P7QkQ+ZGFFlsY2frya3SagIJAgbmRJucr1ylMximFV/OaApO0g+y/AU6lJ74s6rU+5mK8o91lNZt976H0vAiqIhRNWLT18MUqd4/mPA75DVKBrkFzxoiMf+CpT6vJmHH/+K008SSmmSROTVY1XOiNxfW/Ohzj3ExR2h1k=+-----END PGP MESSAGE-----
+ tests/data/seipdv2-three-recipients.pgp.aa view
@@ -0,0 +1,13 @@+-----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-----
+ tests/data/seipdv2-two-recipients.pgp.aa view
@@ -0,0 +1,11 @@+-----BEGIN PGP MESSAGE-----++wW0GIQav44SnLNNBPMT5pEw1RZY8zjlKostWz+pDmoUF+5URxRmPwQGf5CbZQKLE+VnWosSwUCTzfssCThJ8F3ipLqGWyJyjPK9ORkR2F2mJcFaGN37sgh6YS3YDCy7M8+KtEW4sCKbPPaCi8AHyWTwWwGFQTIJj/G1nYES26XOVnC8sLK4w3pCBIBB0Cc/SaD+cEivp/+lPv11uVOacGCxzAUmg3j0N7QfvpCOYDAPTgXG+2wHd4o1GCW3t/vCTnHU+BsC9fym6071xys8em8YXQAMwYaxNFd1tQd9GL5zSdgIJAgbnRfhxbeKxWPQjGsCo+11qRYfinBxjBQUwI8NpwPrGstym4RvVuxDSBGMrga6FRIjAn9VD9cwDZsJ5mxWhO+bsV0rVwQr/Nn2ibpJpOzVHty/6hkyf3dRDSPiaZdRQmvuWCTtyWd/ptLBX6oK0c6+JidNvfI=+-----END PGP MESSAGE-----
+ tests/data/v4-encrypted-secret.pgp.aa view
@@ -0,0 +1,53 @@+-----BEGIN PGP PRIVATE KEY BLOCK-----+Comment: D2E0 81E9 3FDC A2E7 8B5F  C433 811D 9243 394B 79C1+Comment: <v4test@example.org>+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-----
+ tests/data/v4-encrypted.rev.aa view
@@ -0,0 +1,14 @@+-----BEGIN PGP PUBLIC KEY BLOCK-----+Comment: Revocation certificate for+Comment: D2E0 81E9 3FDC A2E7 8B5F  C433 811D 9243 394B 79C1+Comment: <v4test@example.org>+Comment: v4 Test User++xjMEakxBgBYJKwYBBAHaRw8BAQdAP6cjID4HFp73MwUjEA/nCYXMRSItPLypDLtZ+jPULW1jCwAsEIBYKAH0FgmpMQYAJEIEdkkM5S3nBRxQAAAAAAB4AIHNhbHRAbm90+YXRpb25zLnNlcXVvaWEtcGdwLm9yZ/hWf5apgI9nH8rb38xB9/pvNhBar7LRWmx3+nhaGr1GIDR0AVW5zcGVjaWZpZWQWIQTS4IHpP9yi54tfxDOBHZJDOUt5wQAAytsA+/R0VwOa7/1datJPZxyqeF0t9xD/XUGvjxMAnDoJSWyLyAQCPOEdgir5BeKShK+Z3+J45dM+Ccv0l5tcQDqUsOUMa0AA==+=ASZC+-----END PGP PUBLIC KEY BLOCK-----
tests/suite.hs view
@@ -1,928 +1,38 @@-{-# LANGUAGE OverloadedStrings #-}- -- suite.hs: hOpenPGP test suite--- Copyright © 2012-2019  Clint Adams+-- 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, testGroup)-import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, testCase)-import Test.Tasty.QuickCheck as QC -import Codec.Encryption.OpenPGP.Arbitrary ()-import Codec.Encryption.OpenPGP.Compression (compressPkts, decompressPkt)-import Codec.Encryption.OpenPGP.Expirations (isTKTimeValid)-import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)-import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)-import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint)-import Codec.Encryption.OpenPGP.KeyringParser (parseTKs)-import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey, encryptPrivateKey)-import Codec.Encryption.OpenPGP.Serialize (parsePkts)-import Codec.Encryption.OpenPGP.Signatures-  ( verifyAgainstKeys-  , verifySigWith-  , verifyTKWith-  )-import Codec.Encryption.OpenPGP.Types-import Control.Error.Util (isRight)-import Control.Exception.Base (SomeException, catch)-import Control.Monad.Trans.Resource (ResourceT)-import qualified Crypto.PubKey.ECC.ECDSA as ECDSA-import qualified Crypto.PubKey.RSA as RSA-import Data.Bifunctor (bimap)-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 Data.Conduit.OpenPGP.Compression (conduitCompress, conduitDecompress)-import Data.Conduit.OpenPGP.Decrypt (conduitDecrypt)-import Data.Conduit.OpenPGP.Keyring-  ( conduitToTKs-  , conduitToTKsDropping-  , sinkKeyringMap-  )-import Data.Conduit.OpenPGP.Verify (conduitVerify)-import Data.Conduit.Serialization.Binary (conduitGet)-import Data.IxSet.Typed ((@=), getOne)-import Data.Maybe (isJust)-import Data.Text (Text)-import Data.Text.Prettyprint.Doc (pretty)-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)--import qualified Data.Conduit as DC-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL---- this needs a better name-runGet :: Get a -> BL.ByteString -> Either String a-runGet g bs = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail g bs)---- FIXME: nothing tests serialization of TKs-testSerialization :: FilePath -> Assertion-testSerialization fpr = do-  bs <- BL.readFile $ "tests/data/" ++ 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--testCompression :: FilePath -> Assertion-testCompression fpr = do-  bs <- BL.readFile $ "tests/data/" ++ fpr-  let firstpass = fmap (concatMap 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 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--testPKAandSizeAndKeyIDandFingerprint :: FilePath -> String -> Assertion-testPKAandSizeAndKeyIDandFingerprint fpr kf = do-  bs <- BL.readFile $ "tests/data/" ++ fpr-  case runGet (get :: Get Pkt) bs of-    Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke."-    Right (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 public key, got something else."-  where-    spaceless = filter (/= ' ')--testKeyringLookup :: FilePath -> String -> Bool -> Assertion-testKeyringLookup fpr eok expected = do-  kr <--    DC.runConduitRes $-    CB.sourceFile ("tests/data/" ++ fpr) DC..| conduitGet get DC..| conduitToTKs DC..|-    sinkKeyringMap-  let key = getOne (kr @= (read eok :: EightOctetKeyId))-  assertEqual (eok ++ " in " ++ fpr) expected (isJust key)--testVerifyMessage ::-     FilePath -> FilePath -> [TwentyOctetFingerprint] -> Assertion-testVerifyMessage keyring message issuers = do-  kr <--    DC.runConduitRes $-    CB.sourceFile ("tests/data/" ++ keyring) DC..| conduitGet get DC..|-    conduitToTKs DC..|-    sinkKeyringMap-  verification <--    DC.runConduitRes $-    CB.sourceFile ("tests/data/" ++ message) DC..| conduitGet get DC..|-    conduitDecompress DC..|-    conduitVerify kr Nothing DC..|-    CL.consume-  let verification' =-        map (fmap (fingerprint . _verificationSigner)) verification-  assertEqual (keyring ++ " for " ++ message) (map Right issuers) verification'--testKeysSelfVerification :: Bool -> FilePath -> Assertion-testKeysSelfVerification expectsuccess keyfile = do-  ks <--    DC.runConduitRes $-    CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..|-    conduitToTKs DC..|-    CL.consume-  let verifieds =-        mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks-  assertEqual-    (keyfile ++ " self-verification")-    expectsuccess-    (isRight verifieds) -- FIXME:--testKeysExpiration :: Bool -> FilePath -> Assertion-testKeysExpiration expectsuccess keyfile = do-  ks <--    DC.runConduitRes $-    CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..|-    conduitToTKs DC..|-    CL.consume-  let Right verifieds =-        mapM (verifyTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks-      tvalid =-        all-          (isTKTimeValid-             (posixSecondsToUTCTime (realToFrac (1400000000 :: Integer))))-          verifieds-  assertEqual (keyfile ++ " key expiration") expectsuccess tvalid---- This needs a lot of work-testSymmetricEncryption :: FilePath -> FilePath -> BL.ByteString -> Assertion-testSymmetricEncryption encfile passfile cleartext = do-  passphrase <- BL.readFile $ "tests/data/" ++ passfile-  -- get parse tree-  pt <--    DC.runConduitRes $-    CB.sourceFile ("tests/data/" ++ encfile) DC..| conduitGet get DC..|-    CL.consume-  -- assert parse tree has exactly two packets: skesk, encdata-  assertEqual "wrong number of packets" 2 (length pt)-  let skesk = fromPkt . head $ pt-      d = fromPkt . last $ pt-  -- FIXME: these assertions don't currently do anything properly,-  -- because haskell notices the _-prefixed accessor invocations below-  -- and the type system chokes before we hit them:-  assertEqual "first packet should be SKESK" SKESKType (packetType skesk)-  assertEqual-    "second packet should be encrypted data"-    SymEncIntegrityProtectedDataType-    (packetType d)-  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))-  let payload = _literalDataPayload . fromPkt . head $ decrypted-  assertEqual ("cleartext for " ++ encfile) cleartext payload-  where-    fakeCallback :: BL.ByteString -> String -> IO BL.ByteString-    fakeCallback = const . return--testSecretKeyDecryption :: FilePath -> FilePath -> Assertion-testSecretKeyDecryption keyfile passfile = do-  passphrase <- BL.readFile $ "tests/data/" ++ passfile-  kr <--    DC.runConduitRes $-    CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..|-    CL.consume-  let SecretKey pkp ska = fromPkt . head $ kr-      SUUnencrypted skey _ = decryptPrivateKey (pkp, ska) passphrase-  doPkeyAndSkeyMatch (_pubkey pkp) skey---- FIXME: this should be reworked either with tasty-golden or some other form of sanity-testSecretKeyEncryption :: FilePath -> FilePath -> Assertion-testSecretKeyEncryption keyfile passfile = do-  passphrase <- BL.readFile $ "tests/data/" ++ passfile-  kr <--    DC.runConduitRes $-    CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..|-    CL.consume-  gkr <--    DC.runConduitRes $-    CB.sourceFile ("tests/data/" ++ "aes256-sha512.seckey") DC..| conduitGet get DC..|-    CL.consume-  let SecretKey pkp ska = fromPkt . head $ kr-      newska =-        encryptPrivateKey-          "\226~\197\a\202#\"G"-          (IV "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t")-          ska-          passphrase-      newtruck = toPkt (SecretKey pkp newska) : tail kr-  assertEqual "encrypted private key matches golden file" gkr newtruck--testParsePktsUtil :: FilePath -> Assertion-testParsePktsUtil fn = do-  let fpath = "tests/data/" ++ fn-  cp <--    DC.runConduitRes $ CB.sourceFile fpath DC..| conduitGet get DC..| CL.consume-  pp <- parsePkts `fmap` BL.readFile fpath-  assertEqual-    "parsePkts utility function gives same results as conduit pipeline"-    cp-    pp--testParseTKsUtil :: FilePath -> Assertion-testParseTKsUtil fn = do-  let fpath = "tests/data/" ++ fn-  lbs <- BL.readFile fpath-  cp <--    DC.runConduitRes $-    CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToTKs DC..| CL.consume-  let pt = parseTKs True . parsePkts $ lbs-  assertEqual-    "parsePkts utility function gives same results as conduit pipeline"-    cp-    pt+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 = testGroup "Tests" [properties, unitTests]+tests =+  localOption+    (NumThreads 4)+    (testGroup+       "Tests"+       [ localOption (QC.QuickCheckTests 20) propertiesTests+       , unitTests+       ])  unitTests :: TestTree unitTests =   testGroup     "Unit Tests"-    [ testGroup-        "Serialization group"-        [ testCase-            "000001-006.public_key"-            (testSerialization "000001-006.public_key")-        , 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-            "sample-eddsa.pubkey"-            (testSerialization "sample-eddsa.pubkey")-        ]-    , testGroup-        "PKA/Size/KeyID/fingerprint group"-        [ testCase-            "v3 key"-            (testPKAandSizeAndKeyIDandFingerprint-               "v3.key"-               "R1024:C7261095/CBD9 F412 6807 E405 CC2D  2712 1DF5 E86E")-        , testCase-            "v4 key"-            (testPKAandSizeAndKeyIDandFingerprint-               "000001-006.public_key"-               "R1248:D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E")-        , testCase-            "ECDSA key"-            (testPKAandSizeAndKeyIDandFingerprint-               "nist_p-256_key.gpg"-               "E256:F7708BADD6063224/174C CF12 C571 6D0E 527F  B50E F770 8BAD D606 3224")-        , testCase-            "EdDSA key"-            (testPKAandSizeAndKeyIDandFingerprint-               "sample-eddsa.pubkey"-               "w256:8CFDE12197965A9A/C959 BDBA FA32 A2F8 9A15  3B67 8CFD E121 9796 5A9A")-        ]-    , 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)-   -- FIXME: should count keys in rings-        ]-    , testGroup-        "Message verification group"-        [ testCase-            "uncompressed-ops-dsa"-            (testVerifyMessage-               "pubring.gpg"-               "uncompressed-ops-dsa.gpg"-               [fp "1EB2 0B2F 5A5C C3BE AFD6  E5CB 7732 CF98 8A63 EA86"])-        , testCase-            "uncompressed-ops-dsa-sha384"-            (testVerifyMessage-               "pubring.gpg"-               "uncompressed-ops-dsa-sha384.txt.gpg"-               [fp "1EB2 0B2F 5A5C C3BE AFD6  E5CB 7732 CF98 8A63 EA86"])-        , testCase-            "uncompressed-ops-rsa"-            (testVerifyMessage-               "pubring.gpg"-               "uncompressed-ops-rsa.gpg"-               [fp "CB79 3345 9F59 C70D F1C3  FBEE DEDC 3ECF 689A F56D"])-        , testCase-            "compressedsig"-            (testVerifyMessage-               "pubring.gpg"-               "compressedsig.gpg"-               [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"])-        , testCase-            "compressedsig-zlib"-            (testVerifyMessage-               "pubring.gpg"-               "compressedsig-zlib.gpg"-               [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"])-        , testCase-            "compressedsig-bzip2"-            (testVerifyMessage-               "pubring.gpg"-               "compressedsig-bzip2.gpg"-               [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"])-        ]-    , testGroup-        "Certificate verification group"-        [ testCase-            "userid"-            (testVerifyMessage-               "pubring.gpg"-               "minimized.gpg"-               [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"])-        , testCase-            "subkey"-            (testVerifyMessage-               "pubring.gpg"-               "subkey.gpg"-               [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"])-        , testCase-            "primary key binding"-            (testVerifyMessage-               "signing-subkey.gpg"-               "primary-binding.gpg"-               [fp "ED1B D216 F70E 5D5F 4444  48F9 B830 F2C4 83A9 9AE5"])-        , testCase-            "attribute"-            (testVerifyMessage-               "pubring.gpg"-               "uat.gpg"-               [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"])-        , testCase-            "primary key revocation"-            (testVerifyMessage-               "pubring.gpg"-               "prikey-rev.gpg"-               [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"])-        , testCase-            "subkey revocation"-            (testVerifyMessage-               "pubring.gpg"-               "subkey-rev.gpg"-               [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"])-        , testCase-            "6F87040E"-            (testVerifyMessage-               "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"-               ])-        , testCase-            "6F87040E-cr"-            (testVerifyMessage-               "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"-               ])-        , testCase-            "simple RSA secret key"-            (testVerifyMessage-               "pubring.gpg"-               "simple.seckey"-               [fp "421F 28FE AAD2 22F8 56C8  FFD5 D4D5 4EA1 6F87 040E"])-        , testCase-            "simple ECDSA public key"-            (testVerifyMessage-               "ecdsa-key-without-ecdh.pubkey"-               "ecdsa-key-without-ecdh.pubkey"-               [fp "174C CF12 C571 6D0E 527F  B50E F770 8BAD D606 3224"])-        ]-    , 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-        "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-        "Compression group"-        [ testCase "compressedsig.gpg" (testCompression "compressedsig.gpg")-        , testCase-            "compressedsig-zlib.gpg"-            (testCompression "compressedsig-zlib.gpg")-        , testCase-            "compressedsig-bzip2.gpg"-            (testCompression "compressedsig-bzip2.gpg")-        ]-    , 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-            "conduitToTKs"-            (testConduitOutputLength "pubring.gpg" (cgp DC..| conduitToTKs) 4)-        , testCase-            "conduitToTKsDropping"-            (testConduitOutputLength-               "pubring.gpg"-               (cgp DC..| conduitToTKsDropping)-               4)-        ]-    , testGroup-        "Encrypted data"-        [ testCase-            "Symmetric Encryption simple S2K SHA1 3DES, no MDC"-            (testSymmetricEncryption-               "encryption-sym-3des-s2k0.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted S2K SHA1 3DES, no MDC"-            (testSymmetricEncryption-               "encryption-sym-3des.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption simple S2K SHA1 3DES"-            (testSymmetricEncryption-               "encryption-sym-3des-mdc-s2k0.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted S2K SHA1 3DES"-            (testSymmetricEncryption-               "encryption-sym-3des-mdc.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption simple S2K SHA1 CAST5, no MDC"-            (testSymmetricEncryption-               "encryption-sym-cast5-s2k0.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted S2K SHA1 CAST5, no MDC"-            (testSymmetricEncryption-               "encryption-sym-cast5.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption simple S2K SHA1 CAST5"-            (testSymmetricEncryption-               "encryption-sym-cast5-mdc-s2k0.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted S2K SHA1 CAST5"-            (testSymmetricEncryption-               "encryption-sym-cast5-mdc.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption simple S2K SHA1 Blowfish, no MDC"-            (testSymmetricEncryption-               "encryption-sym-blowfish-s2k0.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted S2K SHA1 Blowfish, no MDC"-            (testSymmetricEncryption-               "encryption-sym-blowfish.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption simple S2K SHA1 Blowfish"-            (testSymmetricEncryption-               "encryption-sym-blowfish-mdc-s2k0.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted S2K SHA1 Blowfish"-            (testSymmetricEncryption-               "encryption-sym-blowfish-mdc.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption simple S2K SHA1 AES128"-            (testSymmetricEncryption-               "encryption-sym-aes128-s2k0.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted S2K SHA1 AES128"-            (testSymmetricEncryption-               "encryption-sym-aes128.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption simple S2K SHA1 AES192"-            (testSymmetricEncryption-               "encryption-sym-aes192-s2k0.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted S2K SHA1 AES192"-            (testSymmetricEncryption-               "encryption-sym-aes192.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption simple S2K SHA1 AES256"-            (testSymmetricEncryption-               "encryption-sym-aes256-s2k0.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted S2K SHA1 AES256"-            (testSymmetricEncryption-               "encryption-sym-aes256.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption simple S2K SHA1 Twofish"-            (testSymmetricEncryption-               "encryption-sym-twofish-s2k0.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted S2K SHA1 Twofish"-            (testSymmetricEncryption-               "encryption-sym-twofish.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption simple Camellia128"-            (testSymmetricEncryption-               "encryption-sym-camellia128-s2k0.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted Camellia128"-            (testSymmetricEncryption-               "encryption-sym-camellia128.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted Camellia192"-            (testSymmetricEncryption-               "encryption-sym-camellia192.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption iterated-salted Camellia256"-            (testSymmetricEncryption-               "encryption-sym-camellia256.gpg"-               "symmetric-password.txt"-               "test\n")-        , testCase-            "Symmetric Encryption pgcrypto"-            (testSymmetricEncryption-               "encryption-sym-pgcrypto.pgp"-               "pgcrypto-passphrase.txt"-               "{\"t\":\"plus\"}")-        ]-    , 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-            "SUSSHA1 AES256 IteratedSalted SHA512 RSA"-            (testSecretKeyEncryption "unencrypted.seckey" "pki-password.txt")-        ]-    , testGroup-        "Utility function group"-        [ testCase "pubring as packets" (testParsePktsUtil "pubring.gpg")-        , testCase "pubring as TKs" (testParseTKsUtil "pubring.gpg")-        ]-    ]--properties :: TestTree-properties = testGroup "Properties" [qcProps]--qcProps :: TestTree-qcProps =-  testGroup-    "(checked by QuickCheck)"-    [ QC.testProperty "PKESK packet serialization-deserialization" $ \pkesk ->-        Right (pkesk :: PKESK) == runGet get (runPut (put pkesk))-    , QC.testProperty "Signature packet serialization-deserialization" $ \sig ->-        Right (sig :: Signature) == runGet get (runPut (put sig))-    , QC.testProperty "UserId packet serialization-deserialization" $ \uid ->-        Right (uid :: UserId) == runGet get (runPut (put uid))+    [ serializationTests+    , keyAndVerificationTests+    , encryptionAndCompressionTests+    , messageAndArmorTests+    , utilityTests     ]--cgp :: DC.ConduitT B.ByteString Pkt (ResourceT IO) ()-cgp = conduitGet (get :: Get Pkt)--fp :: Text -> TwentyOctetFingerprint-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"  main :: IO () main = defaultMain tests