hOpenPGP-3.1: tests/Tests/Common.hs
-- 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 qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
( Armor (..)
, ArmorType (..)
)
import Control.Error.Util (hush)
import Control.Monad (join, unless, void)
import Control.Monad.Trans.Resource (ResourceT)
import qualified Crypto.Error as CE
import qualified Crypto.Hash as CH
import qualified Crypto.Hash.Algorithms as CHA
import Crypto.KDF.HKDF (expand, extract)
import Crypto.Number.Serialize (os2ip)
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Types as ECCT
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import Data.Bifunctor (bimap, first)
import Data.Binary (get)
import Data.Binary.Get
( Get
, getLazyByteString
, getRemainingLazyByteString
, getWord16be
, getWord8
, runGetOrFail
)
import Data.Binary.Put (putWord64be, runPut)
import Data.Bits (xor)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16.Lazy as B16L
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.Char (toUpper)
import qualified Data.Conduit as DC
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.List (isInfixOf)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (catMaybes, listToMaybe)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Word (Word32, Word64)
import System.IO.Unsafe (unsafePerformIO)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit
( Assertion
, assertBool
, assertEqual
, assertFailure
, testCase
)
import qualified "crypton" Crypto.Cipher.AES as AES
import qualified "crypton" Crypto.Cipher.Types as CCT
import Codec.Encryption.OpenPGP.Arbitrary ()
import Codec.Encryption.OpenPGP.Compression (decompressPkt)
import Codec.Encryption.OpenPGP.Encrypt
( PKESKSessionMaterial
, encodeOpenPGPSessionMaterial
, mkPKESKSessionMaterial
)
import Codec.Encryption.OpenPGP.Fingerprint
( eightOctetKeyID
, fingerprint
)
import Codec.Encryption.OpenPGP.Internal
( curveFromCurve
, curveToCurveoidBS
, emptyPSC
, lastPrimaryKey
, lastSubkey
, lastUIDorUAt
)
import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint)
import Codec.Encryption.OpenPGP.Message
( ClearPayload
, EncryptMessageOptions (..)
, EncryptedPayload
, MessageError (..)
, Passphrase
, RecoveredSessionMaterial (..)
, SessionMaterialExposure (..)
, VersionedPKPayload
, asV4PKPayload
, asV6PKPayload
, encryptMessage
)
import Codec.Encryption.OpenPGP.Policy
( DecryptPolicy
, defaultDecryptPolicy
)
import Codec.Encryption.OpenPGP.SecretKey
( decryptPrivateKey
)
import Codec.Encryption.OpenPGP.Serialize
( dearmorIfAsciiArmored
, parsePkts
)
import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig)
import Codec.Encryption.OpenPGP.Signatures
( VerificationError (..)
, renderSignError
, renderVerificationError
, signCertRevocationWithRSA
, signCertificationWithRSA
, signDataWithEd25519
, signDataWithRSA
, signDirectKeyWithRSA
, signKeyRevocationWithRSA
, signSubkeyRevocationWithRSA
)
import Codec.Encryption.OpenPGP.Types
import Data.Conduit.OpenPGP.Compression (conduitDecompress)
import Data.Conduit.OpenPGP.Decrypt
( DecryptKeyResolution (..)
, DecryptOptions (..)
, DecryptOutcome (..)
, PKESKRecipientKey (..)
)
import qualified Data.Conduit.OpenPGP.Decrypt as DCD
import Data.Conduit.OpenPGP.Keyring
( conduitToSomeTKsEither
, partitionSomeTKs
, sinkPublicKeyringMap
)
import Data.Conduit.OpenPGP.Message
( VerificationMode (..)
, VerificationOptions (..)
, VerificationPolicy (..)
, defaultVerificationOptions
, verifyMessage
, verifyMessagePackets
)
-- Test assertion helpers
assertTrue :: String -> Bool -> Assertion
assertTrue msg b = assertBool msg b
assertFalse :: String -> Bool -> Assertion
assertFalse msg b = assertBool msg (not b)
fixturePath :: FilePath -> FilePath
fixturePath file = "tests/data/" ++ file
readFixtureLazy :: FilePath -> IO BL.ByteString
readFixtureLazy = BL.readFile . fixturePath
readFixtureStrict :: FilePath -> IO B.ByteString
readFixtureStrict = B.readFile . fixturePath
readFixturePackets :: FilePath -> IO [Pkt]
readFixturePackets file =
DC.runConduitRes $
CB.sourceFile (fixturePath file)
DC..| conduitGet get
DC..| CL.consume
readFixtureDecompressedPackets :: FilePath -> IO [Pkt]
readFixtureDecompressedPackets file =
DC.runConduitRes $
CB.sourceFile (fixturePath file)
DC..| conduitGet get
DC..| conduitDecompress
DC..| CL.consume
loadFirstArmor :: FilePath -> IO Armor
loadFirstArmor file = do
armors <- loadArmor file
case armors of
(a : _) -> pure a
[] ->
assertFailure (file ++ " armor file contained no armor blocks")
>> fail "expected armor block"
readPKIPassphrase :: IO BL.ByteString
readPKIPassphrase = readFixtureLazy "pki-password.txt"
-- this needs a better name
runGet :: Get a -> BL.ByteString -> Either String a
runGet g bs = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail g bs)
extractV4SignatureAlgorithmFields
:: BL.ByteString -> Either String (PubKeyAlgorithm, B.ByteString)
extractV4SignatureAlgorithmFields =
runGet $ do
version <- getWord8
if version /= 4
then
fail
("expected v4 signature payload, got version " ++ show version)
else do
_ <- getWord8 -- sig type
pka <- getWord8
_ <- getWord8 -- hash algo
hlen <- getWord16be
_ <- getLazyByteString (fromIntegral hlen)
ulen <- getWord16be
_ <- getLazyByteString (fromIntegral ulen)
_ <- getWord16be -- left16
algorithmFields <- getRemainingLazyByteString
pure (toFVal pka, BL.toStrict algorithmFields)
conduitDecrypt
:: (String -> IO BL.ByteString)
-> DC.ConduitT Pkt Pkt (ResourceT IO) ()
conduitDecrypt cb =
void $
DCD.conduitDecrypt
DecryptOptions
{ decryptOptionsKeyResolution = DecryptWithoutPKESK
, decryptOptionsPolicy = defaultDecryptPolicy
, decryptOptionsPassphraseCallback = cb
}
conduitDecryptWithPKESKContext
:: (Pkt -> IO (Maybe PKESKRecipientKey))
-> (String -> IO BL.ByteString)
-> DC.ConduitT Pkt Pkt (ResourceT IO) ()
conduitDecryptWithPKESKContext pkcb cb =
void $
DCD.conduitDecrypt
DecryptOptions
{ decryptOptionsKeyResolution =
DecryptWithUnwrapCandidatesCallback
(asPKESKUnwrapCandidatesCallback pkcb)
, decryptOptionsPolicy = defaultDecryptPolicy
, decryptOptionsPassphraseCallback = cb
}
conduitDecryptWithDecryptPolicy
:: DecryptPolicy
-> (Pkt -> IO (Maybe PKESKRecipientKey))
-> (String -> IO BL.ByteString)
-> DC.ConduitT Pkt Pkt (ResourceT IO) ()
conduitDecryptWithDecryptPolicy dp pkcb cb =
void $
DCD.conduitDecrypt
DecryptOptions
{ decryptOptionsKeyResolution =
DecryptWithUnwrapCandidatesCallback
(asPKESKUnwrapCandidatesCallback pkcb)
, decryptOptionsPolicy = dp
, decryptOptionsPassphraseCallback = cb
}
conduitDecryptChecked
:: (String -> IO BL.ByteString)
-> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome
conduitDecryptChecked cb =
DCD.conduitDecrypt
DecryptOptions
{ decryptOptionsKeyResolution = DecryptWithoutPKESK
, decryptOptionsPolicy = defaultDecryptPolicy
, decryptOptionsPassphraseCallback = cb
}
conduitDecryptCheckedWithDecryptPolicy
:: DecryptPolicy
-> (Pkt -> IO (Maybe PKESKRecipientKey))
-> (String -> IO BL.ByteString)
-> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome
conduitDecryptCheckedWithDecryptPolicy dp pkcb cb =
DCD.conduitDecrypt
DecryptOptions
{ decryptOptionsKeyResolution =
DecryptWithUnwrapCandidatesCallback
(asPKESKUnwrapCandidatesCallback pkcb)
, decryptOptionsPolicy = dp
, decryptOptionsPassphraseCallback = cb
}
conduitDecryptWithCandidatesCallbackAndPolicy
:: DecryptPolicy
-> (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])
-> (String -> IO BL.ByteString)
-> DC.ConduitT Pkt Pkt (ResourceT IO) ()
conduitDecryptWithCandidatesCallbackAndPolicy dp candCb cb =
void $
DCD.conduitDecrypt
DecryptOptions
{ decryptOptionsKeyResolution =
DecryptWithUnwrapCandidatesCallback candCb
, decryptOptionsPolicy = dp
, decryptOptionsPassphraseCallback = cb
}
asPKESKUnwrapCandidatesCallback
:: (Pkt -> IO (Maybe PKESKRecipientKey))
-> KeyIdentifier
-> PubKeyAlgorithm
-> IO [PKESKRecipientKey]
asPKESKUnwrapCandidatesCallback pkcb keyIdentifier pka = do
mk <- pkcb (pkeskProbePacket keyIdentifier pka)
pure (maybe [] (: []) mk)
pkeskProbePacket :: KeyIdentifier -> PubKeyAlgorithm -> Pkt
pkeskProbePacket keyIdentifier pka =
case keyIdentifier of
KeyIdentifierWildcard ->
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId (BL.replicate 8 0))
pka
(MPI 0 :| [])
)
)
KeyIdentifierEightOctet rid ->
PKESKPkt
( PKESKPayloadV3Packet
(PKESKPayloadV3 3 rid pka (MPI 0 :| []))
)
KeyIdentifierFingerprint rid ->
PKESKPkt
( PKESKPayloadV6Packet
(PKESKPayloadV6 (unFingerprint rid) pka mempty)
)
readFixturePayload :: FilePath -> IO BL.ByteString
readFixturePayload fpr = do
bs <- BL.readFile ("tests/data/" ++ fpr)
case dearmorIfAsciiArmored bs of
Left err ->
assertFailure
("ASCII armor decode failed for " ++ fpr ++ ": " ++ err)
>> pure mempty
Right (_, payload) -> pure payload
testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized
:: Assertion
testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized = do
secretPackets <-
DC.runConduitRes $
CB.sourceFile "tests/data/unencrypted.seckey"
DC..| conduitGet get
DC..| CL.consume
(publicKey, privateKey) <-
case secretPackets of
(SecretKeyPkt pkp ska : _) ->
case (_pubkey pkp, ska) of
( RSAPubKey (RSA_PublicKey pub)
, SUUnencrypted (RSAPrivateKey (RSA_PrivateKey prv)) _
) ->
pure (pub, prv)
_ ->
assertFailure
"unencrypted.seckey did not contain a parseable unencrypted RSA key pair"
>> fail "expected RSA key pair from parsed secret key packet"
_ ->
assertFailure
"unencrypted.seckey did not begin with a secret key packet"
>> fail "expected secret key packet"
let plaintext = "pkcs1-v1.5 regression payload" :: B.ByteString
encrypted <-
( P15.encrypt publicKey plaintext
:: IO (Either RSA.Error B.ByteString)
)
ciphertext <-
case encrypted of
Left err ->
assertFailure ("RSA PKCS#1 v1.5 encryption failed: " ++ show err)
>> pure mempty
Right ct -> pure ct
decrypted <-
( P15.decryptSafer privateKey ciphertext
:: IO (Either RSA.Error B.ByteString)
)
case decrypted of
Left RSA.MessageNotRecognized ->
assertFailure
"parsed RSA private key decryption failed with MessageNotRecognized"
Left err ->
assertFailure
("parsed RSA private key decryption failed: " ++ show err)
Right got ->
assertEqual
"parsed RSA private key decrypts PKCS#1 v1.5 payload"
plaintext
got
testEncodeOpenPGPSessionMaterial :: Assertion
testEncodeOpenPGPSessionMaterial = do
let keyBytes = B.pack [1 .. 32]
expected =
B.singleton (fromFVal AES256)
<> keyBytes
<> encodeChecksum16 keyBytes
case encodeOpenPGPSessionMaterial AES256 (SessionKey keyBytes) of
Left err ->
assertFailure
("encodeOpenPGPSessionMaterial failed: " ++ show err)
Right encoded ->
assertEqual "OpenPGP session material encoding" expected encoded
mkPKESKSessionMaterialOrFail
:: SymmetricAlgorithm -> SessionKey -> IO PKESKSessionMaterial
mkPKESKSessionMaterialOrFail symalgo sessionKey =
case mkPKESKSessionMaterial symalgo sessionKey of
Left err ->
assertFailure ("mkPKESKSessionMaterial failed: " ++ show err)
>> fail "mkPKESKSessionMaterial failed"
Right material -> pure material
armorPayload :: Armor -> BL.ByteString
armorPayload (Armor _ _ bs) = BL.fromStrict (BLC8.toStrict bs)
armorPayload (ClearSigned _ _ inner) = armorPayload inner
selectRecipientKeyInfo
:: Pkt -> [PKESKRecipientKey] -> Maybe PKESKRecipientKey
selectRecipientKeyInfo (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) keyInfos =
listToMaybe
[ keyInfo
| keyInfo <- keyInfos
, supportsPKESKAlgorithm pka keyInfo
, matchesRecipientIdentifier rid keyInfo
]
selectRecipientKeyInfo (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) keyInfos
| isWildcardEightOctetKeyId rid =
listToMaybe
[ keyInfo | keyInfo <- keyInfos, supportsPKESKAlgorithm pka keyInfo
]
| otherwise =
listToMaybe
[ keyInfo
| keyInfo <- keyInfos
, supportsPKESKAlgorithm pka keyInfo
, matchesEightOctetRecipientKeyId rid keyInfo
]
selectRecipientKeyInfo _ keyInfos = listToMaybe keyInfos
isWildcardEightOctetKeyId :: EightOctetKeyId -> Bool
isWildcardEightOctetKeyId (EightOctetKeyId rid) =
BL.length rid == 8 && BL.all (== 0) rid
matchesEightOctetRecipientKeyId
:: EightOctetKeyId -> PKESKRecipientKey -> Bool
matchesEightOctetRecipientKeyId (EightOctetKeyId rid) keyInfo =
case pkeskRecipientPKPayload keyInfo of
Nothing -> False
Just pkp ->
let fingerprintBytes = unFingerprint (fingerprint pkp)
in BL.length fingerprintBytes >= 8
&& BL.drop (BL.length fingerprintBytes - 8) fingerprintBytes == rid
supportsPKESKAlgorithm
:: PubKeyAlgorithm -> PKESKRecipientKey -> Bool
supportsPKESKAlgorithm pka keyInfo =
case pkeskRecipientSKey keyInfo of
RSAPrivateKey {} -> pka == RSA
ECDHPrivateKey {} -> pka == ECDH || pka == X25519
X25519PrivateKey {} -> pka == X25519
X448PrivateKey {} -> pka == X448
_ -> False
matchesRecipientIdentifier
:: BL.ByteString -> PKESKRecipientKey -> Bool
matchesRecipientIdentifier rid keyInfo =
case pkeskRecipientPKPayload keyInfo of
Nothing -> False
Just pkp ->
let fingerprintBytes = BL.toStrict (unFingerprint (fingerprint pkp))
identifier = BL.toStrict rid
in identifier == fingerprintBytes
|| identifier == B.cons 0x04 fingerprintBytes
|| identifier == B.cons 0x06 fingerprintBytes
buildECDHKDFParamForTest
:: SomePKPayload
-> PubKeyAlgorithm
-> ECCT.Curve
-> HashAlgorithm
-> SymmetricAlgorithm
-> B.ByteString
buildECDHKDFParamForTest recipientPKP pka curve kdfHA kdfSA =
B.singleton (fromIntegral (B.length curveOid))
<> curveOid
<> B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA]
<> "Anonymous Sender "
<> BL.toStrict (unFingerprint (fingerprint recipientPKP))
where
curveOid =
either
(const B.empty)
id
(curveToCurveoidBS (curveFromCurve curve))
buildCurve25519LegacyKdfParamForTest
:: SomePKPayload
-> PubKeyAlgorithm
-> HashAlgorithm
-> SymmetricAlgorithm
-> B.ByteString
buildCurve25519LegacyKdfParamForTest recipientPKP pka kdfHA kdfSA =
B.singleton (fromIntegral (B.length curveOid))
<> curveOid
<> B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA]
<> "Anonymous Sender "
<> BL.toStrict (unFingerprint (fingerprint recipientPKP))
where
curveOid = "\x2b\x06\x01\x04\x01\x97\x55\x01\x05\x01"
deriveECDHKekForTest
:: HashAlgorithm
-> SymmetricAlgorithm
-> B.ByteString
-> B.ByteString
-> B.ByteString
deriveECDHKekForTest kdfHA kdfSA sharedSecret kdfParam =
B.take (keyLengthForTest kdfSA) digest
where
digest =
case kdfHA of
SHA256 ->
BA.convert
( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)
:: CH.Digest CHA.SHA256
)
SHA384 ->
BA.convert
( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)
:: CH.Digest CHA.SHA384
)
SHA512 ->
BA.convert
( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)
:: CH.Digest CHA.SHA512
)
_ ->
BA.convert
( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)
:: CH.Digest CHA.SHA256
)
deriveX448KekForTest
:: B.ByteString
-> B.ByteString
-> B.ByteString
-> B.ByteString
deriveX448KekForTest ephemeralPublic recipientPublic sharedSecret =
let ikm = ephemeralPublic <> recipientPublic <> sharedSecret
prk = extract @CHA.SHA512 B.empty ikm
info = "OpenPGP X448" :: B.ByteString
in expand @CHA.SHA512 prk info 32
deriveX25519KekForTest
:: B.ByteString
-> B.ByteString
-> B.ByteString
-> B.ByteString
deriveX25519KekForTest ephemeralPublic recipientPublic sharedSecret =
let ikm = ephemeralPublic <> recipientPublic <> sharedSecret
prk = extract @CHA.SHA256 B.empty ikm
info = "OpenPGP X25519" :: B.ByteString
in expand @CHA.SHA256 prk info 16
keyLengthForTest :: SymmetricAlgorithm -> Int
keyLengthForTest AES128 = 16
keyLengthForTest AES192 = 24
keyLengthForTest AES256 = 32
keyLengthForTest _ = 16
aesKeyWrapRFC3394ForTest
:: SymmetricAlgorithm
-> B.ByteString
-> B.ByteString
-> B.ByteString
aesKeyWrapRFC3394ForTest sa kek plain =
case sa of
AES128 -> wrapWithCipher (initCipher kek :: AES.AES128) plain
AES192 -> wrapWithCipher (initCipher kek :: AES.AES192) plain
AES256 -> wrapWithCipher (initCipher kek :: AES.AES256) plain
_ -> error "unsupported KEK algorithm in test"
where
initCipher keyBytes =
case CE.eitherCryptoError (CCT.cipherInit keyBytes) of
Left err -> error ("cipher init failed: " ++ show err)
Right c -> c
wrapWithCipher cipher plainBytes =
let rs = chunksOf8ForTest plainBytes
n = length rs
a0 = B.replicate 8 0xA6
(aFinal, rFinal) =
foldl (\(a, r) j -> wrapRound cipher n j a r) (a0, rs) [0 .. 5]
in aFinal <> B.concat rFinal
wrapRound cipher n j a rs = foldl step (a, rs) [1 .. n]
where
step (aCurr, rCurr) i =
let b = CCT.ecbEncrypt cipher (aCurr <> (rCurr !! (i - 1)))
(aMsb, rLsb) = B.splitAt 8 b
t = fromIntegral (n * j + i) :: Word64
aNext = xorBSForTest aMsb (encodeWord64beForTest t)
in (aNext, replaceAtForTest (i - 1) rLsb rCurr)
encodeWord64beForTest :: Word64 -> B.ByteString
encodeWord64beForTest = BL.toStrict . runPut . putWord64be
chunksOf8ForTest :: B.ByteString -> [B.ByteString]
chunksOf8ForTest bs
| B.null bs = []
| otherwise =
let (h, t) = B.splitAt 8 bs
in h : chunksOf8ForTest t
replaceAtForTest :: Int -> a -> [a] -> [a]
replaceAtForTest idx x xs =
let (prefix, suffix) = splitAt idx xs
in case suffix of
[] -> xs
(_ : rest) -> prefix <> (x : rest)
xorBSForTest :: B.ByteString -> B.ByteString -> B.ByteString
xorBSForTest a b = B.pack (B.zipWith xor a b)
encodeChecksum16 :: B.ByteString -> B.ByteString
encodeChecksum16 bs =
B.pack
[fromIntegral (s `div` 256), fromIntegral (s `mod` 256)]
where
s =
B.foldl'
(\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Int))
0
bs
verifyMessageFromPackets
:: PublicKeyring -> BL.ByteString -> [Either String Verification]
verifyMessageFromPackets keyring signedMessage =
map (either (Left . renderVerificationError) Right) $
verifyMessagePackets
defaultVerificationOptions
{ verificationPolicy = VerifyInformational
, verificationMode = VerificationStreaming
}
keyring
( concatMap
(either (const []) id . decompressPkt)
(parsePkts signedMessage)
)
verifyMessageFromPacketsBatch
:: PublicKeyring -> BL.ByteString -> [Either String Verification]
verifyMessageFromPacketsBatch keyring signedMessage =
map (either (Left . renderVerificationError) Right) $
verifyMessagePackets
defaultVerificationOptions
{ verificationPolicy = VerifyInformational
, verificationMode = VerificationBatch
}
keyring
( concatMap
(either (const []) id . decompressPkt)
(parsePkts signedMessage)
)
verifyMessageFromBytestring
:: PublicKeyring -> BL.ByteString -> [Either String Verification]
verifyMessageFromBytestring keyring signedMessage =
map (either (Left . renderVerificationError) Right) $
verifyMessage
defaultVerificationOptions
{ verificationPolicy = VerifyInformational
, verificationMode = VerificationStreaming
}
keyring
signedMessage
verifyMessageFromBytestringBatch
:: PublicKeyring -> BL.ByteString -> [Either String Verification]
verifyMessageFromBytestringBatch keyring signedMessage =
map (either (Left . renderVerificationError) Right) $
verifyMessage
defaultVerificationOptions
{ verificationPolicy = VerifyInformational
, verificationMode = VerificationBatch
}
keyring
signedMessage
assertMessageVerification
:: (PublicKeyring -> BL.ByteString -> [Either String Verification])
-> FilePath
-> FilePath
-> [Fingerprint]
-> Assertion
assertMessageVerification verifier keyringFile messageFile issuers = do
kr <- loadKeyring keyringFile
signedMessage <- readFixtureLazy messageFile
let verification = verifier kr signedMessage
actual = map (fmap (fingerprint . _verificationSigner)) verification
assertEqual
(keyringFile ++ " for " ++ messageFile)
(map Right issuers)
actual
loadKeyring :: FilePath -> IO PublicKeyring
loadKeyring keyring =
DC.runConduitRes $
CB.sourceFile (fixturePath keyring)
DC..| conduitGet get
DC..| conduitToSomeTKsEither
DC..| CL.map (fmap someTKToPublicViewTK . join . hush)
DC..| CL.catMaybes
DC..| sinkPublicKeyringMap
loadAndDecompressPkts :: FilePath -> IO [Pkt]
loadAndDecompressPkts = readFixtureDecompressedPackets
loadArmor :: FilePath -> IO [Armor]
loadArmor file = do
armored <- readFixtureLazy file
case AA.decodeLazy armored :: Either String [Armor] of
Left err ->
assertFailure
("Failed to decode armored fixture " ++ file ++ ": " ++ err)
>> pure []
Right armors -> pure armors
encryptMessageDefault
:: SessionMaterialExposure
-> Passphrase
-> ClearPayload
-> Either
MessageError
(EncryptedPayload, Maybe RecoveredSessionMaterial)
encryptMessageDefault exposure passphrase payload =
encryptMessage
( RFC9580EncryptMessageOptions
{ rfc9580EncryptMessageExposure = exposure
, rfc9580EncryptMessageSymmetricAlgorithm = AES256
, rfc9580EncryptMessageS2K =
Argon2 (Salt16 (B.pack [0x80 .. 0x8f])) 1 4 15
, rfc9580EncryptMessageIV = IV "0123456789ABCDEF"
}
)
passphrase
payload
mkTestKeyring :: [TKUnknown] -> PublicKeyring
mkTestKeyring tks =
let someTKs = [stk | Right stk <- map fromUnknownToTKEither tks]
in fst (partitionSomeTKs someTKs)
addTimestampSeconds
:: ThirtyTwoBitTimeStamp -> Word32 -> ThirtyTwoBitTimeStamp
addTimestampSeconds (ThirtyTwoBitTimeStamp ts) seconds = ThirtyTwoBitTimeStamp (ts + seconds)
timestampToUTCTime :: ThirtyTwoBitTimeStamp -> UTCTime
timestampToUTCTime = posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp
signCertificationAt
:: SomePKPayload
-> RSA.PrivateKey
-> UserId
-> ThirtyTwoBitTimeStamp
-> [SigSubPacket]
-> IO SignaturePayload
signCertificationAt signer signingKey uid creationTime hashedExtras = do
(hashed, unhashed) <-
messageIssuerSubpacketsAt signer creationTime
case signCertificationWithRSA
GenericCert
signer
uid
(hashedExtras ++ hashed)
unhashed
signingKey of
Left err ->
assertFailure
("failed to sign certification: " ++ renderSignError err)
>> fail "expected certification signature"
Right sigPayload -> pure sigPayload
signCertificationRevocationAt
:: SomePKPayload
-> RSA.PrivateKey
-> UserId
-> ThirtyTwoBitTimeStamp
-> [SigSubPacket]
-> IO SignaturePayload
signCertificationRevocationAt signer signingKey uid creationTime hashedExtras = do
(hashed, unhashed) <-
messageIssuerSubpacketsAt signer creationTime
case signCertRevocationWithRSA
signer
uid
(hashedExtras ++ hashed)
unhashed
signingKey of
Left err ->
assertFailure
( "failed to sign certification revocation: "
++ renderSignError err
)
>> fail "expected certification revocation signature"
Right sigPayload -> pure sigPayload
messageIssuerSubpacketsAt
:: SomePKPayload
-> ThirtyTwoBitTimeStamp
-> IO ([SigSubPacket], [SigSubPacket])
messageIssuerSubpacketsAt signer creationTime =
case eightOctetKeyID signer of
Left err ->
assertFailure
("failed to derive issuer key id for timeline test: " ++ err)
>> fail "expected issuer key id"
Right issuerKeyId ->
pure
(
[ SigSubPacket False (SigCreationTime creationTime)
, SigSubPacket
False
(IssuerFingerprint IssuerFingerprintV4 (fingerprint signer))
]
, [SigSubPacket False (Issuer issuerKeyId)]
)
loadUnencryptedRsaSigner :: IO (SomePKPayload, RSA.PrivateKey)
loadUnencryptedRsaSigner = do
secretPackets <-
DC.runConduitRes $
CB.sourceFile "tests/data/unencrypted.seckey"
DC..| conduitGet get
DC..| CL.consume
case secretPackets of
(SecretKeyPkt pkp ska : _) ->
case ska of
SUUnencrypted (RSAPrivateKey (RSA_PrivateKey privateKey)) _ ->
pure (pkp, privateKey)
_ ->
assertFailure
"unencrypted.seckey did not contain an unencrypted RSA key"
>> fail "expected decrypted RSA private key"
_ ->
assertFailure
"unencrypted.seckey did not begin with a secret key packet"
>> fail "expected secret key packet"
loadUnencryptedRsaSignerV6 :: IO (SomePKPayload, RSA.PrivateKey)
loadUnencryptedRsaSignerV6 = do
(signer, signingKey) <- loadUnencryptedRsaSigner
pure (setKeyVersion V6 signer, signingKey)
setKeyVersion :: KeyVersion -> SomePKPayload -> SomePKPayload
setKeyVersion keyVersion (PKPayload _ ts v3e pka pubkey) =
PKPayload keyVersion ts v3e pka pubkey
setKeyTimestamp
:: ThirtyTwoBitTimeStamp -> SomePKPayload -> SomePKPayload
setKeyTimestamp ts (PKPayload keyVersion _ v3e pka pubkey) =
PKPayload keyVersion ts v3e pka pubkey
setPKAlgorithm
:: PubKeyAlgorithm -> SomePKPayload -> SomePKPayload
setPKAlgorithm algorithm (PKPayload keyVersion ts v3e _ pubkey) =
PKPayload keyVersion ts v3e algorithm pubkey
expectV4PKPayload
:: String -> SomePKPayload -> IO (VersionedPKPayload V4)
expectV4PKPayload label pk =
case asV4PKPayload pk of
Left err ->
assertFailure (label ++ " should have a v4 PKPayload: " ++ err)
>> fail "expected v4 PKPayload"
Right v4pk -> pure v4pk
expectV6PKPayload
:: String -> SomePKPayload -> IO (VersionedPKPayload V6)
expectV6PKPayload label pk =
case asV6PKPayload pk of
Left err ->
assertFailure (label ++ " should have a v6 PKPayload: " ++ err)
>> fail "expected v6 PKPayload"
Right v6pk -> pure v6pk
loadDeterministicEd25519Signer
:: IO (SomePKPayload, Ed25519.SecretKey)
loadDeterministicEd25519Signer = do
let seed = B.pack [1 .. 32]
secretKey <-
case CE.eitherCryptoError (Ed25519.secretKey seed) of
Left err ->
assertFailure
( "failed to initialize deterministic Ed25519 secret key: "
++ show err
)
>> fail "expected deterministic Ed25519 secret key"
Right sk -> pure sk
let publicKeyBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString
signer =
PKPayload
V4
0
0
EdDSA
( EdDSAPubKey
EdSigningCurve25519
( PrefixedNativeEPoint
(EPoint (os2ip (B.cons 0x40 publicKeyBytes)))
)
)
pure (signer, secretKey)
loadDeterministicEd25519SignerV6
:: IO (SomePKPayload, Ed25519.SecretKey)
loadDeterministicEd25519SignerV6 = do
let seed = B.pack [1 .. 32]
secretKey <-
case CE.eitherCryptoError (Ed25519.secretKey seed) of
Left err ->
assertFailure
( "failed to initialize deterministic Ed25519 secret key: "
++ show err
)
>> fail "expected deterministic Ed25519 secret key"
Right sk -> pure sk
let publicKeyBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString
signer =
PKPayload
V6
0
0
EdDSA
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip publicKeyBytes)))
)
pure (signer, secretKey)
loadDeterministicEd448Signer
:: IO (SomePKPayload, Ed448.SecretKey)
loadDeterministicEd448Signer = do
let seed = B.pack [1 .. 57]
secretKey <-
case CE.eitherCryptoError (Ed448.secretKey seed) of
Left err ->
assertFailure
( "failed to initialize deterministic Ed448 secret key: "
++ show err
)
>> fail "expected deterministic Ed448 secret key"
Right sk -> pure sk
let publicKeyBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString
signer =
PKPayload
V4
0
0
EdDSA
( EdDSAPubKey
EdSigningCurve448
( PrefixedNativeEPoint
(EPoint (os2ip (B.cons 0x40 publicKeyBytes)))
)
)
pure (signer, secretKey)
loadDeterministicEd448SignerV6
:: IO (SomePKPayload, Ed448.SecretKey)
loadDeterministicEd448SignerV6 = do
let seed = B.pack [1 .. 57]
secretKey <-
case CE.eitherCryptoError (Ed448.secretKey seed) of
Left err ->
assertFailure
( "failed to initialize deterministic Ed448 secret key: "
++ show err
)
>> fail "expected deterministic Ed448 secret key"
Right sk -> pure sk
let publicKeyBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString
signer =
PKPayload
V6
0
0
EdDSA
( EdDSAPubKey
EdSigningCurve448
(NativeEPoint (EPoint (os2ip publicKeyBytes)))
)
pure (signer, secretKey)
testSEIPDv2ForV4KeyArmor :: Assertion
testSEIPDv2ForV4KeyArmor = do
armors <- loadArmor "seipdv2-for-v4-key.pgp.aa"
armor <-
case armors of
[a] -> pure a
_ ->
assertFailure
"seipdv2-for-v4-key fixture should contain one armored payload"
>> fail "expected one armored payload"
payload <-
case armor of
Armor ArmorMessage _ p -> pure p
Armor atype _ _ ->
assertFailure
( "seipdv2-for-v4-key fixture should decode as a message block, got "
++ show atype
)
>> fail "expected message block"
_ ->
assertFailure
"seipdv2-for-v4-key fixture should decode as an armored payload"
>> fail "expected armored payload"
let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload))
case packets of
[ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))
, SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _)
] -> do
let ridHex = map toUpper (BLC8.unpack (B16L.encode rid))
if ridHex
`elem` [ "C8263FC6D676044B6E973959C2F2C2CAE30DE908"
, "04C8263FC6D676044B6E973959C2F2C2CAE30DE908"
]
then pure ()
else
assertFailure
( "seipdv2-for-v4-key fixture should target the expected recipient fingerprint, got "
++ ridHex
)
assertEqual
"seipdv2-for-v4-key fixture should use ECDH PKESKv6"
ECDH
pka
assertEqual
"seipdv2-for-v4-key fixture should use AES-256"
AES256
sa
assertEqual
"seipdv2-for-v4-key fixture should use OCB"
OCB
aa
assertEqual
"seipdv2-for-v4-key fixture should use 4KiB chunks"
6
chunkSize
_ ->
assertFailure
( "seipdv2-for-v4-key fixture should contain [PKESKPkt (PKESK6 ...), SymEncIntegrityProtectedDataPkt (SEIPD2 ...)], got: "
++ show packets
)
loadSEIPDv2FixtureWithV4Secret
:: FilePath -> IO ([Pkt], [Pkt], BL.ByteString)
loadSEIPDv2FixtureWithV4Secret fixture = do
messageArmor <- loadFirstArmor fixture
encryptedSecretArmor <-
loadFirstArmor "v4-encrypted-secret.pgp.aa"
passphrase <- readPKIPassphrase
pure
( parsePkts (armorPayload messageArmor)
, parsePkts (armorPayload encryptedSecretArmor)
, passphrase
)
forceVersionedRecipientIdentifier :: Pkt -> Pkt
forceVersionedRecipientIdentifier pkt =
case pkt of
PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk))
| BL.length rid == 20 ->
PKESKPkt
(PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x04 rid) pka esk))
| BL.length rid == 32 ->
PKESKPkt
(PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x06 rid) pka esk))
| otherwise -> pkt
_ -> pkt
selectRecipientKeyInfoByRawRecipientId
:: Pkt -> [PKESKRecipientKey] -> Maybe PKESKRecipientKey
selectRecipientKeyInfoByRawRecipientId (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) keyInfos =
listToMaybe
[ keyInfo
| keyInfo <- keyInfos
, supportsPKESKAlgorithm pka keyInfo
, matchesRawRecipientFingerprint rid keyInfo
]
selectRecipientKeyInfoByRawRecipientId (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) keyInfos
| isWildcardEightOctetKeyId rid =
listToMaybe
[ keyInfo | keyInfo <- keyInfos, supportsPKESKAlgorithm pka keyInfo
]
| otherwise =
listToMaybe
[ keyInfo
| keyInfo <- keyInfos
, supportsPKESKAlgorithm pka keyInfo
, matchesEightOctetRecipientKeyId rid keyInfo
]
selectRecipientKeyInfoByRawRecipientId _ keyInfos = listToMaybe keyInfos
matchesRawRecipientFingerprint
:: BL.ByteString -> PKESKRecipientKey -> Bool
matchesRawRecipientFingerprint rid keyInfo =
case pkeskRecipientPKPayload keyInfo of
Nothing -> False
Just pkp ->
BL.toStrict rid == BL.toStrict (unFingerprint (fingerprint pkp))
testSEIPDv2TwoRecipientsArmor :: Assertion
testSEIPDv2TwoRecipientsArmor =
testSEIPDv2RecipientFixtureArmor
"seipdv2-two-recipients.pgp.aa"
2
testSEIPDv2ThreeRecipientsArmor :: Assertion
testSEIPDv2ThreeRecipientsArmor =
testSEIPDv2RecipientFixtureArmor
"seipdv2-three-recipients.pgp.aa"
3
testSEIPDv2RecipientFixtureArmor :: FilePath -> Int -> Assertion
testSEIPDv2RecipientFixtureArmor file expectedRecipients = do
armors <- loadArmor file
armor <-
case armors of
[a] -> pure a
_ ->
assertFailure
(file ++ " fixture should contain one armored payload")
>> fail "expected one armored payload"
payload <-
case armor of
Armor ArmorMessage _ p -> pure p
Armor atype _ _ ->
assertFailure
( file
++ " fixture should decode as a message block, got "
++ show atype
)
>> fail "expected message block"
_ ->
assertFailure
(file ++ " fixture should decode as an armored payload")
>> fail "expected armored payload"
let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload))
pkesks =
[ (rid, pka)
| PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _)) <-
packets
]
x25519Esks =
[ BL.toStrict esk
| PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 esk)) <-
packets
]
x448Esks =
[ BL.toStrict esk
| PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 esk)) <-
packets
]
seipdv2Packets =
[ (sa, aa, chunkSize)
| SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _) <-
packets
]
assertEqual
( file
++ " fixture should contain expected number of PKESKv6 packets"
)
expectedRecipients
(length pkesks)
if all (\(_, pka) -> pka == ECDH || pka == X25519) pkesks
then pure ()
else
assertFailure
( file
++ " fixture should use only ECDH/X25519 PKESKv6 packets, got "
++ show (map snd pkesks)
)
if any ((== ECDH) . snd) pkesks
then pure ()
else
assertFailure
( file
++ " fixture should include an ECDH recipient for the v4 key"
)
mapM_ (assertX25519EskShape file) x25519Esks
mapM_ (assertX448EskShape file) x448Esks
if all
( \(rid, _) ->
let l = BL.length rid
in l == 20 || l == 21 || l == 32 || l == 33
)
pkesks
then pure ()
else
assertFailure
( file
++ " fixture should use 20/21-byte or 32/33-byte recipient identifiers"
)
case seipdv2Packets of
[(sa, aa, chunkSize)] -> do
assertEqual (file ++ " fixture should use AES-256") AES256 sa
assertEqual (file ++ " fixture should use OCB") OCB aa
assertEqual
(file ++ " fixture should use 4KiB chunks")
6
chunkSize
_ ->
assertFailure
( file
++ " fixture should contain one SymEncIntegrityProtectedDataV2 packet"
)
assertX25519EskShape :: FilePath -> B.ByteString -> Assertion
assertX25519EskShape file x25519Esk
| B.length x25519Esk < 33 =
assertFailure
( file
++ " X25519 PKESKv6 ESK should contain 32-octet ephemeral and wrapped-len"
)
| otherwise = do
let wrappedLen = fromIntegral (B.index x25519Esk 32) :: Int
wrapped = B.drop 33 x25519Esk
assertEqual
(file ++ " X25519 PKESKv6 wrapped length octet")
wrappedLen
(B.length wrapped)
assertX448EskShape :: FilePath -> B.ByteString -> Assertion
assertX448EskShape file x448Esk
| B.length x448Esk < 57 =
assertFailure
( file
++ " X448 PKESKv6 ESK should contain 56-octet ephemeral and wrapped-len"
)
| otherwise = do
let wrappedLen = fromIntegral (B.index x448Esk 56) :: Int
wrapped = B.drop 57 x448Esk
assertEqual
(file ++ " X448 PKESKv6 wrapped length octet")
wrappedLen
(B.length wrapped)
prependUnusableLatestPKESK :: [Pkt] -> [Pkt]
prependUnusableLatestPKESK packets =
let bogusRid = BL.pack (0x06 : replicate 32 0x99)
bogusPKESK =
PKESKPkt
(PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk"))
(eskPrefix, encryptedSuffix) = span isPrecedingESK packets
in eskPrefix ++ [bogusPKESK] ++ encryptedSuffix
reorderPrecedingPKESKs :: [Pkt] -> [Pkt]
reorderPrecedingPKESKs packets =
let (eskPrefix, encryptedSuffix) = span isPrecedingESK packets
reorderedPKESKs = reverse [pkt | pkt@(PKESKPkt _) <- eskPrefix]
in refillPKESKSlots eskPrefix reorderedPKESKs ++ encryptedSuffix
where
refillPKESKSlots [] _ = []
refillPKESKSlots (pkt : rest) pkesks =
case pkt of
PKESKPkt {} ->
case pkesks of
[] -> pkt : refillPKESKSlots rest []
(replacement : remaining) ->
replacement : refillPKESKSlots rest remaining
_ -> pkt : refillPKESKSlots rest pkesks
isPrecedingESK :: Pkt -> Bool
isPrecedingESK (PKESKPkt _) = True
isPrecedingESK (SKESKPkt _) = True
isPrecedingESK _ = False
messageVerificationFixtures
:: [(String, FilePath, FilePath, [Fingerprint])]
messageVerificationFixtures =
[
( "uncompressed-ops-dsa"
, "pubring.gpg"
, "uncompressed-ops-dsa.gpg"
, [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"]
)
,
( "uncompressed-ops-dsa-sha384"
, "pubring.gpg"
, "uncompressed-ops-dsa-sha384.txt.gpg"
, [fp "1EB2 0B2F 5A5C C3BE AFD6 E5CB 7732 CF98 8A63 EA86"]
)
,
( "uncompressed-ops-rsa"
, "pubring.gpg"
, "uncompressed-ops-rsa.gpg"
, [fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"]
)
,
( "compressedsig"
, "pubring.gpg"
, "compressedsig.gpg"
, [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]
)
,
( "compressedsig-zlib"
, "pubring.gpg"
, "compressedsig-zlib.gpg"
, [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]
)
,
( "compressedsig-bzip2"
, "pubring.gpg"
, "compressedsig-bzip2.gpg"
, [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]
)
]
certificateVerificationFixtures
:: [(String, FilePath, FilePath, [Fingerprint])]
certificateVerificationFixtures =
[
( "userid"
, "pubring.gpg"
, "minimized.gpg"
, [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]
)
,
( "subkey"
, "pubring.gpg"
, "subkey.gpg"
, [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]
)
,
( "primary key binding"
, "signing-subkey.gpg"
, "primary-binding.gpg"
, [fp "ED1B D216 F70E 5D5F 4444 48F9 B830 F2C4 83A9 9AE5"]
)
,
( "attribute"
, "pubring.gpg"
, "uat.gpg"
, [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]
)
,
( "primary key revocation"
, "pubring.gpg"
, "prikey-rev.gpg"
, [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]
)
,
( "subkey revocation"
, "pubring.gpg"
, "subkey-rev.gpg"
, [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]
)
,
( "6F87040E"
, "pubring.gpg"
, "6F87040E.pubkey"
,
[ fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"
, fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"
, fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"
]
)
,
( "6F87040E-cr"
, "pubring.gpg"
, "6F87040E-cr.pubkey"
,
[ fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"
, fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"
, fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"
, fp "CB79 3345 9F59 C70D F1C3 FBEE DEDC 3ECF 689A F56D"
, fp "AF95 E4D7 BAC5 21EE 9740 BED7 5E9F 1523 4132 62DC"
]
)
,
( "simple RSA secret key"
, "pubring.gpg"
, "simple.seckey"
, [fp "421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E"]
)
,
( "simple ECDSA public key"
, "ecdsa-key-without-ecdh.pubkey"
, "ecdsa-key-without-ecdh.pubkey"
, [fp "174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224"]
)
]
verificationFixtureGroup
:: String
-> (PublicKeyring -> BL.ByteString -> [Either String Verification])
-> [(String, FilePath, FilePath, [Fingerprint])]
-> TestTree
verificationFixtureGroup groupName verifier fixtures =
testGroup
groupName
[ testCase
name
( assertMessageVerification
verifier
keyringFile
messageFile
issuers
)
| (name, keyringFile, messageFile, issuers) <- fixtures
]
loadV6UnencryptedSecretKeyFixtureForProperty
:: IO (Either String (SomePKPayload, SKAddendum, SKey))
loadV6UnencryptedSecretKeyFixtureForProperty = do
armored <- readFixtureLazy "v6-secret.pgp.aa"
pure $ do
armors <-
first
("failed to decode v6 secret fixture: " ++)
(AA.decodeLazy armored)
armor <-
case armors of
(a : _) -> Right a
[] -> Left "v6-secret.pgp.aa should contain one armored payload"
let packets = parsePkts (armorPayload armor)
(pkp, ska) <-
case packets of
(SecretKeyPkt pkpayload skaddendum : _) -> Right (pkpayload, skaddendum)
_ -> Left "v6-secret.pgp.aa should begin with a secret key packet"
skey <-
case ska of
SUUnencrypted x _ -> Right x
_ ->
Left
"v6-secret.pgp.aa should contain unencrypted secret key material"
Right (pkp, ska, skey)
loadV4EncryptedSecretKeyFixtureForProperty
:: IO
(Either String (SomePKPayload, SKAddendum, SKey, BL.ByteString))
loadV4EncryptedSecretKeyFixtureForProperty = do
passphrase <- readPKIPassphrase
packets <-
DC.runConduitRes $
CB.sourceFile "tests/data/aes256-sha512.seckey"
DC..| conduitGet get
DC..| CL.consume
pure $ do
(pkp, ska) <-
case packets of
(SecretKeyPkt pkpayload skaddendum : _) -> Right (pkpayload, skaddendum)
_ ->
Left "aes256-sha512.seckey should begin with a secret key packet"
skey <-
case decryptPrivateKey (pkp, ska) passphrase of
Right (SUUnencrypted x _) -> Right x
Right other ->
Left
("unexpected decrypted key shape for v4 fixture: " ++ show other)
Left err ->
Left ("failed to decrypt v4 fixture secret key: " ++ err)
Right (pkp, ska, skey, passphrase)
reverseIf :: Bool -> [a] -> [a]
reverseIf shouldReverse xs
| shouldReverse = reverse xs
| otherwise = xs
cgp :: DC.ConduitT B.ByteString Pkt (ResourceT IO) ()
cgp = conduitGet (get :: Get Pkt)
fp :: Text -> Fingerprint
fp = either error id . parseFingerprint
doPkeyAndSkeyMatch :: PKey -> SKey -> Assertion
doPkeyAndSkeyMatch (RSAPubKey (RSA_PublicKey rpub)) (RSAPrivateKey (RSA_PrivateKey rpriv)) =
assertEqual
"RSA private key matches RSA public key"
rpub
(RSA.private_pub rpriv)
doPkeyAndSkeyMatch (ECDSAPubKey (ECDSA_PublicKey ecpub)) (ECDSAPrivateKey (ECDSA_PrivateKey ecpriv)) =
assertEqual
"ECDSA private key curve matches ECDSA public key curve"
(ECDSA.public_curve ecpub)
(ECDSA.private_curve ecpriv)
doPkeyAndSkeyMatch _ _ = assertFailure "matching unimplemented"
{-# NOINLINE secretKeyInfoCacheRef #-}
secretKeyInfoCacheRef
:: IORef [(([Pkt], BL.ByteString), [PKESKRecipientKey])]
secretKeyInfoCacheRef = unsafePerformIO (newIORef [])
collectSecretKeyInfos
:: [Pkt] -> BL.ByteString -> IO [PKESKRecipientKey]
collectSecretKeyInfos pkts passphrase = do
cache <- readIORef secretKeyInfoCacheRef
case lookup (pkts, passphrase) cache of
Just cached -> pure cached
Nothing -> do
keyInfos <- computeSecretKeyInfos
modifyIORef'
secretKeyInfoCacheRef
(((pkts, passphrase), keyInfos) :)
pure keyInfos
where
computeSecretKeyInfos = do
let keyInfoResults = map toKeyInfo pkts
keyInfos = catMaybes [mKeyInfo | Right mKeyInfo <- keyInfoResults]
unlockErrors = [err | Left err <- keyInfoResults]
unless (null unlockErrors) $
assertFailure
( "one or more secret key packets failed to unlock (partial failures are surfaced to\
\ prevent silent key-context gaps):\n"
++ unlines unlockErrors
)
pure keyInfos
toKeyInfo (SecretKeyPkt pkp ska) = decryptToRecipientKey "SecretKeyPkt" pkp ska
toKeyInfo (SecretSubkeyPkt pkp ska) = decryptToRecipientKey "SecretSubkeyPkt" pkp ska
toKeyInfo _ = Right Nothing
decryptToRecipientKey contextLabel pkp ska =
case ska of
SUUnencrypted skey _ ->
Right
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just pkp
, pkeskRecipientSKey = skey
}
)
)
_ ->
case decryptPrivateKey (pkp, ska) passphrase of
Right (SUUnencrypted skey _) ->
Right
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just pkp
, pkeskRecipientSKey = skey
}
)
)
Right decryptedSKA ->
Left
( contextLabel
++ " "
++ show (fingerprint pkp)
++ ": decryptPrivateKey returned unexpected protection: "
++ show decryptedSKA
)
Left err ->
Left
( contextLabel
++ " "
++ show (fingerprint pkp)
++ ": decryptPrivateKey failed: "
++ err
)
signSubkeyRevocationWithRSAAt
:: SomePKPayload
-> SomePKPayload
-> RSA.PrivateKey
-> ThirtyTwoBitTimeStamp
-> IO SignaturePayload
signSubkeyRevocationWithRSAAt signer subkey signingKey creationTime = do
(hashed, unhashed) <-
messageIssuerSubpacketsAt signer creationTime
case signSubkeyRevocationWithRSA
signer
subkey
hashed
unhashed
signingKey of
Left err ->
assertFailure
("failed to sign subkey revocation: " ++ renderSignError err)
>> fail "expected subkey revocation signature"
Right sigPayload -> pure sigPayload
signSubkeyBindingWithRSAAt
:: SomePKPayload
-> SomePKPayload
-> RSA.PrivateKey
-> ThirtyTwoBitTimeStamp
-> IO SignaturePayload
signSubkeyBindingWithRSAAt signer subkey signingKey creationTime = do
signSubkeyBindingWithRSAExtrasAt
signer
subkey
signingKey
creationTime
[]
signDirectKeyWithRSAExtrasAt
:: SomePKPayload
-> RSA.PrivateKey
-> ThirtyTwoBitTimeStamp
-> [SigSubPacket]
-> IO SignaturePayload
signDirectKeyWithRSAExtrasAt signer signingKey creationTime hashedExtras = do
(hashed, unhashed) <-
messageIssuerSubpacketsAt signer creationTime
case signDirectKeyWithRSA
SignatureDirectlyOnAKey
signer
(hashedExtras ++ hashed)
unhashed
signingKey of
Left err ->
assertFailure
( "failed to sign direct key self-signature: "
++ renderSignError err
)
>> fail "expected direct key self-signature"
Right sigPayload -> pure sigPayload
signSubkeyBindingWithRSAExtrasAt
:: SomePKPayload
-> SomePKPayload
-> RSA.PrivateKey
-> ThirtyTwoBitTimeStamp
-> [SigSubPacket]
-> IO SignaturePayload
signSubkeyBindingWithRSAExtrasAt signer subkey signingKey creationTime hashedExtras = do
(hashed, unhashed) <-
messageIssuerSubpacketsAt signer creationTime
let bindingPayload =
payloadForSig
SubkeyBindingSig
emptyPSC
{ lastPrimaryKey = PublicKeyPkt signer
, lastSubkey = PublicSubkeyPkt subkey
}
case signDataWithRSA
SubkeyBindingSig
signingKey
(hashedExtras ++ hashed)
unhashed
bindingPayload of
Left err ->
assertFailure
("failed to sign subkey binding: " ++ renderSignError err)
>> fail "expected subkey binding signature"
Right sigPayload -> pure sigPayload
verifyTimelinePackets
:: PublicKeyring
-> BL.ByteString
-> SignaturePayload
-> [Either VerificationError Verification]
verifyTimelinePackets keyring payload sigPayload =
verifyMessagePackets
defaultVerificationOptions
{ verificationPolicy = VerifyStrict
, verificationMode = VerificationBatch
}
keyring
[ LiteralDataPkt BinaryData BL.empty 0 payload
, SignaturePkt sigPayload
]
assertSingleSignerFingerprint
:: String
-> Fingerprint
-> [Either VerificationError Verification]
-> Assertion
assertSingleSignerFingerprint label expected results =
case results of
[Right verification] ->
assertEqual
label
expected
(fingerprint (_verificationSigner verification))
other ->
assertFailure
( label
++ ", expected one successful verification result, got "
++ show (length other)
++ " result(s)"
)
assertSingleFailureContainsTimeline
:: String
-> String
-> [Either VerificationError Verification]
-> Assertion
assertSingleFailureContainsTimeline label needle results =
case results of
[Left err] ->
assertBool
label
(needle `isInfixOf` renderVerificationError err)
other ->
assertFailure
( label
++ ", expected one verification failure result, got "
++ show (length other)
++ " result(s)"
)
signCertificationWithEd25519At
:: SomePKPayload
-> SomePKPayload
-> Ed25519.SecretKey
-> UserId
-> ThirtyTwoBitTimeStamp
-> [SigSubPacket]
-> IO SignaturePayload
signCertificationWithEd25519At certifiedSigner certifierSigner signingKey uid creationTime hashedExtras = do
(hashed, unhashed) <-
messageIssuerSubpacketsAt certifierSigner creationTime
let state =
emptyPSC
{ lastPrimaryKey = PublicKeyPkt certifiedSigner
, lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText)
}
case signDataWithEd25519
GenericCert
signingKey
(hashedExtras ++ hashed)
unhashed
(payloadForSig GenericCert state) of
Left err ->
assertFailure
("failed to sign Ed25519 certification: " ++ renderSignError err)
>> fail "expected Ed25519 certification signature"
Right sigPayload -> pure sigPayload
signCertificationRevocationWithEd25519At
:: SomePKPayload
-> SomePKPayload
-> Ed25519.SecretKey
-> UserId
-> ThirtyTwoBitTimeStamp
-> [SigSubPacket]
-> IO SignaturePayload
signCertificationRevocationWithEd25519At certifiedSigner certifierSigner signingKey uid creationTime hashedExtras = do
(hashed, unhashed) <-
messageIssuerSubpacketsAt certifierSigner creationTime
let state =
emptyPSC
{ lastPrimaryKey = PublicKeyPkt certifiedSigner
, lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText)
}
case signDataWithEd25519
CertRevocationSig
signingKey
(hashedExtras ++ hashed)
unhashed
(payloadForSig CertRevocationSig state) of
Left err ->
assertFailure
( "failed to sign Ed25519 certification revocation: "
++ renderSignError err
)
>> fail "expected Ed25519 certification revocation signature"
Right sigPayload -> pure sigPayload
signKeyRevocationWithReasonAt
:: SomePKPayload
-> RSA.PrivateKey
-> ThirtyTwoBitTimeStamp
-> RevocationCode
-> IO SignaturePayload
signKeyRevocationWithReasonAt signer signingKey creationTime reasonCode =
signKeyRevocationWithReasonAndExtrasAt
signer
signingKey
creationTime
reasonCode
[]
signKeyRevocationWithReasonAndExtrasAt
:: SomePKPayload
-> RSA.PrivateKey
-> ThirtyTwoBitTimeStamp
-> RevocationCode
-> [SigSubPacket]
-> IO SignaturePayload
signKeyRevocationWithReasonAndExtrasAt signer signingKey creationTime reasonCode hashedExtras = do
(hashed, unhashed) <-
messageIssuerSubpacketsAt signer creationTime
case signKeyRevocationWithRSA
signer
( SigSubPacket False (ReasonForRevocation reasonCode "")
: hashedExtras
++ hashed
)
unhashed
signingKey of
Left err ->
assertFailure
("failed to sign key revocation: " ++ renderSignError err)
>> fail "expected key revocation signature"
Right sigPayload -> pure sigPayload
signBinaryMessageWithRSAAt
:: SomePKPayload
-> RSA.PrivateKey
-> ThirtyTwoBitTimeStamp
-> BL.ByteString
-> IO SignaturePayload
signBinaryMessageWithRSAAt signer signingKey creationTime payload = do
(hashed, unhashed) <-
messageIssuerSubpacketsAt signer creationTime
case signDataWithRSA BinarySig signingKey hashed unhashed payload of
Left err ->
assertFailure
("failed to sign RSA message payload: " ++ renderSignError err)
>> fail "expected RSA message signature"
Right sigPayload -> pure sigPayload
signBinaryMessageWithEd25519At
:: SomePKPayload
-> Ed25519.SecretKey
-> ThirtyTwoBitTimeStamp
-> BL.ByteString
-> IO SignaturePayload
signBinaryMessageWithEd25519At signer signingKey creationTime payload = do
(hashed, unhashed) <-
messageIssuerSubpacketsAt signer creationTime
case signDataWithEd25519 BinarySig signingKey hashed unhashed payload of
Left err ->
assertFailure
("failed to sign Ed25519 message payload: " ++ renderSignError err)
>> fail "expected Ed25519 message signature"
Right sigPayload -> pure sigPayload