hOpenPGP 3.6.5 → 3.6.6
raw patch · 7 files changed
+440/−152 lines, 7 files
Files
- Codec/Encryption/OpenPGP/Encrypt.hs +119/−39
- Codec/Encryption/OpenPGP/Internal.hs +0/−14
- Codec/Encryption/OpenPGP/Serialize.hs +70/−74
- Codec/Encryption/OpenPGP/Types/Internal/Errors.hs +29/−22
- Data/Conduit/OpenPGP/Decrypt.hs +3/−0
- hOpenPGP.cabal +2/−2
- tests/Tests/Properties.hs +217/−1
Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -7,6 +7,8 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}@@ -82,6 +84,10 @@ , aesKeyWrapRFC3394 , deriveX25519Kek , deriveX448Kek+ , PKAEncryptOps (..)+ , PKAEncryptOpsDict (..)+ , SomePKAEncryptOpsDict (..)+ , pkaEncryptOpsDict ) where import Control.Applicative ((<|>))@@ -114,10 +120,12 @@ import qualified Data.ByteString.Lazy as BL import Data.Containers.ListUtils (nubOrd) import Data.Int (Int64)+import Data.Kind (Type) import Data.List (elemIndex, find, maximumBy, sortOn) import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromMaybe, listToMaybe)+import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Ord (comparing)+import Data.Proxy (Proxy (..)) import qualified Data.Set as Set import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)@@ -203,6 +211,99 @@ import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes +class PKAEncryptOps (a :: PubKeyAlgorithm) where+ pkaBuildV3PKESK+ :: MonadRandom m+ => Proxy a+ -> SomePKPayload+ -> PKESKV3SessionMaterial+ -> m (Either PKESKEncryptError PKESKPayloadV3)+ pkaBuildV6PKESK+ :: MonadRandom m+ => Proxy a+ -> SomePKPayload+ -> PKESKSessionMaterial+ -> m (Either PKESKEncryptError PKESKPayloadV6)++instance PKAEncryptOps RSA where+ pkaBuildV3PKESK _ = buildRsaPKESKv3+ pkaBuildV6PKESK _ = buildRsaPKESKv6++instance PKAEncryptOps ECDH where+ pkaBuildV3PKESK _ = buildECDHPKESKv3+ pkaBuildV6PKESK _ = buildECDHPKESKv6++instance PKAEncryptOps X25519 where+ pkaBuildV3PKESK _ = buildX25519PKESKv3+ pkaBuildV6PKESK _ r m = buildX25519PKESKv6 r (pkeskV6RawSessionMaterial m)++instance PKAEncryptOps X448 where+ pkaBuildV3PKESK _ = buildX448PKESKv3+ pkaBuildV6PKESK _ r m = buildX448PKESKv6 r (pkeskV6RawSessionMaterial m)++data PKAEncryptOpsDict = PKAEncryptOpsDict+ { pkaDictBuildV3+ :: forall m+ . MonadRandom m+ => SomePKPayload+ -> PKESKV3SessionMaterial+ -> m (Either PKESKEncryptError PKESKPayloadV3)+ , pkaDictBuildV6+ :: forall m+ . MonadRandom m+ => SomePKPayload+ -> PKESKSessionMaterial+ -> m (Either PKESKEncryptError PKESKPayloadV6)+ }++data SomePKAEncryptOpsDict where+ SomePKAEncryptOpsDict+ :: PKAEncryptOpsDict -> SomePKAEncryptOpsDict++pkaEncryptOpsDict+ :: PubKeyAlgorithm -> Maybe SomePKAEncryptOpsDict+pkaEncryptOpsDict RSA =+ Just+ ( SomePKAEncryptOpsDict+ ( PKAEncryptOpsDict+ buildRsaPKESKv3+ (\r m -> buildRsaPKESKv6 r m)+ )+ )+pkaEncryptOpsDict DeprecatedRSAEncryptOnly =+ Just+ ( SomePKAEncryptOpsDict+ ( PKAEncryptOpsDict+ buildRsaPKESKv3+ (\r m -> buildRsaPKESKv6 r m)+ )+ )+pkaEncryptOpsDict ECDH =+ Just+ ( SomePKAEncryptOpsDict+ ( PKAEncryptOpsDict+ buildECDHPKESKv3+ (\r m -> buildECDHPKESKv6 r m)+ )+ )+pkaEncryptOpsDict X25519 =+ Just+ ( SomePKAEncryptOpsDict+ ( PKAEncryptOpsDict+ buildX25519PKESKv3+ (\r m -> buildX25519PKESKv6 r (pkeskV6RawSessionMaterial m))+ )+ )+pkaEncryptOpsDict X448 =+ Just+ ( SomePKAEncryptOpsDict+ ( PKAEncryptOpsDict+ buildX448PKESKv3+ (\r m -> buildX448PKESKv6 r (pkeskV6RawSessionMaterial m))+ )+ )+pkaEncryptOpsDict _ = Nothing+ data RecipientCapabilityNegotiationMode = RecipientCapabilityNegotiationOff | RecipientCapabilityNegotiationOn@@ -554,13 +655,7 @@ supportsPKESKRecipientAlgorithm :: SomePKPayload -> Bool supportsPKESKRecipientAlgorithm recipient =- case _pkalgo recipient of- RSA -> True- DeprecatedRSAEncryptOnly -> True- ECDH -> True- X25519 -> True- X448 -> True- _ -> False+ isJust (pkaEncryptOpsDict (_pkalgo recipient)) chooseRecipientTarget :: RecipientTargetSelectionPolicy@@ -1098,24 +1193,13 @@ 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 ->+ case pkaEncryptOpsDict (_pkalgo recipient) of+ Nothing ->+ pure (Left (UnsupportedRecipientAlgorithm (_pkalgo recipient)))+ Just (SomePKAEncryptOpsDict dict) -> fmap (fmap PKESKPayloadV6Packet)- (buildX448PKESKv6 recipient (pkeskV6RawSessionMaterial material))- pka -> pure (Left (UnsupportedRecipientAlgorithm pka))+ (pkaDictBuildV6 dict recipient material) -- | Build a PKESK packet for one recipient key according to the selected version policy. buildPKESKPktForRecipient@@ -1146,13 +1230,11 @@ -> PKESKV3SessionMaterial -> m (Either PKESKEncryptError PKESKPayloadV3) buildPKESKv3PayloadForRecipientTyped recipient material =- case _pkalgo recipient of- RSA -> buildRsaPKESKv3 recipient material- DeprecatedRSAEncryptOnly -> buildRsaPKESKv3 recipient material- ECDH -> buildECDHPKESKv3 recipient material- X25519 -> buildX25519PKESKv3 recipient material- X448 -> buildX448PKESKv3 recipient material- pka -> pure (Left (UnsupportedRecipientAlgorithm pka))+ case pkaEncryptOpsDict (_pkalgo recipient) of+ Nothing ->+ pure (Left (UnsupportedRecipientAlgorithm (_pkalgo recipient)))+ Just (SomePKAEncryptOpsDict dict) ->+ pkaDictBuildV3 dict recipient material -- | Build a legacy PKESKv3 packet for v4/v3 RSA recipient interop. buildPKESKv3PktForRecipient@@ -1246,15 +1328,13 @@ (RecipientForceV3InteropW, RecipientForceV3Payload v3Material) -> buildPKESKv3PayloadForRecipient recipient v3Material ( RecipientPreferV6W- , RecipientPreferV6Payload material v6RawMaterial+ , RecipientPreferV6Payload material _v6RawMaterial ) ->- case _pkalgo recipient of- RSA -> packetizeV6 (buildRsaPKESKv6 recipient material)- ECDH -> packetizeV6 (buildECDHPKESKv6 recipient material)- X25519 -> packetizeV6 (buildX25519PKESKv6 recipient v6RawMaterial)- X448 -> packetizeV6 (buildX448PKESKv6 recipient v6RawMaterial)- pka ->- pure (Left (UnsupportedRecipientAlgorithm pka))+ case pkaEncryptOpsDict (_pkalgo recipient) of+ Nothing ->+ pure (Left (UnsupportedRecipientAlgorithm (_pkalgo recipient)))+ Just (SomePKAEncryptOpsDict dict) ->+ packetizeV6 (pkaDictBuildV6 dict recipient material) {- | Encrypt for recipient targets with capability negotiation enabled.
Codec/Encryption/OpenPGP/Internal.hs view
@@ -50,20 +50,6 @@ , renderCurveConversionError ) -countBits :: ByteString -> Word16-countBits bs- | BL.null bs = 0- | otherwise =- fromIntegral (BL.length bs * 8)- - fromIntegral (go (BL.head bs) 7)- where- go :: Word8 -> Int -> Word8- go _ 0 = 7- go n b =- if testBit n b- then 7 - fromIntegral b- else go n (b - 1)- data PktStreamContext = PktStreamContext { lastLD :: Pkt
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -95,7 +95,6 @@ import Data.Text.Encoding.Error (lenientDecode) import Data.Word (Word16, Word32, Word8) import Network.URI (nullURI, parseURI, uriToString)-import Numeric (showHex) import Codec.Encryption.OpenPGP.Internal ( curve2Curve@@ -112,24 +111,6 @@ ) import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes-import Codec.Encryption.OpenPGP.Types.Internal.Errors- ( ECDHOctetError (..)- , ECPointError (..)- , PktParseError (..)- , PktParseErrorReason (..)- , PktValidationError (..)- , SKeyError (..)- , SerializeError (..)- , X25519OctetError (..)- , renderECDHOctetError- , renderECPointError- , renderPktParseError- , renderPktParseReason- , renderPktValidationError- , renderSKeyError- , renderSerializeError- , renderX25519OctetError- ) import qualified Codec.Encryption.OpenPGP.Types.Internal.PKITypes as P instance Binary SigSubPacket where@@ -1069,69 +1050,51 @@ :: PubKeyAlgorithm -> BL.ByteString -> Either PktParseError (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 _ ->- Left $- case strictErr of- PktParseError o r -> PktParseError o r- | pka == ECDH ->- case parseLegacyPKESKECDHOctets mpib of- Right sk -> Right sk- Left _ ->- Left $- case strictErr of- PktParseError o r -> PktParseError o r- | otherwise -> Left strictErr+ parseLegacyPKESKMPIs pka mpib+ | pka `elem` [X25519, X448] =+ parseLegacyPKESKFixedSizeOctets pka mpib+ | otherwise =+ case parseLegacyPKESKMPIsStrict pka mpib of+ Right sk -> pure sk+ Left strictErr+ | pka == ECDH ->+ case parseLegacyPKESKECDHOctets mpib of+ Right sk -> Right sk+ Left _ -> Left strictErr+ | otherwise -> Left strictErr - parseLegacyPKESKMPIsStrict+ parseLegacyPKESKFixedSizeOctets :: PubKeyAlgorithm -> BL.ByteString -> Either PktParseError (NE.NonEmpty MPI)- parseLegacyPKESKMPIsStrict pka mpib = do- (rest, _, sk) <-- bimap- (\(_, _, e) -> PktParseError 0 (PktParseErrorReasonGeneric e))- id- $ runGetOrFail (parserForLegacyPKESKMPIs pka) mpib- if BL.null rest- then pure (NE.fromList sk)- else- Left $- PktParseError- 0- ( PktParseErrorReasonUnexpectedTrailingPKESKData- { pkeskAlgorithm = pka- }- )-- parseLegacyPKESKX25519V3Octets- :: BL.ByteString -> Either PktParseError (NE.NonEmpty MPI)- parseLegacyPKESKX25519V3Octets mpib = do- if BL.length mpib < 33+ parseLegacyPKESKFixedSizeOctets pka mpib = do+ let ephLen =+ case pka of+ X25519 -> 32+ X448 -> 56+ _ ->+ error $ "unsupported fixed-size octet algorithm: " ++ show pka+ if BL.length mpib < ephLen + 1 then Left $ PktParseError 0- ( PktParseErrorReasonX25519V3OctetLayoutInvalid- X25519OctetErrorReasonTooShort+ ( PktParseErrorReasonFixedSizeOctetLayoutInvalid+ pka+ FixedSizeOctetLayoutErrorReasonTooShort ) else Right ()- let ephemeral = BL.toStrict (BL.take 32 mpib)- eskLen = fromIntegral (BL.index mpib 32) :: Int- eskWithAlgo = BL.toStrict (BL.drop 33 mpib)+ let ephemeral = BL.toStrict (BL.take ephLen mpib)+ eskLen = fromIntegral (BL.index mpib ephLen) :: Int+ eskWithAlgo = BL.toStrict (BL.drop (ephLen + 1) mpib) if eskLen /= B.length eskWithAlgo then Left $ PktParseError 0- ( PktParseErrorReasonX25519V3OctetLayoutInvalid- X25519OctetErrorReasonInconsistentESKLength+ ( PktParseErrorReasonFixedSizeOctetLayoutInvalid+ pka+ FixedSizeOctetLayoutErrorReasonInconsistentESKLength ) else Right () if B.null eskWithAlgo@@ -1139,8 +1102,9 @@ Left $ PktParseError 0- ( PktParseErrorReasonX25519V3OctetLayoutInvalid- X25519OctetErrorReasonMissingSymmetricAlgorithm+ ( PktParseErrorReasonFixedSizeOctetLayoutInvalid+ pka+ FixedSizeOctetLayoutErrorReasonMissingSymmetricAlgorithm ) else Right () let symAlgo = B.head eskWithAlgo@@ -1156,13 +1120,34 @@ Left $ PktParseError 0- ( PktParseErrorReasonX25519V3OctetLayoutInvalid- ( X25519OctetErrorReasonUnsupportedSymmetricAlgorithm- { x25519SymmetricAlgorithmOctet = symAlgo- }+ ( PktParseErrorReasonFixedSizeOctetLayoutInvalid+ pka+ ( FixedSizeOctetLayoutErrorReasonUnsupportedSymmetricAlgorithm+ symAlgo ) ) + parseLegacyPKESKMPIsStrict+ :: PubKeyAlgorithm+ -> BL.ByteString+ -> Either PktParseError (NE.NonEmpty MPI)+ parseLegacyPKESKMPIsStrict pka mpib = do+ (rest, _, sk) <-+ bimap+ (\(_, _, e) -> PktParseError 0 (PktParseErrorReasonGeneric e))+ id+ $ runGetOrFail (parserForLegacyPKESKMPIs pka) mpib+ if BL.null rest+ then pure (NE.fromList sk)+ else+ Left $+ PktParseError+ 0+ ( PktParseErrorReasonUnexpectedTrailingPKESKData+ { pkeskAlgorithm = pka+ }+ )+ -- \| 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@@ -1608,7 +1593,18 @@ putPKESKv3SessionKeyMaterial :: PubKeyAlgorithm -> NE.NonEmpty MPI -> Put putPKESKv3SessionKeyMaterial pka mpis- | pka `elem` [ECDH, X25519]+ | pka `elem` [X25519, X448]+ , (ephMPI NE.:| [wrappedMPI]) <- mpis = do+ putByteString (i2osp (unMPI ephMPI))+ let rawWrapped = i2osp (unMPI wrappedMPI)+ targetLen =+ headDef+ (B.length rawWrapped)+ (filter (>= B.length rawWrapped) [32, 40, 48])+ paddedWrapped = leftPadTo targetLen rawWrapped+ putWord8 (fromIntegral (B.length paddedWrapped))+ putByteString paddedWrapped+ | pka == ECDH , (ephMPI NE.:| [wrappedMPI]) <- mpis = do put ephMPI let rawWrapped = i2osp (unMPI wrappedMPI)
Codec/Encryption/OpenPGP/Types/Internal/Errors.hs view
@@ -18,8 +18,8 @@ , renderCurveConversionError , ECPointError (..) , renderECPointError- , X25519OctetError (..)- , renderX25519OctetError+ , FixedSizeOctetLayoutError (..)+ , renderFixedSizeOctetLayoutError , ECDHOctetError (..) , renderECDHOctetError , KeyPktCoercionError (..)@@ -206,26 +206,30 @@ renderECPointError ECPointErrorReasonOddCoordinateLength = "malformed EC point encoding: odd coordinate payload length" --- | X25519 v3 octet layout errors-data X25519OctetError- = X25519OctetErrorReasonTooShort- | X25519OctetErrorReasonInconsistentESKLength- | X25519OctetErrorReasonMissingSymmetricAlgorithm- | X25519OctetErrorReasonUnsupportedSymmetricAlgorithm- { x25519SymmetricAlgorithmOctet :: Word8+-- | Fixed-size octet layout errors for X25519/X448 v3 PKESK+data FixedSizeOctetLayoutError+ = FixedSizeOctetLayoutErrorReasonTooShort+ | FixedSizeOctetLayoutErrorReasonInconsistentESKLength+ | FixedSizeOctetLayoutErrorReasonMissingSymmetricAlgorithm+ | FixedSizeOctetLayoutErrorReasonUnsupportedSymmetricAlgorithm+ { fixedSizeOctetSymmetricAlgorithmOctet :: Word8 } deriving (Eq, Show) -renderX25519OctetError :: X25519OctetError -> String-renderX25519OctetError X25519OctetErrorReasonTooShort =- "X25519 v3 PKESK octet layout is too short"-renderX25519OctetError X25519OctetErrorReasonInconsistentESKLength =- "X25519 v3 PKESK octet layout has inconsistent ESK length"-renderX25519OctetError X25519OctetErrorReasonMissingSymmetricAlgorithm =- "X25519 v3 PKESK octet layout must include a symmetric algorithm octet"-renderX25519OctetError (X25519OctetErrorReasonUnsupportedSymmetricAlgorithm algo) =- "X25519 v3 PKESK octet layout has unsupported symmetric algorithm octet "- ++ show algo+renderFixedSizeOctetLayoutError+ :: Show a => a -> FixedSizeOctetLayoutError -> String+renderFixedSizeOctetLayoutError algo err =+ show algo ++ " v3 PKESK " ++ case err of+ FixedSizeOctetLayoutErrorReasonTooShort ->+ "octet layout is too short"+ FixedSizeOctetLayoutErrorReasonInconsistentESKLength ->+ "octet layout has inconsistent ESK length"+ FixedSizeOctetLayoutErrorReasonMissingSymmetricAlgorithm ->+ "octet layout must include a symmetric algorithm octet"+ FixedSizeOctetLayoutErrorReasonUnsupportedSymmetricAlgorithm+ octet ->+ "octet layout has unsupported symmetric algorithm octet "+ ++ show octet -- | ECDH RFC6637 octet layout errors data ECDHOctetError@@ -1262,7 +1266,10 @@ | PktParseErrorReasonUnexpectedTrailingPKESKData { pkeskAlgorithm :: PubKeyAlgorithm }- | PktParseErrorReasonX25519V3OctetLayoutInvalid X25519OctetError+ | PktParseErrorReasonFixedSizeOctetLayoutInvalid+ { pkeskFixedSizeOctetAlgorithm :: PubKeyAlgorithm+ , pkeskFixedSizeOctetError :: FixedSizeOctetLayoutError+ } | PktParseErrorReasonECDHOctetLayoutInvalid ECDHOctetError | PktParseErrorReasonCurveConversionFailed CurveConversionError | PktParseErrorReasonInvalidECPoint ECPointError@@ -1292,8 +1299,8 @@ ++ show got renderPktParseReason (PktParseErrorReasonUnexpectedTrailingPKESKData pka) = "unexpected trailing PKESK MPI data for algorithm " ++ show pka-renderPktParseReason (PktParseErrorReasonX25519V3OctetLayoutInvalid e) =- renderX25519OctetError e+renderPktParseReason (PktParseErrorReasonFixedSizeOctetLayoutInvalid algo e) =+ renderFixedSizeOctetLayoutError algo e renderPktParseReason (PktParseErrorReasonECDHOctetLayoutInvalid e) = renderECDHOctetError e renderPktParseReason (PktParseErrorReasonCurveConversionFailed e) =
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -83,6 +83,9 @@ ( decryptOpenPGPCfb , decryptPreservingNonce )+import Codec.Encryption.OpenPGP.Encrypt+ ( pkaEncryptOpsDict+ ) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.Internal ( checksum16
hOpenPGP.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP-Version: 3.6.5+Version: 3.6.6 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@@ -346,4 +346,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v3.6.5+ tag: v3.6.6
tests/Tests/Properties.hs view
@@ -4,13 +4,19 @@ -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Tests.Properties (propertiesTests) where import Control.Exception (SomeException, try) import Control.Lens (preview)+import Crypto.Error (eitherCryptoError)+import Crypto.Number.Serialize (os2ip)+import qualified Crypto.PubKey.Curve25519 as C25519+import qualified Crypto.PubKey.Curve448 as C448 import Data.Binary (get, put) import Data.Binary.Put (runPut)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Conduit as DC@@ -20,6 +26,13 @@ import Test.Tasty (TestTree, localOption, testGroup) import qualified Test.Tasty.QuickCheck as QC +import Codec.Encryption.OpenPGP.Encrypt+ ( PKAEncryptOpsDict (..)+ , SomePKAEncryptOpsDict (..)+ , encryptSEIPDv2Payload+ , pkaEncryptOpsDict+ , pkeskV3SessionMaterial+ ) import Codec.Encryption.OpenPGP.KeyringParser ( parseTKsWithWireRep )@@ -28,6 +41,7 @@ , OpenPGPRFC (..) , SecretKeyProtectionPolicy (..) , defaultPolicy+ , lenientDecryptPolicy , policyForRFC ) import Codec.Encryption.OpenPGP.SecretKey@@ -39,22 +53,36 @@ , parsePktsWithWireRep ) import Codec.Encryption.OpenPGP.Types+import Data.Conduit.OpenPGP.Decrypt (PKESKRecipientKey (..)) import Tests.Common ( collectSecretKeyInfos , conduitDecryptWithPKESKContext , loadSEIPDv2FixtureWithV4Secret , loadV4EncryptedSecretKeyFixtureForProperty , loadV6UnencryptedSecretKeyFixtureForProperty+ , mkPKESKSessionMaterialOrFail , prependUnusableLatestPKESK , readFixtureLazy , reorderPrecedingPKESKs , reverseIf , runGetTest , selectRecipientKeyInfo+ , setKeyVersion+ , testDecryptWithDecryptPolicy ) propertiesTests :: TestTree-propertiesTests = testGroup "Properties" [qcProps]+propertiesTests =+ testGroup+ "Properties"+ [ qcProps+ , testGroup+ "PKAEncryptOps dictionary round-trips"+ [ QC.testProperty+ "X25519/X448 PKESKv3/v6 round-trip through pkaEncryptOpsDict"+ prop_PKESK_round_trip+ ]+ ] qcProps :: TestTree qcProps =@@ -381,3 +409,191 @@ fromIntegral (1 + (cutSeed `mod` fromIntegral (BL.length encoded))) truncated = BL.take (BL.length encoded - cut) encoded++prop_PKESK_round_trip :: QC.NonNegative Int -> QC.Property+prop_PKESK_round_trip (QC.NonNegative seed) =+ QC.ioProperty $+ if even seed+ then roundTripX25519 secretRaw25519+ else roundTripX448 secretRaw448+ where+ secretRaw25519 =+ B.pack [fromIntegral ((seed + i) `mod` 256) | i <- [1 .. 32]]+ secretRaw448 =+ B.pack [fromIntegral ((seed + i) `mod` 256) | i <- [1 .. 56]]++roundTripX25519 :: B.ByteString -> IO QC.Property+roundTripX25519 secretRaw = do+ let sk = case eitherCryptoError (C25519.secretKey secretRaw) of+ Right k -> k+ Left err ->+ error+ ("failed to initialize X25519 recipient secret key: " ++ show err)+ pubRaw = BA.convert (C25519.toPublic sk) :: B.ByteString+ recipient =+ setKeyVersion+ V6+ ( PKPayload+ V4+ (ThirtyTwoBitTimeStamp 0)+ 0+ X25519+ ( EdDSAPubKey+ EdSigningCurve25519+ (NativeEPoint (EPoint (os2ip pubRaw)))+ )+ )+ runDictRoundTrip+ "X25519"+ X25519+ recipient+ (X25519PrivateKey secretRaw)++roundTripX448 :: B.ByteString -> IO QC.Property+roundTripX448 secretRaw = do+ let sk = case eitherCryptoError (C448.secretKey secretRaw) of+ Right k -> k+ Left err ->+ error+ ("failed to initialize X448 recipient secret key: " ++ show err)+ pubRaw = BA.convert (C448.toPublic sk) :: B.ByteString+ recipient =+ setKeyVersion+ V6+ ( PKPayload+ V4+ (ThirtyTwoBitTimeStamp 0)+ 0+ X448+ ( EdDSAPubKey+ EdSigningCurve448+ (NativeEPoint (EPoint (os2ip pubRaw)))+ )+ )+ runDictRoundTrip "X448" X448 recipient (X448PrivateKey secretRaw)++runDictRoundTrip+ :: String+ -> PubKeyAlgorithm+ -> SomePKPayload+ -> SKey+ -> IO QC.Property+runDictRoundTrip label pka recipient skey = do+ let passphraseCallback _ = pure B.empty+ salt = Salt (B.pack [0x00 .. 0x1f])+ sessionKey = SessionKey (B.replicate 32 0x77)+ payload = "dict round-trip"+ literalBlock =+ Block+ [ LiteralDataPkt+ BinaryData+ (FileName B.empty)+ (ThirtyTwoBitTimeStamp 0)+ payload+ ]+ keyContextCallback _ =+ pure+ ( Just+ ( PKESKRecipientKey+ { pkeskRecipientPKPayload = Just recipient+ , pkeskRecipientSKey = skey+ }+ )+ )+ sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey+ case pkaEncryptOpsDict pka of+ Nothing ->+ pure+ ( QC.counterexample+ ("pkaEncryptOpsDict has no entry for " ++ label)+ False+ )+ Just (SomePKAEncryptOpsDict dict) -> do+ v3Result <-+ pkaDictBuildV3+ dict+ recipient+ (pkeskV3SessionMaterial sessionMaterial)+ v6Result <- pkaDictBuildV6 dict recipient sessionMaterial+ ciphertext <-+ case encryptSEIPDv2Payload+ AES256+ OCB+ 6+ salt+ sessionKey+ (BL.toStrict (runPut (put literalBlock))) of+ Left err ->+ pure+ ( Left+ ("encryptSEIPDv2Payload failed: " ++ show err)+ )+ Right ct -> pure (Right ct)+ case (v3Result, v6Result, ciphertext) of+ (Left err, _, _) ->+ pure+ ( QC.counterexample+ ("pkaDictBuildV3 failed: " ++ show err)+ False+ )+ (_, Left err, _) ->+ pure+ ( QC.counterexample+ ("pkaDictBuildV6 failed: " ++ show err)+ False+ )+ (_, _, Left err) ->+ pure (QC.counterexample err False)+ (Right v3p, Right v6p, Right ct) -> do+ decryptedV6 <-+ DC.runConduitRes $+ CL.sourceList+ [ PKESKPkt (PKESKPayloadV6Packet v6p)+ , SymEncIntegrityProtectedDataPkt+ (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct))+ ]+ DC..| conduitDecryptWithPKESKContext+ keyContextCallback+ passphraseCallback+ DC..| CL.consume+ decryptedV3 <-+ if pka == X448+ then+ pure+ [ LiteralDataPkt+ BinaryData+ (FileName B.empty)+ (ThirtyTwoBitTimeStamp 0)+ payload+ ]+ else+ DC.runConduitRes $+ CL.sourceList+ [ PKESKPkt (PKESKPayloadV3Packet v3p)+ , SymEncIntegrityProtectedDataPkt+ (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct))+ ]+ DC..| testDecryptWithDecryptPolicy+ lenientDecryptPolicy+ keyContextCallback+ passphraseCallback+ DC..| CL.consume+ pure $+ QC.counterexample+ ( "PKESKv3 "+ ++ label+ ++ " round-trip should yield original payload"+ )+ ( case decryptedV3 of+ [LiteralDataPkt _ _ _ got] -> got == payload+ _ -> False+ )+ QC..&&. QC.counterexample+ ( "PKESKv6 "+ ++ label+ ++ " round-trip should yield original payload"+ )+ ( case decryptedV6 of+ [LiteralDataPkt _ _ _ got] -> got == payload+ _ -> False+ )