hOpenPGP-3.6.6: tests/Tests/Properties.hs
-- 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 #-}
{-# 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
import qualified Data.Conduit.List as CL
import Data.Maybe (isNothing)
import Data.Word (Word8)
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
)
import Codec.Encryption.OpenPGP.Policy
( OpenPGPPolicy (..)
, OpenPGPRFC (..)
, SecretKeyProtectionPolicy (..)
, defaultPolicy
, lenientDecryptPolicy
, policyForRFC
)
import Codec.Encryption.OpenPGP.SecretKey
( decryptSecretKeyAddendum
, encryptSecretKeyWithPolicy
)
import Codec.Encryption.OpenPGP.Serialize
( parsePktsEither
, 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
, testGroup
"PKAEncryptOps dictionary round-trips"
[ QC.testProperty
"X25519/X448 PKESKv3/v6 round-trip through pkaEncryptOpsDict"
prop_PKESK_round_trip
]
]
qcProps :: TestTree
qcProps =
testGroup
"(checked by QuickCheck)"
[ QC.testProperty "PKESKv3 packet serialization-deserialization" $ \pkesk ->
Right (pkesk :: PKESK 'PKESKV3)
== runGetTest get (runPut (put pkesk))
, QC.testProperty "PKESKv6 packet serialization-deserialization" $ \pkesk ->
Right (pkesk :: PKESK 'PKESKV6)
== runGetTest get (runPut (put pkesk))
, QC.testProperty "Signature packet serialization-deserialization" $ \sig ->
( isNothing
(preview _SigVOther (_signaturePayload (sig :: Signature)))
)
QC.==> Right (sig :: Signature) == runGetTest get (runPut (put sig))
, QC.testProperty "UserId packet serialization-deserialization" $ \uid ->
Right (uid :: UserId) == runGetTest 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.toStrict
(BL.pack (map (fromIntegral . fromEnum) passphraseChars))
encryptedResult <-
encryptSecretKeyWithPolicy
defaultPolicy
pkp
expectedSKey
(Passphrase passphrase)
pure $
case encryptedResult of
Left err ->
QC.counterexample
("encryptPrivateKey failed: " ++ show err)
False
Right encryptedSKA ->
case decryptSecretKeyAddendum pkp encryptedSKA (Passphrase passphrase) of
Left err ->
QC.counterexample
("decryptSecretKeyAddendum failed: " ++ show err)
False
Right (skey, SUSUnprotected _ _) ->
QC.counterexample
"secret key material changed across encrypt/decrypt roundtrip"
(skey == expectedSKey)
Right other ->
QC.counterexample
( "expected SUSUnprotected 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 =
Just
SecretKeyProtectionPolicy
{ secretKeyDefaultSymmetricAlgorithm = AES256
, secretKeyDefaultAEADAlgorithm = OCB
, secretKeyDefaultS2KForSalt =
\salt ->
IteratedSalted
SHA512
(Salt8 (B.take 8 (unSalt salt)))
(IterationCount 65536)
, secretKeyS2KSaltOctets = 8
, secretKeyAEADNonceOctets = 16
}
}
encryptedResult <-
encryptSecretKeyWithPolicy
legacyOverridePolicy
pkp
expectedSKey
passphrase
pure $
case encryptedResult of
Left err ->
QC.counterexample
( "encryptPrivateKey failed under legacy override policy: "
++ show err
)
False
Right encryptedSKA ->
case decryptSecretKeyAddendum pkp encryptedSKA passphrase of
Left err ->
QC.counterexample
("decryptSecretKeyAddendum failed: " ++ show err)
False
Right (skey, SUSUnprotected _ _) ->
QC.counterexample
"v4 secret key material changed across encrypt/decrypt roundtrip"
(skey == expectedSKey)
Right other ->
QC.counterexample
( "expected SUSUnprotected after decrypting v4 encrypted key, got: "
++ show other
)
False
)
, QC.testProperty
"PKESKv6 typed recipient identifier preserves fingerprint"
propertyPKESKv6TypedRecipientIdentifier
, 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
]
propertyPKESKv6TypedRecipientIdentifier
:: Bool -> [Word8] -> QC.Property
propertyPKESKv6TypedRecipientIdentifier _ seedBytes =
QC.counterexample
"PKESKv6 typed recipient identifier should preserve fingerprint"
(fingerprintMatches)
where
targetLen = 32
ridBody = B.pack (take targetLen (seedBytes ++ repeat 0x00))
fp = Fingerprint ridBody
payload =
PKESKPayloadV6Packet
(PKESKPayloadV6 (Just (V6, fp)) RSA (EncryptedSessionKey "esk"))
fingerprintMatches = case payload of
PKESKPayloadV6Packet (PKESKPayloadV6 (Just (_, fp')) _ _) -> fp == fp'
_ -> False
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
{ _tkStructuredRevs =
reverseIf
reverseDirect
(_tkStructuredRevs structured)
, _tkStructuredDirectKeySigs =
reverseIf
reverseDirect
(_tkStructuredDirectKeySigs 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 B.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
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
)