hOpenPGP-3.5: tests/Tests/KeyGeneration.hs
-- KeyGeneration.hs: hOpenPGP key generation tests
-- 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 #-}
{-# LANGUAGE TypeApplications #-}
module Tests.KeyGeneration (keyGenerationTests) where
import Control.Lens ((^.))
import Control.Monad.Trans.Except (runExceptT)
import Data.Binary.Get (runGetOrFail)
import Data.Binary.Put (runPut)
import Data.Maybe (mapMaybe)
import qualified Data.Set as Set
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit
( Assertion
, assertBool
, assertEqual
, assertFailure
, testCase
)
import Codec.Encryption.OpenPGP.KeyGeneration
( KeyGenSpec (..)
, addSubkey
, addUID
, days
, generateSecretKey
, newKey
, runTKGen
, setAEADPreferences
, setCompressionPreferences
, setExpiration
, setHashPreferences
, setKeyServerPreferences
, setSEIPDv1SymmetricPreferences
)
import Codec.Encryption.OpenPGP.Policy
( defaultVerificationPolicy
)
import Codec.Encryption.OpenPGP.Serialize
( getSecretKey
, putSKeyForPKPayload
)
import Codec.Encryption.OpenPGP.SignatureQualities
( sigType
, signatureHashedSubpacketsKnown
)
import Codec.Encryption.OpenPGP.Signatures
( verifyAgainstKeys
, verifySigWith
, verifyTKWith
)
import Codec.Encryption.OpenPGP.Types
keyGenerationTests :: TestTree
keyGenerationTests =
testGroup
"Key generation"
[ testGroup
"RSA"
[ testCase "V4 RSA 1024-bit round-trip" testRSAV4RoundTrip
, testCase "V6 RSA 1024-bit round-trip" testRSAV6RoundTrip
, testCase "RSA key size must be multiple of 8" testRSAMultipleOf8
]
, testGroup
"Ed25519"
[ testCase "V6 Ed25519 round-trip" testEd25519V6RoundTrip
]
, testGroup
"Ed448"
[ testCase "V6 Ed448 round-trip" testEd448V6RoundTrip
]
, testGroup
"X25519"
[ testCase "V6 X25519 round-trip" testX25519V6RoundTrip
]
, testGroup
"X448"
[ testCase "V6 X448 round-trip" testX448V6RoundTrip
]
, testGroup
"Direct Key Signatures"
[ testCase
"V6 Ed25519 with preferences and expiration"
testDirectKeySigV6Ed25519
, testCase "V4 RSA with preferences" testDirectKeySigV4RSA
, testCase "V3 RSA (no direct key sig)" testDirectKeySigV3RSA
, testCase "X25519 (non-signing primary)" testDirectKeySigX25519
, testCase "Empty preferences" testDirectKeySigEmptyPrefs
, testCase "AEAD preferences" testDirectKeySigAEAD
, testCase "Key Server preferences" testDirectKeySigKeyServer
, testCase
"Subkey binding signature verifies"
testSubkeyBindingSigVerifies
]
]
roundTripAssertion
:: String
-> SomePKPayload
-> SKey
-> Assertion
roundTripAssertion label pkp skey = do
put <-
either
(assertFailure . ("serialize failed: " ++))
pure
(putSKeyForPKPayload pkp skey)
let bs = runPut put
case runGetOrFail (getSecretKey pkp) bs of
Left (_, _, err) -> assertFailure ("getSecretKey failed: " ++ err)
Right (_, _, parsedSkey) ->
assertEqual (label ++ " secret key round-trip") skey parsedSkey
testRSAV4RoundTrip :: Assertion
testRSAV4RoundTrip = do
result <-
runTKGen (V4, ThirtyTwoBitTimeStamp 0) $ do
(pkp, skey) <- newKey RSA
pure (pkp, skey)
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right ((pkp, skey), _tk) -> roundTripAssertion "RSA V4" pkp skey
testRSAV6RoundTrip :: Assertion
testRSAV6RoundTrip = do
result <-
runTKGen (V6, ThirtyTwoBitTimeStamp 0) $ do
(pkp, skey) <- newKey RSA
pure (pkp, skey)
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right ((pkp, skey), _tk) -> roundTripAssertion "RSA V6" pkp skey
testRSAMultipleOf8 :: Assertion
testRSAMultipleOf8 = do
result <-
runExceptT $
generateSecretKey (KeyGenRSA @V4 (ThirtyTwoBitTimeStamp 0) 1023)
case result of
Left _ -> pure ()
Right _ ->
assertFailure
"expected failure for non-multiple-of-8 RSA key size"
testEd25519V6RoundTrip :: Assertion
testEd25519V6RoundTrip = do
result <-
runTKGen (V6, ThirtyTwoBitTimeStamp 0) $ do
(pkp, skey) <- newKey Ed25519
pure (pkp, skey)
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right ((pkp, skey), _tk) -> roundTripAssertion "Ed25519 V6" pkp skey
testEd448V6RoundTrip :: Assertion
testEd448V6RoundTrip = do
result <-
runTKGen (V6, ThirtyTwoBitTimeStamp 0) $ do
(pkp, skey) <- newKey Ed448
pure (pkp, skey)
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right ((pkp, skey), _tk) -> roundTripAssertion "Ed448 V6" pkp skey
testX25519V6RoundTrip :: Assertion
testX25519V6RoundTrip = do
result <-
runTKGen (V6, ThirtyTwoBitTimeStamp 0) $ do
(pkp, skey) <- newKey X25519
pure (pkp, skey)
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right ((pkp, skey), _tk) -> roundTripAssertion "X25519 V6" pkp skey
testX448V6RoundTrip :: Assertion
testX448V6RoundTrip = do
result <-
runTKGen (V6, ThirtyTwoBitTimeStamp 0) $ do
(pkp, skey) <- newKey X448
pure (pkp, skey)
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right ((pkp, skey), _tk) -> roundTripAssertion "X448 V6" pkp skey
testDirectKeySigV6Ed25519 :: Assertion
testDirectKeySigV6Ed25519 = do
result <-
runTKGen (V6, ThirtyTwoBitTimeStamp 1000) $ do
_ <- newKey Ed25519
setExpiration (days 365)
setSEIPDv1SymmetricPreferences [AES256]
setHashPreferences [SHA256]
setCompressionPreferences [BZip2]
addUID "Test User <test@example.com>"
pure ()
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right (_a, tk) -> do
let dks = tk ^. tkDirectKeySigs
assertEqual "V6 Ed25519 direct key sig count" 1 (length dks)
let sig = head dks
assertEqual
"V6 Ed25519 direct key sig type"
(Just DirectKeySignature)
(sigType sig)
case signatureHashedSubpacketsKnown sig of
Nothing -> assertFailure "direct key sig hashed subpackets unknown"
Just hashed -> do
assertBool
"hashed subpackets contain SigCreationTime"
(any isSigCreationTime hashed)
assertBool
"hashed subpackets contain SigExpirationTime"
(any isSigExpirationTime hashed)
assertBool
"hashed subpackets contain PreferredSymmetricAlgorithms"
(any isPreferredSymmetric hashed)
assertBool
"hashed subpackets contain PreferredHashAlgorithms"
(any isPreferredHash hashed)
assertBool
"hashed subpackets contain PreferredCompressionAlgorithms"
(any isPreferredCompression hashed)
let pubKs = mapMaybe someTKToPublicTK [SomePublicTK (publicViewTK tk)]
case verifyTKWith
(verifySigWith defaultVerificationPolicy (verifyAgainstKeys pubKs))
Nothing
(publicViewTK tk) of
Left err ->
assertFailure
("V6 Ed25519 self-verification failed: " ++ show err)
Right _ -> pure ()
testDirectKeySigV4RSA :: Assertion
testDirectKeySigV4RSA = do
result <-
runTKGen (V4, ThirtyTwoBitTimeStamp 2000) $ do
_ <- newKey RSA
setSEIPDv1SymmetricPreferences [AES128]
setHashPreferences [SHA384]
setCompressionPreferences [BZip2]
pure ()
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right (_a, tk) -> do
let dks = tk ^. tkDirectKeySigs
assertEqual "V4 RSA direct key sig count" 1 (length dks)
let sig = head dks
assertEqual
"V4 RSA direct key sig type"
(Just DirectKeySignature)
(sigType sig)
case signatureHashedSubpacketsKnown sig of
Nothing -> assertFailure "direct key sig hashed subpackets unknown"
Just hashed -> do
assertBool
"hashed subpackets contain SigCreationTime"
(any isSigCreationTime hashed)
assertBool
"hashed subpackets contain PreferredSymmetricAlgorithms"
(any isPreferredSymmetric hashed)
assertBool
"hashed subpackets contain PreferredHashAlgorithms"
(any isPreferredHash hashed)
assertBool
"hashed subpackets contain PreferredCompressionAlgorithms"
(any isPreferredCompression hashed)
let pubKs = mapMaybe someTKToPublicTK [SomePublicTK (publicViewTK tk)]
case verifyTKWith
(verifySigWith defaultVerificationPolicy (verifyAgainstKeys pubKs))
Nothing
(publicViewTK tk) of
Left err ->
assertFailure ("V4 RSA self-verification failed: " ++ show err)
Right _ -> pure ()
testDirectKeySigV3RSA :: Assertion
testDirectKeySigV3RSA = do
result <-
runTKGen (DeprecatedV3, ThirtyTwoBitTimeStamp 3000) $ do
_ <- newKey RSA
pure ()
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right (_a, tk) ->
assertEqual
"V3 RSA direct key sig count"
0
(length (tk ^. tkDirectKeySigs))
testDirectKeySigX25519 :: Assertion
testDirectKeySigX25519 = do
result <-
runTKGen (V6, ThirtyTwoBitTimeStamp 4000) $ do
_ <- newKey X25519
pure ()
case result of
Left err ->
assertFailure
("runTKGen should succeed for X25519: " ++ show err)
Right (_a, tk) ->
assertEqual
"X25519 direct key sig count"
0
(length (tk ^. tkDirectKeySigs))
testDirectKeySigEmptyPrefs :: Assertion
testDirectKeySigEmptyPrefs = do
result <-
runTKGen (V6, ThirtyTwoBitTimeStamp 5000) $ do
_ <- newKey Ed25519
pure ()
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right (_a, tk) -> do
let dks = tk ^. tkDirectKeySigs
assertEqual "empty prefs direct key sig count" 1 (length dks)
let sig = head dks
case signatureHashedSubpacketsKnown sig of
Nothing -> assertFailure "direct key sig hashed subpackets unknown"
Just hashed -> do
assertBool
"hashed subpackets contain SigCreationTime"
(any isSigCreationTime hashed)
assertBool
"no PreferredSymmetricAlgorithms"
(not (any isPreferredSymmetric hashed))
assertBool
"no PreferredHashAlgorithms"
(not (any isPreferredHash hashed))
assertBool
"no PreferredCompressionAlgorithms"
(not (any isPreferredCompression hashed))
testDirectKeySigAEAD :: Assertion
testDirectKeySigAEAD = do
result <-
runTKGen (V6, ThirtyTwoBitTimeStamp 6000) $ do
_ <- newKey Ed25519
setAEADPreferences [(AES256, EAX)]
pure ()
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right (_a, tk) -> do
let dks = tk ^. tkDirectKeySigs
assertEqual "AEAD direct key sig count" 1 (length dks)
let sig = head dks
case signatureHashedSubpacketsKnown sig of
Nothing -> assertFailure "direct key sig hashed subpackets unknown"
Just hashed -> do
assertBool
"hashed subpackets contain SigCreationTime"
(any isSigCreationTime hashed)
assertBool
"hashed subpackets contain PreferredAEADCiphersuites"
(any isPreferredAEAD hashed)
testDirectKeySigKeyServer :: Assertion
testDirectKeySigKeyServer = do
result <-
runTKGen (V6, ThirtyTwoBitTimeStamp 7000) $ do
_ <- newKey Ed25519
setKeyServerPreferences (Set.singleton NoModify)
pure ()
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right (_a, tk) -> do
let dks = tk ^. tkDirectKeySigs
assertEqual "key server direct key sig count" 1 (length dks)
let sig = head dks
case signatureHashedSubpacketsKnown sig of
Nothing -> assertFailure "direct key sig hashed subpackets unknown"
Just hashed -> do
assertBool
"hashed subpackets contain SigCreationTime"
(any isSigCreationTime hashed)
assertBool
"hashed subpackets contain KeyServerPreferences"
(any isKeyServerPrefs hashed)
testSubkeyBindingSigVerifies :: Assertion
testSubkeyBindingSigVerifies = do
result <-
runTKGen (V6, ThirtyTwoBitTimeStamp 8000) $ do
_ <- newKey Ed25519
_ <- addSubkey Ed25519 [SignDataKey]
pure ()
case result of
Left err -> assertFailure ("runTKGen failed: " ++ show err)
Right (_a, tk) ->
case tk ^. tkSubs of
[] -> assertFailure "expected one subkey"
((subPkt, sigs) : _) -> do
assertEqual "subkey sig count" 1 (length sigs)
let pubKs = mapMaybe someTKToPublicTK [SomePublicTK (publicViewTK tk)]
case verifyTKWith
(verifySigWith defaultVerificationPolicy (verifyAgainstKeys pubKs))
Nothing
(publicViewTK tk) of
Left err ->
assertFailure
("subkey binding self-verification failed: " ++ show err)
Right _ -> pure ()
isKeyServerPrefs :: SigSubPacket -> Bool
isKeyServerPrefs (SigSubPacket _ KeyServerPreferences {}) = True
isKeyServerPrefs _ = False
isPreferredAEAD :: SigSubPacket -> Bool
isPreferredAEAD (SigSubPacket _ PreferredAEADCiphersuites {}) = True
isPreferredAEAD _ = False
isSigCreationTime :: SigSubPacket -> Bool
isSigCreationTime (SigSubPacket _ SigCreationTime {}) = True
isSigCreationTime _ = False
isSigExpirationTime :: SigSubPacket -> Bool
isSigExpirationTime (SigSubPacket _ SigExpirationTime {}) = True
isSigExpirationTime _ = False
isPreferredSymmetric :: SigSubPacket -> Bool
isPreferredSymmetric (SigSubPacket _ PreferredSymmetricAlgorithms {}) = True
isPreferredSymmetric _ = False
isPreferredHash :: SigSubPacket -> Bool
isPreferredHash (SigSubPacket _ PreferredHashAlgorithms {}) = True
isPreferredHash _ = False
isPreferredCompression :: SigSubPacket -> Bool
isPreferredCompression (SigSubPacket _ PreferredCompressionAlgorithms {}) = True
isPreferredCompression _ = False