hOpenPGP 3.3 → 3.4
raw patch · 28 files changed
+1028/−362 lines, 28 files
Files
- Codec/Encryption/OpenPGP/Arbitrary.hs +14/−4
- Codec/Encryption/OpenPGP/Encrypt.hs +7/−5
- Codec/Encryption/OpenPGP/Expirations.hs +3/−3
- Codec/Encryption/OpenPGP/Internal.hs +13/−15
- Codec/Encryption/OpenPGP/KeyGeneration.hs +134/−0
- Codec/Encryption/OpenPGP/KeyringParser.hs +14/−6
- Codec/Encryption/OpenPGP/Message.hs +13/−4
- Codec/Encryption/OpenPGP/Ontology.hs +2/−2
- Codec/Encryption/OpenPGP/Policy.hs +2/−2
- Codec/Encryption/OpenPGP/SecretKey.hs +2/−118
- Codec/Encryption/OpenPGP/Serialize.hs +39/−25
- Codec/Encryption/OpenPGP/SerializeForSigs.hs +2/−2
- Codec/Encryption/OpenPGP/Signatures.hs +20/−7
- Codec/Encryption/OpenPGP/Types/Internal/Base.hs +162/−28
- Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +6/−4
- Codec/Encryption/OpenPGP/Types/Internal/TK.hs +206/−17
- Data/Conduit/OpenPGP/Keyring/Instances.hs +1/−0
- Data/Conduit/OpenPGP/Verify.hs +2/−2
- hOpenPGP.cabal +5/−2
- tests/Tests/Common.hs +5/−3
- tests/Tests/Encryption.hs +45/−30
- tests/Tests/KeyGeneration.hs +143/−0
- tests/Tests/Keys.hs +29/−13
- tests/Tests/MessageAndArmor.hs +93/−30
- tests/Tests/Properties.hs +6/−2
- tests/Tests/Serialization.hs +2/−1
- tests/Tests/Utilities.hs +38/−21
- tests/suite.hs +20/−16
Codec/Encryption/OpenPGP/Arbitrary.hs view
@@ -178,7 +178,8 @@ set = fmap SigExpirationTime arbitrary ec = fmap ExportableCertification arbitrary ts =- arbitrary >>= \tl -> arbitrary >>= \ta -> return (TrustSignature tl ta)+ arbitrary >>= \tl ->+ arbitrary >>= \ta -> return (TrustSignature (TrustLevel tl) (TrustAmount ta)) re = fmap RegularExpression arbitrary ket = fmap KeyExpirationTime arbitrary psa = fmap PreferredSymmetricAlgorithms arbitrary@@ -202,12 +203,12 @@ suid = fmap SignersUserId arbitrary rfr = arbitrary >>= \rc ->- arbitrary >>= \rr -> return (ReasonForRevocation rc rr)+ arbitrary >>= \rr -> return (ReasonForRevocation rc (RevocationReason rr)) fs = fmap Features arbitrary st = arbitrary >>= \pka -> arbitrary >>= \ha ->- arbitrary >>= \sh -> return (SignatureTarget pka ha sh)+ arbitrary >>= \sh -> return (SignatureTarget pka ha (SignatureHash sh)) es _ = pure (EmbeddedSignature (SigVOther 5 BL.empty)) ifp = elements [IssuerFingerprintV4, IssuerFingerprintV6] >>= \v ->@@ -294,7 +295,7 @@ , PositiveCert , SubkeyBindingSig , PrimaryKeyBindingSig- , SignatureDirectlyOnAKey+ , DirectKeySignature , KeyRevocationSig , SubkeyRevocationSig , CertRevocationSig@@ -403,3 +404,12 @@ instance Arbitrary Padding where arbitrary = fmap Padding arbitrary++instance Arbitrary Exportability where+ arbitrary = fmap Exportability arbitrary++instance Arbitrary Revocability where+ arbitrary = fmap Revocability arbitrary++instance Arbitrary NestedFlag where+ arbitrary = fmap NestedFlag arbitrary
Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -1023,7 +1023,7 @@ defaultRecipientPayloadShape = RecipientPayloadShape { recipientPayloadDataType = BinaryData- , recipientPayloadFileName = BL.empty+ , recipientPayloadFileName = FileName B.empty , recipientPayloadTimestamp = 0 , recipientPayloadUseOnePassSignatures = False , recipientPayloadSignatures = []@@ -1769,7 +1769,9 @@ (zipWith buildOnePassSignature nestedFlags (reverse signatures)) where signatures = recipientPayloadSignatures payloadShape- nestedFlags = replicate (length signatures - 1) True ++ [False]+ nestedFlags =+ replicate (length signatures - 1) (NestedFlag True)+ ++ [NestedFlag False] data OnePassSignatureBuildCase where OnePassSignatureBuildCaseV3@@ -2658,7 +2660,7 @@ ( Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload) ]@@ -2790,14 +2792,14 @@ Nothing -> [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload) ] Just sigs -> LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload) : sigs
Codec/Encryption/OpenPGP/Expirations.hs view
@@ -73,7 +73,7 @@ relevantSelfSignatures relevantSelfSignatures = concat- [ filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkRevs)+ [ filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkDirectKeySigs) , filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkUIDs))@@ -310,7 +310,7 @@ isDirectKeySelfSigFor primaryKey sig && signatureEffectiveAt ct sig )- (tk ^. tkRevs)+ (tk ^. tkDirectKeySigs) uidSelfCerts = mapMaybe ( latestActiveSelfCertificationAt ct@@ -377,7 +377,7 @@ isDirectKeySelfSigFor :: SomePKPayload -> SignaturePayload -> Bool isDirectKeySelfSigFor pkp sig =- sigType sig == Just SignatureDirectlyOnAKey+ sigType sig == Just DirectKeySignature && isSelfSignatureFor pkp sig isSelfCertificationFor
Codec/Encryption/OpenPGP/Internal.hs view
@@ -7,26 +7,24 @@ {-# LANGUAGE OverloadedStrings #-} module Codec.Encryption.OpenPGP.Internal- ( countBits- , PktStreamContext (..)- , issuer- , issuerFP- , emptyPSC- , leftPadTo- , checksum16+ ( checksum16 , checksum16Bytes- , edPointBytes- , encodeWord64be , chunksOf8- , pubkeyToMPIs- , multiplicativeInverse- , curveoidBSToCurve+ , curve2Curve+ , curveFromCurve , curveToCurveoidBS- , point2MBS+ , curveoidBSToCurve , curveoidBSToEdSigningCurve+ , edPointBytes , edSigningCurveToCurveoidBS- , curve2Curve- , curveFromCurve+ , emptyPSC+ , encodeWord64be+ , issuer+ , issuerFP+ , leftPadTo+ , PktStreamContext (..)+ , point2MBS+ , pubkeyToMPIs , xorBS ) where
+ Codec/Encryption/OpenPGP/KeyGeneration.hs view
@@ -0,0 +1,134 @@+-- KeyGeneration.hs: OpenPGP (RFC9580) key generation+-- Copyright © 2026 Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Codec.Encryption.OpenPGP.KeyGeneration+ ( KeyGenSpec (..)+ , generateSecretKey+ ) where++import Control.Monad (unless)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT (..), throwE)+import qualified Crypto.Error as CE+import Crypto.Number.Serialize (os2ip)+import qualified Crypto.PubKey.Curve25519 as C25519+import qualified Crypto.PubKey.Curve448 as C448+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448+import qualified Crypto.PubKey.RSA as RSA+import Crypto.Random.Types (MonadRandom, getRandomBytes)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B++import Codec.Encryption.OpenPGP.Types++class RSAKeyVersion (v :: KeyVersion) where+ rsaKeyVersion :: KeyVersion++instance RSAKeyVersion 'V4 where+ rsaKeyVersion = V4++instance RSAKeyVersion 'V6 where+ rsaKeyVersion = V6++data KeyGenSpec (v :: KeyVersion) where+ KeyGenRSA+ :: RSAKeyVersion v => ThirtyTwoBitTimeStamp -> Int -> KeyGenSpec v+ KeyGenEd25519 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6+ KeyGenEd448 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6+ KeyGenX25519 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6+ KeyGenX448 :: ThirtyTwoBitTimeStamp -> KeyGenSpec 'V6++generateSecretKey+ :: forall v m+ . MonadRandom m+ => KeyGenSpec v+ -> ExceptT String m (SomePKPayload, SKey)+generateSecretKey spec = case spec of+ KeyGenRSA ts keySizeBits -> rsaGenerate (rsaKeyVersion @v) ts keySizeBits+ KeyGenEd25519 ts -> ed25519Generate ts+ KeyGenEd448 ts -> ed448Generate ts+ KeyGenX25519 ts -> x25519Generate ts+ KeyGenX448 ts -> x448Generate ts+ where+ rsaGenerate kv ts keySizeBits = do+ unless (keySizeBits `mod` 8 == 0) $+ throwE "RSA key size must be a multiple of 8"+ let keySizeBytes = keySizeBits `div` 8+ (publicKey, privateKey) <- lift $ RSA.generate keySizeBytes 65537+ let pkey = RSAPubKey (RSA_PublicKey publicKey)+ skey = RSAPrivateKey (RSA_PrivateKey privateKey)+ pkp = case kv of+ DeprecatedV3 -> PKPayload DeprecatedV3 ts 0 RSA pkey+ V4 -> PKPayload V4 ts 0 RSA pkey+ V6 -> PKPayload V6 ts 0 RSA pkey+ pure (pkp, skey)+ ed25519Generate ts = do+ seed <- lift $ getRandomBytes 32+ secretKey <-+ either+ (throwE . ("Ed25519 key generation failed: " ++) . show)+ pure+ (CE.eitherCryptoError (Ed25519.secretKey seed))+ let pubBytes = BA.convert (Ed25519.toPublic secretKey) :: B.ByteString+ pkey =+ EdDSAPubKey+ EdSigningCurve25519+ (NativeEPoint (EPoint (os2ip pubBytes)))+ skey = Ed25519PrivateKey seed+ pkp = PKPayload V6 ts 0 Ed25519 pkey+ pure (pkp, skey)+ ed448Generate ts = do+ seed <- lift $ getRandomBytes 57+ secretKey <-+ either+ (throwE . ("Ed448 key generation failed: " ++) . show)+ pure+ (CE.eitherCryptoError (Ed448.secretKey seed))+ let pubBytes = BA.convert (Ed448.toPublic secretKey) :: B.ByteString+ pkey =+ EdDSAPubKey+ EdSigningCurve448+ (NativeEPoint (EPoint (os2ip pubBytes)))+ skey = Ed448PrivateKey seed+ pkp = PKPayload V6 ts 0 Ed448 pkey+ pure (pkp, skey)+ x25519Generate ts = do+ secretRaw <- lift $ getRandomBytes 32+ secretKey <-+ either+ (throwE . ("X25519 key generation failed: " ++) . show)+ pure+ (CE.eitherCryptoError (C25519.secretKey secretRaw))+ let pubRaw = BA.convert (C25519.toPublic secretKey) :: B.ByteString+ pkey =+ EdDSAPubKey+ EdSigningCurve25519+ (NativeEPoint (EPoint (os2ip pubRaw)))+ skey = X25519PrivateKey secretRaw+ pkp = PKPayload V6 ts 0 X25519 pkey+ pure (pkp, skey)+ x448Generate ts = do+ secretRaw <- lift $ getRandomBytes 56+ secretKey <-+ either+ (throwE . ("X448 key generation failed: " ++) . show)+ pure+ (CE.eitherCryptoError (C448.secretKey secretRaw))+ let pubRaw = BA.convert (C448.toPublic secretKey) :: B.ByteString+ pkey =+ EdDSAPubKey+ EdSigningCurve448+ (NativeEPoint (EPoint (os2ip pubRaw)))+ skey = X448PrivateKey secretRaw+ pkp = PKPayload V6 ts 0 X448 pkey+ pure (pkp, skey)
Codec/Encryption/OpenPGP/KeyringParser.hs view
@@ -201,7 +201,9 @@ splitUs (many (signedUID intolerant <|> signedUAt intolerant)) subs <- concatMany (pubsub intolerant)- return $ Just (TKUnknown pkp pkpsigs uids uats subs)+ let revs = filter ((== Just KeyRevocationSig) . sigType) pkpsigs+ directKeySigs = filter ((== Just DirectKeySignature) . sigType) pkpsigs+ return $ Just (TKUnknown pkp revs directKeySigs uids uats subs) where pubsub True = signedOrRevokedPubSubkey True pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey@@ -215,7 +217,9 @@ splitUs (many (signedUID intolerant <|> signedUAt intolerant)) subs <- concatMany (secsub intolerant)- return $ Just (TKUnknown skp skpsigs uids uats subs)+ let revs = filter ((== Just KeyRevocationSig) . sigType) skpsigs+ directKeySigs = filter ((== Just DirectKeySignature) . sigType) skpsigs+ return $ Just (TKUnknown skp revs directKeySigs uids uats subs) where secsub True = rawOrSignedOrRevokedSecSubkey True secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey@@ -225,7 +229,7 @@ _ <- broken 6 _ <- many- (signature False [KeyRevocationSig, SignatureDirectlyOnAKey])+ (signature False [KeyRevocationSig, DirectKeySignature]) _ <- many (signedUID False <|> signedUAt False) _ <- concatMany (signedOrRevokedPubSubkey False <|> brokenPubSubkey)@@ -234,7 +238,7 @@ _ <- broken 5 _ <- many- (signature False [KeyRevocationSig, SignatureDirectlyOnAKey])+ (signature False [KeyRevocationSig, DirectKeySignature]) _ <- many (signedUID False <|> signedUAt False) _ <- concatMany@@ -452,7 +456,9 @@ uidrefs = concatMap snd uidResults subs = fmap fst subResults subrefs = concatMap snd subResults- tk = TKUnknown pkp pkpsigs uids uats subs+ revs = filter ((== Just KeyRevocationSig) . sigType) pkpsigs+ directKeySigs = filter ((== Just DirectKeySignature) . sigType) pkpsigs+ tk = TKUnknown pkp revs directKeySigs uids uats subs refs = pkps ++ pkpsigrefs ++ uidrefs ++ subrefs return $ Just (mkTKWithWireRep tk refs) where@@ -479,7 +485,9 @@ uidrefs = concatMap snd uidResults subs = fmap fst subResults subrefs = concatMap snd subResults- tk = TKUnknown skp skpsigs uids uats subs+ revs = filter ((== Just KeyRevocationSig) . sigType) skpsigs+ directKeySigs = filter ((== Just DirectKeySignature) . sigType) skpsigs+ tk = TKUnknown skp revs directKeySigs uids uats subs refs = skps ++ skpsigrefs ++ uidrefs ++ subrefs return $ Just (mkTKWithWireRep tk refs) where
Codec/Encryption/OpenPGP/Message.hs view
@@ -495,7 +495,12 @@ s2k (unPassphrase passphrase) ( Block- [LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload)]+ [ LiteralDataPkt+ BinaryData+ (FileName B.empty)+ 0+ (unClearPayload payload)+ ] ) sessionKeyMaterial <- deriveSessionMaterial sa s2k passphrase pure@@ -529,7 +534,11 @@ WrappedSessionMaterial <$> string2Key s2k keyLen (unPassphrase passphrase) let literal =- LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload)+ LiteralDataPkt+ BinaryData+ (FileName B.empty)+ 0+ (unClearPayload payload) cleartext = BL.toStrict (runPut (put (Block [literal]))) cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext encrypted <-@@ -803,7 +812,7 @@ -> Either SignError BL.ByteString signWithSubpackets hashed unhashed signingFn payload = do let clear = unClearPayload payload- literal = LiteralDataPkt BinaryData BL.empty 0 clear+ literal = LiteralDataPkt BinaryData (FileName B.empty) 0 clear signature <- signingFn hashed unhashed clear let sigPkt = SignaturePkt signature bimap@@ -811,7 +820,7 @@ ( \ops -> runPut . put $ Block [OnePassSignaturePkt ops, literal, sigPkt] )- (buildOnePassSignature False signature)+ (buildOnePassSignature (NestedFlag False) signature) extractEncryptedPayload :: [Pkt] -> Either MessageParseFailure SomeParsedEncryptedPayload
Codec/Encryption/OpenPGP/Ontology.hs view
@@ -46,11 +46,11 @@ isRevokerP sig = case preview _SigV4 sig of Just (st, _, _, h, u, _, _) ->- st == SignatureDirectlyOnAKey && hasRevokerSubpackets h u+ st == DirectKeySignature && hasRevokerSubpackets h u Nothing -> case preview _SigV6 sig of Just (st, _, _, _, h, u, _, _) ->- st == SignatureDirectlyOnAKey && hasRevokerSubpackets h u+ st == DirectKeySignature && hasRevokerSubpackets h u Nothing -> False hasRevokerSubpackets :: [SigSubPacket] -> [SigSubPacket] -> Bool
Codec/Encryption/OpenPGP/Policy.hs view
@@ -614,7 +614,7 @@ -- RFC9580/RFC4880 signature context validation predicates -- These enforce which signature types are allowed in which structural contexts --- | RFC9580 §3.2: Primary key can only have KeyRevocationSig or SignatureDirectlyOnAKey+-- | RFC9580 §3.2: Primary key can only have KeyRevocationSig or DirectKeySignature isAllowedPrimaryKeySig :: SignaturePayload -> Bool isAllowedPrimaryKeySig = maybe False isAllowedPrimaryKeySigType . sigType @@ -629,7 +629,7 @@ -- | Test if a SigType is allowed on a primary key isAllowedPrimaryKeySigType :: SigType -> Bool isAllowedPrimaryKeySigType KeyRevocationSig = True-isAllowedPrimaryKeySigType SignatureDirectlyOnAKey = True+isAllowedPrimaryKeySigType DirectKeySignature = True isAllowedPrimaryKeySigType _ = False -- | Test if a SigType is allowed on a subkey
Codec/Encryption/OpenPGP/SecretKey.hs view
@@ -11,11 +11,9 @@ ( decryptPrivateKey , mkUnencryptedSKAddendum , encryptPrivateKeyWithPolicyAndSaltAndIV- , encryptPrivateKey- , changePrivateKeyPassphrase- , changePrivateKeyPassphraseRandom- , reencryptSecretKeyRandomEither , reencryptPrivateKeyTyped+ , reencryptPrivateKeyTypedWithPolicy+ , reencryptPrivateKeyWithSaltAndIV , SecretKeyError (..) , renderSecretKeyError , SecretKeyEncryptOptions (..)@@ -25,7 +23,6 @@ , encryptSecretKeyWithPolicy , reencryptSecretKey , reencryptSecretKeyRandom- , changeSecretKeyPassphrase ) where import Control.Error.Util (note)@@ -311,28 +308,6 @@ , skeoIV = Nothing } -{-# DEPRECATED- changeSecretKeyPassphrase- "Use reencryptSecretKey or reencryptSecretKeyRandom instead"- #-}-changeSecretKeyPassphrase- :: MonadRandom m- => SecretKey- -> Passphrase- -> Passphrase- -> m (Either SecretKeyError SecretKey)-changeSecretKeyPassphrase sk oldPassphrase newPassphrase =- reencryptSecretKey- sk- oldPassphrase- newPassphrase- SecretKeyEncryptOptions- { skeoPolicy = defaultPolicy- , skeoGenerateSaltAndIV = True- , skeoSalt = Nothing- , skeoIV = Nothing- }- decryptPrivateKeyTyped :: SomePKPayload -> SKAddendumV v@@ -642,24 +617,6 @@ keyVersionByte V4 = 4 keyVersionByte V6 = 6 -{-# DEPRECATED encryptPrivateKey "Use encryptSecretKeyWithPolicy instead" #-}---- | generates pseudo-random salt and IV-encryptPrivateKey- :: MonadRandom m- => OpenPGPPolicy- -> SomePKPayload- -> SKAddendum- -> BL.ByteString- -> m (Either String SKAddendum)-encryptPrivateKey policy pkp ska pp = do- nextMaterial <- generateSecretKeyProtectionMaterial policy pkp- case nextMaterial of- Left err -> pure $ Left err- Right (salt, iv) ->- pure $- encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp- encryptPrivateKeyWithPolicyAndSaltAndIV :: OpenPGPPolicy -> SomePKPayload@@ -693,53 +650,6 @@ (\payload -> SUSAEAD sa aa s2k iv (BL.fromStrict payload)) <$> encryptV6SKey pkp skey sa aa s2k iv pp -{-# DEPRECATED changePrivateKeyPassphrase "Use reencryptSecretKey instead" #-}-changePrivateKeyPassphrase- :: (SomePKPayload, SKAddendum)- -> BL.ByteString- -> Salt- -> IV- -> BL.ByteString- -> Either String SKAddendum-changePrivateKeyPassphrase (pkp, ska) oldPassphrase salt iv newPassphrase = do- decrypted <- decryptPrivateKey (pkp, ska) oldPassphrase- case decrypted of- SUUnencrypted skey _ ->- reencryptPrivateKeyWithSaltAndIV- pkp- ska- salt- iv- skey- newPassphrase- _ ->- Left- "Unexpected codepath: decrypted private key material was not in unencrypted form"--{-# DEPRECATED- changePrivateKeyPassphraseRandom- "Use reencryptSecretKeyRandom instead"- #-}-changePrivateKeyPassphraseRandom- :: MonadRandom m- => (SomePKPayload, SKAddendum)- -> BL.ByteString- -> BL.ByteString- -> m (Either String SKAddendum)-changePrivateKeyPassphraseRandom (pkp, ska) oldPassphrase newPassphrase = do- nextMaterial <-- generateSecretKeyProtectionMaterial defaultPolicy pkp- case nextMaterial of- Left err -> pure $ Left err- Right (salt, iv) ->- pure $- changePrivateKeyPassphrase- (pkp, ska)- oldPassphrase- salt- iv- newPassphrase- encodeSKeyMaterial :: SKey -> Either String BL.ByteString encodeSKeyMaterial keyMaterial = case keyMaterial of@@ -887,32 +797,6 @@ >>= \aead -> pure (CCT.aeadSimpleEncrypt aead ad plaintext 16) -{-# DEPRECATED- reencryptSecretKeyRandomEither- "Use changeSecretKeyPassphrase or reencryptSecretKeyRandom instead"- #-}-reencryptSecretKeyRandomEither- :: MonadRandom m- => SecretKey -> BL.ByteString -> m (Either String SecretKey)-reencryptSecretKeyRandomEither sk pp =- reencryptSecretKeyRandom- sk- (Passphrase pp)- (Passphrase pp)- defaultPolicy- >>= \case- Left err -> pure $ Left $ show err- Right sk' -> pure $ Right sk'--{- | Version-preserving re-encryption of a typed secret-key addendum.--Each constructor family is re-encrypted in kind:- * V6 variants (AEAD, SHA1, Sym, Unencrypted) → SKAAEADV6 (default v6 policy)- * SKA16bit / SKASHA1Legacy → same S2K family with updated salt- * SKAAEADLegacy → re-protected as SKASHA1Legacy (standard v3\/v4 S2K)- * SKASymLegacy → legacy CFB re-encryption as SKASymLegacy- * SKAUnencryptedLegacy → Left (cannot re-encrypt unencrypted legacy keys)--} reencryptPrivateKeyTyped :: SomePKPayload -> SKAddendumV v
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -39,7 +39,7 @@ ) import Control.Applicative (many, some) import Control.Arrow ((***))-import Control.Lens ((^.), _1)+import Control.Lens (op, (^.), _1) import Control.Monad (guard, replicateM, replicateM_, when) import Control.Monad.Loops (iterateUntilM) import Crypto.Number.Basic (numBits)@@ -333,13 +333,18 @@ <$> fmap ThirtyTwoBitDuration getWord32be getExportableCertification :: SigSubPacketParser-getExportableCertification _pt crit _l = SigSubPacket crit . ExportableCertification <$> get+getExportableCertification _pt crit _l =+ SigSubPacket crit . ExportableCertification . Exportability+ <$> get getTrustSignature :: SigSubPacketParser getTrustSignature _pt crit _l = do tl <- getWord8 ta <- getWord8- return $ SigSubPacket crit (TrustSignature tl ta)+ return $+ SigSubPacket+ crit+ (TrustSignature (TrustLevel tl) (TrustAmount ta)) getRegularExpression :: SigSubPacketParser getRegularExpression _pt crit l = do@@ -349,7 +354,7 @@ return $ SigSubPacket crit (RegularExpression (BL.copy apdre)) getRevocable :: SigSubPacketParser-getRevocable _pt crit _l = SigSubPacket crit . Revocable <$> get+getRevocable _pt crit _l = SigSubPacket crit . Revocable . Revocability <$> get getKeyExpirationTime :: SigSubPacketParser getKeyExpirationTime _pt crit _l =@@ -457,7 +462,9 @@ (decodeUtf8With lenientDecode) (getByteString (fromIntegral (l - 2))) return $- SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason)+ SigSubPacket+ crit+ (ReasonForRevocation (toFVal rcode) (RevocationReason rreason)) getFeatures :: SigSubPacketParser getFeatures _pt crit l = do@@ -469,7 +476,10 @@ pka <- get ha <- get hash <- getLazyByteString (l - 3)- return $ SigSubPacket crit (SignatureTarget pka ha hash)+ return $+ SigSubPacket+ crit+ (SignatureTarget pka ha (SignatureHash (BL.toStrict hash))) getEmbeddedSignature :: SigSubPacketParser getEmbeddedSignature _pt crit l = do@@ -539,7 +549,7 @@ SigCreationTime et -> putSigCreationTime crit et SigExpirationTime et -> putSigExpirationTime crit et ExportableCertification e -> putExportableCertification crit e- TrustSignature tl ta -> putTrustSignature crit tl ta+ TrustSignature tl ta -> putTrustSignature crit (unTrustLevel tl) (unTrustAmount ta) RegularExpression apdre -> putRegularExpression crit apdre Revocable r -> putRevocable crit r KeyExpirationTime et -> putKeyExpirationTime crit et@@ -557,7 +567,7 @@ SignersUserId userid -> putSignersUserId crit userid ReasonForRevocation rcode rreason -> putReasonForRevocation crit rcode rreason Features fs -> putFeatures crit fs- SignatureTarget pka ha hash -> putSignatureTarget crit pka ha hash+ SignatureTarget pka ha hash -> putSignatureTarget crit pka ha (op SignatureHash hash) EmbeddedSignature sp -> putEmbeddedSignature crit sp IssuerFingerprint kv fp -> putIssuerFingerprint crit kv fp IntendedRecipient kv irf -> putIntendedRecipient crit kv irf@@ -577,11 +587,11 @@ putSigSubPacketType crit 3 putWord32be . unThirtyTwoBitDuration $ et -putExportableCertification :: Bool -> Bool -> Put+putExportableCertification :: Bool -> Exportability -> Put putExportableCertification crit e = do putSubPacketLength 2 putSigSubPacketType crit 4- put e+ put (unExportability e) putTrustSignature :: Bool -> Word8 -> Word8 -> Put putTrustSignature crit tl ta = do@@ -597,11 +607,11 @@ putLazyByteString apdre putWord8 0 -putRevocable :: Bool -> Bool -> Put+putRevocable :: Bool -> Revocability -> Put putRevocable crit r = do putSubPacketLength 2 putSigSubPacketType crit 7- put r+ put (unRevocability r) putKeyExpirationTime :: Bool -> ThirtyTwoBitDuration -> Put putKeyExpirationTime crit et = do@@ -709,7 +719,7 @@ putReasonForRevocation :: Bool -> RevocationCode -> RevocationReason -> Put putReasonForRevocation crit rcode rreason = do- let reasonbs = encodeUtf8 rreason+ let reasonbs = encodeUtf8 (unRevocationReason rreason) putSubPacketLength . fromIntegral $ (2 + B.length reasonbs) putSigSubPacketType crit 29 putWord8 . fromFVal $ rcode@@ -723,13 +733,13 @@ putLazyByteString fbs putSignatureTarget- :: Bool -> PubKeyAlgorithm -> HashAlgorithm -> BL.ByteString -> Put+ :: Bool -> PubKeyAlgorithm -> HashAlgorithm -> B.ByteString -> Put putSignatureTarget crit pka ha hash = do- putSubPacketLength . fromIntegral $ (3 + BL.length hash)+ putSubPacketLength . fromIntegral $ (3 + B.length hash) putSigSubPacketType crit 31 put pka put ha- putLazyByteString hash+ putByteString hash putEmbeddedSignature :: Bool -> SignaturePayload -> Put putEmbeddedSignature crit sp = do@@ -1439,7 +1449,8 @@ fn <- getLazyByteString (fromIntegral flen) ts <- fmap ThirtyTwoBitTimeStamp getWord32be ldata <- getLazyByteString (len - (6 + fromIntegral flen))- return $ LiteralDataPkt (toFVal dt) fn ts ldata+ return $+ LiteralDataPkt (toFVal dt) (FileName (BL.toStrict fn)) ts ldata getPublicSubkey :: ByteOffset -> Get Pkt getPublicSubkey len = do@@ -1503,7 +1514,9 @@ bs <- getLazyByteString (l - 17) if hver /= 1 || nuls /= BL.pack (replicate 12 0) then fail "Corrupt UAt subpacket"- else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs+ else+ return $+ ImageAttribute (ImageHV1 (toFVal iformat)) (ImageData bs) | otherwise = do bs <- getLazyByteString (l - 1) return $ OtherUASub t bs@@ -1520,7 +1533,7 @@ putWord8 1 putWord8 (fromFVal iformat) replicateM_ 12 $ putWord8 0- putLazyByteString idata+ putLazyByteString (op ImageData idata) putUserAttrSubPacket' (OtherUASub t bs) = do putWord8 t putLazyByteString bs@@ -1651,7 +1664,7 @@ putWord8 $ fromIntegral . fromFVal $ ha putWord8 $ fromIntegral . fromFVal $ pka putLazyByteString (unEOKI skeyid)- putWord8 . fromIntegral . fromEnum $ not nested+ putWord8 . fromIntegral . fromEnum $ not (unNestedFlag nested) putLengthThenPayload bs putOPSV6 :: OPSPayloadV6 -> Put@@ -1688,7 +1701,7 @@ putWord8 (fromIntegral saltSize) putLazyByteString saltBytes putLazyByteString signerFingerprint- putWord8 . fromIntegral . fromEnum $ not nested+ putWord8 . fromIntegral . fromEnum $ not (unNestedFlag nested) putLengthThenPayload bs putSecretKey :: SomePKPayload -> SKAddendum -> Put@@ -1739,8 +1752,8 @@ let bs = runPut $ do putWord8 $ fromIntegral . fromFVal $ dt- putWord8 $ fromIntegral . BL.length $ fn- putLazyByteString fn+ putWord8 $ fromIntegral . B.length . op FileName $ fn+ putByteString (op FileName fn) putWord32be . unThirtyTwoBitTimeStamp $ ts putLazyByteString b putLengthThenPayload bs@@ -2308,8 +2321,8 @@ put kdfSA parseOPSNestedFlag :: Word8 -> Get NestedFlag-parseOPSNestedFlag 0 = pure True-parseOPSNestedFlag 1 = pure False+parseOPSNestedFlag 0 = pure (NestedFlag True)+parseOPSNestedFlag 1 = pure (NestedFlag False) parseOPSNestedFlag other = fail ("invalid OPS nested flag octet: " ++ show other) @@ -3502,6 +3515,7 @@ (\ska -> put (SecretKey pkp ska)) (snd (tk ^. tkuKey)) mapM_ (put . Signature) (_tkuRevs tk)+ mapM_ (put . Signature) (_tkuDirectKeySigs tk) mapM_ putUid' (_tkuUIDs tk) mapM_ putUat' (_tkuUAts tk) mapM_ putSub' (_tkuSubs tk)
Codec/Encryption/OpenPGP/SerializeForSigs.hs view
@@ -231,10 +231,10 @@ kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig PrimaryKeyBindingSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state)-payloadForSig SignatureDirectlyOnAKey state =+payloadForSig DirectKeySignature state = runPut (putKeyforSigning (lastPrimaryKey state)) payloadForSig KeyRevocationSig state =- payloadForSig SignatureDirectlyOnAKey state+ payloadForSig DirectKeySignature state payloadForSig SubkeyRevocationSig state = kandKPayload (lastPrimaryKey state) (lastSubkey state) payloadForSig CertRevocationSig state =
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -320,7 +320,7 @@ renderSignError (SignUnsupportedKeySignatureType st) = "unsupported key signature type: " ++ show st- ++ " (expected SignatureDirectlyOnAKey or KeyRevocationSig)"+ ++ " (expected DirectKeySignature or KeyRevocationSig)" renderSignError (SignV6SaltSizeMismatch ha expected actual) = "v6 signature salt size mismatch for " ++ show ha@@ -640,6 +640,7 @@ verifyTKWith vsf mt tk = do revokers <- checkRevokers tk revs <- checkKeyRevocations revokers tk+ directKeySigs <- checkDirectKeySigs tk let uids = filter (not . null . snd) . checkUidSigs $ tk ^. tkUIDs let uats = filter (not . null . snd) . checkUAtSigs $ tk ^. tkUAts let subs = concatMap checkSub $ tk ^. tkSubs@@ -647,6 +648,7 @@ TK { _tkPrimaryKey = tk ^. tkPrimaryKey , _tkRevs = revs+ , _tkDirectKeySigs = directKeySigs , _tkUIDs = uids , _tkUAts = uats , _tkSubs = subs@@ -658,7 +660,7 @@ . rights . map verifyRevoker . filter isRevokerP- $ tk ^. tkRevs+ $ tk ^. tkDirectKeySigs checkKeyRevocations :: [(PubKeyAlgorithm, Fingerprint)] -> TK k@@ -670,6 +672,20 @@ . map (liftM2 fmap (,) vSig) $ k ^. tkRevs+ checkDirectKeySigs+ :: TK k+ -> Either VerificationError [SignaturePayload]+ checkDirectKeySigs k =+ map fst+ <$> sequence+ ( concatMap+ ( \sp ->+ case vSig sp of+ Left err -> [Left err]+ Right verification -> [Right (sp, verification)]+ )+ (k ^. tkDirectKeySigs)+ ) checkUidSigs :: [(Text, [SignaturePayload])] -> [(Text, [SignaturePayload])] checkUidSigs =@@ -718,9 +734,6 @@ -> [Either VerificationError SignaturePayload] filterRevs vokers spv = case spv of- (s, _)- | isV4OrV6Sig s && sigType s == Just SignatureDirectlyOnAKey ->- [Right s | signatureKnown s] (s, v) | isV4OrV6Sig s , sigType s == Just KeyRevocationSig@@ -1714,7 +1727,7 @@ signDirectKeyWithRSA :: SigType- -- ^ key-scoped signature type (SignatureDirectlyOnAKey or KeyRevocationSig)+ -- ^ key-scoped signature type (DirectKeySignature or KeyRevocationSig) -> SomePKPayload -- ^ primary key "payload" being signed -> [SigSubPacket]@@ -1725,7 +1738,7 @@ -- ^ RSA signing key -> Either SignError SignaturePayload signDirectKeyWithRSA st pkp hsigsubs usigsubs prv- | st `elem` [SignatureDirectlyOnAKey, KeyRevocationSig] =+ | st `elem` [DirectKeySignature, KeyRevocationSig] = signDataWithRSA st prv hsigsubs usigsubs keypayload | otherwise = Left (SignUnsupportedKeySignatureType st)
Codec/Encryption/OpenPGP/Types/Internal/Base.hs view
@@ -24,20 +24,20 @@ , PubKeyAlgorithm (..) , ThirtyTwoBitTimeStamp (..) , ThirtyTwoBitDuration (..)- , Exportability- , TrustLevel- , TrustAmount+ , Exportability (..)+ , TrustLevel (..)+ , TrustAmount (..) , AlmostPublicDomainRegex- , Revocability- , RevocationReason+ , Revocability (..)+ , RevocationReason (..) , KeyServer- , SignatureHash+ , SignatureHash (..) , PacketVersion , V3Expiration , CompressedDataPayload- , FileName- , ImageData- , NestedFlag+ , FileName (..)+ , ImageData (..)+ , NestedFlag (..) , HashAlgorithm (..) , bsToHexUpper , Hashed@@ -137,6 +137,11 @@ import qualified Data.Aeson.TH as ATH import Data.Bits ((.&.)) import Data.ByteArray (ByteArrayAccess)+import Data.ByteArray.Encoding+ ( Base (..)+ , convertFromBase+ , convertToBase+ ) import qualified Data.ByteString as B import qualified Data.ByteString.Base16.Lazy as B16L import Data.ByteString.Lazy (ByteString)@@ -157,6 +162,8 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)+import Data.Text.Encoding.Error (lenientDecode) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Time.Format (formatTime) import Data.Time.Locale.Compat (defaultTimeLocale)@@ -169,37 +176,92 @@ import System.IO.Unsafe (unsafePerformIO) import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils- ( prettyLBS+ ( prettyBS+ , prettyLBS ) -type Exportability = Bool+newtype Exportability = Exportability {unExportability :: Bool}+ deriving (Data, Eq, Generic, Ord, Show, Typeable) -type TrustLevel = Word8+instance Wrapped Exportability -type TrustAmount = Word8+instance Hashable Exportability +instance Pretty Exportability where+ pretty = pretty . op Exportability++$(ATH.deriveJSON ATH.defaultOptions ''Exportability)++newtype TrustLevel = TrustLevel {unTrustLevel :: Word8}+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Wrapped TrustLevel++instance Hashable TrustLevel++instance Pretty TrustLevel where+ pretty = pretty . op TrustLevel++$(ATH.deriveJSON ATH.defaultOptions ''TrustLevel)++newtype TrustAmount = TrustAmount {unTrustAmount :: Word8}+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Wrapped TrustAmount++instance Hashable TrustAmount++instance Pretty TrustAmount where+ pretty = pretty . op TrustAmount++$(ATH.deriveJSON ATH.defaultOptions ''TrustAmount)+ type AlmostPublicDomainRegex = ByteString -type Revocability = Bool+newtype Revocability = Revocability {unRevocability :: Bool}+ deriving (Data, Eq, Generic, Ord, Show, Typeable) -type RevocationReason = Text+instance Wrapped Revocability -type KeyServer = ByteString+instance Hashable Revocability -type SignatureHash = ByteString+instance Pretty Revocability where+ pretty = pretty . op Revocability +$(ATH.deriveJSON ATH.defaultOptions ''Revocability)++newtype RevocationReason = RevocationReason {unRevocationReason :: Text}+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Wrapped RevocationReason++instance Hashable RevocationReason++instance Pretty RevocationReason where+ pretty = pretty . op RevocationReason++$(ATH.deriveJSON ATH.defaultOptions ''RevocationReason)++type KeyServer = ByteString+ type PacketVersion = Word8 type V3Expiration = Word16 type CompressedDataPayload = ByteString -type FileName = ByteString+newtype NestedFlag = NestedFlag {unNestedFlag :: Bool}+ deriving (Data, Eq, Generic, Ord, Show, Typeable) -type ImageData = ByteString+instance Wrapped NestedFlag -type NestedFlag = Bool+instance Hashable NestedFlag +instance Pretty NestedFlag where+ pretty = pretty . op NestedFlag++$(ATH.deriveJSON ATH.defaultOptions ''NestedFlag)+ {- | Phantom types for tracking subpacket classification and signature version These types are never instantiated; they exist purely for compile-time type safety. -}@@ -671,6 +733,74 @@ hexToW8s :: ReadS Word8 hexToW8s = concatMap readHex . chunksOf 2 . map toLower +newtype SignatureHash = SignatureHash {unSignatureHash :: B.ByteString}+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Wrapped SignatureHash++instance Hashable SignatureHash++instance Pretty SignatureHash where+ pretty = prettyBS . op SignatureHash++instance A.ToJSON SignatureHash where+ toJSON =+ A.toJSON+ . BLC8.unpack+ . BL.fromStrict+ . convertToBase Base64+ . op SignatureHash++instance A.FromJSON SignatureHash where+ parseJSON = A.withText "SignatureHash" $ \t ->+ either+ fail+ (pure . SignatureHash)+ (convertFromBase Base64 (encodeUtf8 t))++newtype FileName = FileName {unFileName :: B.ByteString}+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Wrapped FileName++instance Hashable FileName++instance Pretty FileName where+ pretty = prettyBS . op FileName++instance A.ToJSON FileName where+ toJSON = A.toJSON . decodeUtf8With lenientDecode . op FileName++instance A.FromJSON FileName where+ parseJSON = A.withText "FileName" $ \t ->+ pure (FileName (encodeUtf8 t))++newtype ImageData = ImageData {unImageData :: ByteString}+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Wrapped ImageData++instance Hashable ImageData++instance Pretty ImageData where+ pretty = prettyLBS . op ImageData++instance A.ToJSON ImageData where+ toJSON =+ A.toJSON+ . BLC8.unpack+ . BL.fromStrict+ . convertToBase Base64+ . BL.toStrict+ . op ImageData++instance A.FromJSON ImageData where+ parseJSON = A.withText "ImageData" $ \t ->+ either+ fail+ (pure . ImageData . BL.fromStrict)+ (convertFromBase Base64 (encodeUtf8 t))+ newtype EightOctetKeyId = EightOctetKeyId { unEOKI :: ByteString@@ -1088,7 +1218,7 @@ | PositiveCert | SubkeyBindingSig | PrimaryKeyBindingSig- | SignatureDirectlyOnAKey+ | DirectKeySignature | KeyRevocationSig | SubkeyRevocationSig | CertRevocationSig@@ -1113,7 +1243,7 @@ fromFVal PositiveCert = 0x13 fromFVal SubkeyBindingSig = 0x18 fromFVal PrimaryKeyBindingSig = 0x19- fromFVal SignatureDirectlyOnAKey = 0x1F+ fromFVal DirectKeySignature = 0x1F fromFVal KeyRevocationSig = 0x20 fromFVal SubkeyRevocationSig = 0x28 fromFVal CertRevocationSig = 0x30@@ -1129,7 +1259,7 @@ toFVal 0x13 = PositiveCert toFVal 0x18 = SubkeyBindingSig toFVal 0x19 = PrimaryKeyBindingSig- toFVal 0x1F = SignatureDirectlyOnAKey+ toFVal 0x1F = DirectKeySignature toFVal 0x20 = KeyRevocationSig toFVal 0x28 = SubkeyRevocationSig toFVal 0x30 = CertRevocationSig@@ -1149,7 +1279,7 @@ pretty PositiveCert = pretty "positive" pretty SubkeyBindingSig = pretty "subkey-binding" pretty PrimaryKeyBindingSig = pretty "primary-key-binding"- pretty SignatureDirectlyOnAKey = pretty "signature directly on a key"+ pretty DirectKeySignature = pretty "signature directly on a key" pretty KeyRevocationSig = pretty "key-revocation" pretty SubkeyRevocationSig = pretty "subkey-revocation" pretty CertRevocationSig = pretty "cert-revocation"@@ -1554,7 +1684,7 @@ pretty "signature target" <+> pretty pka <+> pretty ha- <+> prettyLBS sh+ <+> prettyBS (op SignatureHash sh) pretty (EmbeddedSignature sp) = pretty "embedded signature" <+> pretty sp pretty (IssuerFingerprint kv ifp) = pretty "issuer fingerprint (v"@@ -1610,7 +1740,9 @@ toJSON (Features ffs) = object [AK.fromString "features" .= ffs] toJSON (SignatureTarget pka ha sh) = object- [AK.fromString "signatureTarget" .= (pka, ha, BL.unpack sh)]+ [ AK.fromString "signatureTarget"+ .= (pka, ha, B.unpack (op SignatureHash sh))+ ] toJSON (EmbeddedSignature sp) = object [AK.fromString "embeddedSignature" .= sp] toJSON (IssuerFingerprint kv ifp) =@@ -2032,14 +2164,16 @@ instance Pretty UserAttrSubPacket where pretty (ImageAttribute ih d) =- pretty "image-attribute" <+> pretty ih <+> pretty (BL.unpack d)+ pretty "image-attribute"+ <+> pretty ih+ <+> pretty (BL.unpack (op ImageData d)) pretty (OtherUASub t bs) = pretty "unknown attribute type" <> pretty t <+> pretty (BL.unpack bs) instance A.ToJSON UserAttrSubPacket where- toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack d)+ toJSON (ImageAttribute ih d) = A.toJSON (ih, BL.unpack (op ImageData d)) toJSON (OtherUASub t bs) = A.toJSON (t, BL.unpack bs) -- FIXME: should this be merged with EdSigningCurve somehow?
Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs view
@@ -17,10 +17,11 @@ module Codec.Encryption.OpenPGP.Types.Internal.Pkt where import Control.Error.Util (hush)-import Control.Lens (makeLenses)+import Control.Lens (makeLenses, op) import Data.Aeson (object, (.=)) import qualified Data.Aeson as A import qualified Data.Aeson.Key as AK+import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Data@@ -45,7 +46,8 @@ import Codec.Encryption.OpenPGP.Types.Internal.Base import Codec.Encryption.OpenPGP.Types.Internal.PKITypes import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils- ( prettyLBS+ ( prettyBS+ , prettyLBS ) data PKESKPayloadVersion = PKESKV3 | PKESKV6@@ -381,7 +383,7 @@ pretty (LiteralDataPkt dt fn ts bs) = pretty "literal-data" <+> pretty dt- <+> prettyLBS fn+ <+> prettyBS (op FileName fn) <+> pretty ts <+> pretty (bsToHexUpper bs) pretty (TrustPkt bs) = pretty "trust:" <+> pretty (BL.unpack bs)@@ -532,7 +534,7 @@ [ AK.fromString "literaldata" .= object [ AK.fromString "dt" .= dt- , AK.fromString "filename" .= BL.unpack fn+ , AK.fromString "filename" .= B.unpack (op FileName fn) , AK.fromString "ts" .= ts , AK.fromString "data" .= BL.unpack bs ]
Codec/Encryption/OpenPGP/Types/Internal/TK.hs view
@@ -14,8 +14,132 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Codec.Encryption.OpenPGP.Types.Internal.TK where+module Codec.Encryption.OpenPGP.Types.Internal.TK+ ( -- * Types+ TKUnknown (..)+ , TK (..)+ , SomeTK (..)+ , TKKind (..)+ , TKConversionError (..)+ , PacketZipper (..)+ , TKKindToKeyPktKind+ , KeyringIxs+ , PublicKeyring+ , SecretKeyring+ , KeyringOf + -- * Structured types+ , TKWithWireRep (..)+ , PacketRefId (..)+ , SignatureWithWireRef (..)+ , UIDWithWireRefs (..)+ , UATWithWireRefs (..)+ , SubkeyWithWireRefs (..)+ , TKStructuredWithWireRep (..)+ , CanonicalizeTKWithWireRepError (..)++ -- * Constructors+ , mkTKUnknown+ , fromPrimaryKeyPktToSomeTK++ -- * Conversions+ , tkToUnknown+ , someTKToUnknown+ , someTKToPublicTK+ , someTKToSecretTK+ , someTKToPublicViewTK+ , publicViewTK+ , fromUnknownToTK+ , fromUnknownToTKEither+ , tkSecretKeyPairs+ , modifyTKSecretKeys++ -- * Canonicalization+ , canonicalizeTKStructuredWithWireRep+ , canonicalizeTKWithWireRep+ , toStructuredTKWithWireRep++ -- * Wire representation+ , wireRepOfTK+ , wireRepsOfTK+ , packetRefsOfTK+ , packetRefIdOf+ , lookupPacketRef+ , packetWireBytesForRef+ , tksFromWireRep+ , tksContainingPacket++ -- * Sorting/comparison+ , signatureWireSortKey+ , uidWireSortKey+ , uatWireSortKey+ , subkeyWireSortKey+ , compareSignatureWithWireRefCanonical+ , compareUIDWithWireRefsCanonical+ , compareUATWithWireRefsCanonical+ , compareSubkeyWithWireRefsCanonical+ , sortCanonicalByKey+ , sortSignatureWithWireRefsCanonical+ , sortUIDWithWireRefsCanonical+ , sortUATWithWireRefsCanonical+ , sortSubkeyWithWireRefsCanonical++ -- * Instances+ , Eq (..)+ , Ord (..)+ , Show (..)++ -- * Lenses+ , tkuKey+ , tkuRevs+ , tkuDirectKeySigs+ , tkuUIDs+ , tkuUAts+ , tkuSubs+ , tkPrimaryKey+ , tkRevs+ , tkDirectKeySigs+ , tkUIDs+ , tkUAts+ , tkSubs+ , tkWireRepRefs+ , tkWireRepRange+ , tkPackets+ , tkStructuredWireRepRefs+ , tkStructuredWireRepRange+ , tkStructuredPrimaryKey+ , tkStructuredPrimaryKeyRef+ , tkStructuredRevs+ , tkStructuredDirectKeySigs+ , tkStructuredUIDs+ , tkStructuredUAts+ , tkStructuredSubkeys+ , tkStructuredPacketRefs+ , signatureWithWireRefRef+ , signatureWithWireRefValue+ , uidWithWireRefsRef+ , uidWithWireRefsValue+ , uidWithWireRefsSignatures+ , uatWithWireRefsRef+ , uatWithWireRefsValue+ , uatWithWireRefsSignatures+ , subkeyWithWireRefsRef+ , subkeyWithWireRefsValue+ , subkeyWithWireRefsSignatures+ , pktWireRep+ , pktValue+ , pktIndex+ , pktRange+ , pktWireRepRef+ , zpBefore+ , zpCurrent+ , zpAfter+ , packetRefWireRepRef+ , packetRefIndex+ , rangeOffset+ , rangeLength+ ) where+ import Control.Arrow ((&&&)) import Control.Comonad (Comonad (..)) import Control.Error.Util (note)@@ -108,6 +232,7 @@ = TKUnknown { _tkuKey :: (SomePKPayload, Maybe SKAddendum) , _tkuRevs :: [SignaturePayload]+ , _tkuDirectKeySigs :: [SignaturePayload] , _tkuUIDs :: [(Text, [SignaturePayload])] , _tkuUAts :: [([UserAttrSubPacket], [SignaturePayload])] , _tkuSubs :: [(Pkt, [SignaturePayload])]@@ -127,6 +252,7 @@ = TK { _tkPrimaryKey :: KeyPkt (TKKindToKeyPktKind k) , _tkRevs :: [SignaturePayload]+ , _tkDirectKeySigs :: [SignaturePayload] , _tkUIDs :: [(Text, [SignaturePayload])] , _tkUAts :: [([UserAttrSubPacket], [SignaturePayload])] , _tkSubs :: [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]@@ -153,6 +279,8 @@ | SecretSubkeyHasPrimaryRole | ExpectedPublicSubkeyPacket Word8 | ExpectedSecretSubkeyPacket Word8+ | ExpectedPublicPrimaryKeyPacket Word8+ | ExpectedSecretPrimaryKeyPacket Word8 deriving (Eq, Show) renderTKConversionError :: TKConversionError -> String@@ -162,12 +290,17 @@ "expected public subkey, got packet tag " ++ show tagValue renderTKConversionError (ExpectedSecretSubkeyPacket tagValue) = "expected secret subkey, got packet tag " ++ show tagValue+renderTKConversionError (ExpectedPublicPrimaryKeyPacket tagValue) =+ "expected primary key packet, got packet tag " ++ show tagValue+renderTKConversionError (ExpectedSecretPrimaryKeyPacket tagValue) =+ "expected primary key packet, got packet tag " ++ show tagValue tkToUnknown :: TK k -> TKUnknown tkToUnknown tk = TKUnknown { _tkuKey = keyPktTKKey (_tkPrimaryKey tk) , _tkuRevs = _tkRevs tk+ , _tkuDirectKeySigs = _tkDirectKeySigs tk , _tkuUIDs = _tkUIDs tk , _tkuUAts = _tkUAts tk , _tkuSubs =@@ -183,18 +316,21 @@ TKUnknown { _tkuKey = (pkp, maybeSka) , _tkuRevs = []+ , _tkuDirectKeySigs = [] , _tkuUIDs = [] , _tkuUAts = [] , _tkuSubs = [] } -fromPrimaryKeyPktToSomeTK :: Pkt -> Either String SomeTK+fromPrimaryKeyPktToSomeTK+ :: Pkt -> Either TKConversionError SomeTK fromPrimaryKeyPktToSomeTK (PublicKeyPkt pkp) = Right ( SomePublicTK ( TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -207,17 +343,19 @@ ( TK { _tkPrimaryKey = KeyPktSecretPrimary pkp ska , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [] } ) )+fromPrimaryKeyPktToSomeTK (PublicSubkeyPkt _) =+ Left PublicSubkeyHasPrimaryRole+fromPrimaryKeyPktToSomeTK (SecretSubkeyPkt _ _) =+ Left SecretSubkeyHasPrimaryRole fromPrimaryKeyPktToSomeTK pkt =- Left- ( "expected primary key packet, got packet tag "- ++ show (pktTag pkt)- )+ Left (ExpectedPublicPrimaryKeyPacket (pktTag pkt)) someTKToPublicTK :: SomeTK -> Maybe (TK 'PublicTK) someTKToPublicTK (SomePublicTK tk) = Just tk@@ -236,6 +374,7 @@ TK { _tkPrimaryKey = keyPktToPublicView (_tkPrimaryKey tk) , _tkRevs = _tkRevs tk+ , _tkDirectKeySigs = _tkDirectKeySigs tk , _tkUIDs = _tkUIDs tk , _tkUAts = _tkUAts tk , _tkSubs =@@ -247,6 +386,35 @@ let xs = view (to _tkSubs) tk in xs ^.. (folded . _1 . to SomeKeyPkt) +tkSecretKeyPairs :: TK 'SecretTK -> [(SomePKPayload, SKAddendum)]+tkSecretKeyPairs tk =+ [ (keyPktPKPayload kp, secretKeyPktSKAddendum kp)+ | kp <- _tkPrimaryKey tk : map fst (_tkSubs tk)+ ]++modifyTKSecretKeys+ :: TK 'SecretTK+ -> (SomePKPayload -> SKAddendum -> (SomePKPayload, SKAddendum))+ -> TK 'SecretTK+modifyTKSecretKeys tk f =+ tk+ { _tkPrimaryKey = go (_tkPrimaryKey tk)+ , _tkSubs =+ map+ ( \(kp, sigs) ->+ (go kp, sigs)+ )+ (_tkSubs tk)+ }+ where+ go :: KeyPkt 'SecretPkt -> KeyPkt 'SecretPkt+ go (KeyPktSecretPrimary pkp ska) =+ let (pkp', ska') = f pkp ska+ in KeyPktSecretPrimary pkp' ska'+ go (KeyPktSecretSubkey pkp ska) =+ let (pkp', ska') = f pkp ska+ in KeyPktSecretSubkey pkp' ska'+ fromUnknownToTKEither :: TKUnknown -> Either TKConversionError SomeTK fromUnknownToTKEither tk =@@ -258,6 +426,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = _tkuRevs tk+ , _tkDirectKeySigs = _tkuDirectKeySigs tk , _tkUIDs = _tkuUIDs tk , _tkUAts = _tkuUAts tk , _tkSubs = subs@@ -271,6 +440,7 @@ TK { _tkPrimaryKey = KeyPktSecretPrimary pkp ska , _tkRevs = _tkuRevs tk+ , _tkDirectKeySigs = _tkuDirectKeySigs tk , _tkUIDs = _tkuUIDs tk , _tkUAts = _tkuUAts tk , _tkSubs = subs@@ -314,6 +484,11 @@ ( Set.toList $ Set.union (Set.fromList (_tkuRevs a)) (Set.fromList (_tkuRevs b)) )+ ( Set.toList $+ Set.union+ (Set.fromList (_tkuDirectKeySigs a))+ (Set.fromList (_tkuDirectKeySigs b))+ ) ((kvmerge `on` _tkuUIDs) a b) ((kvmerge `on` _tkuUAts) a b) ((ukvmerge `on` _tkuSubs) a b)@@ -332,6 +507,11 @@ ( Set.toList $ Set.union (Set.fromList (_tkRevs a)) (Set.fromList (_tkRevs b)) )+ ( Set.toList $+ Set.union+ (Set.fromList (_tkDirectKeySigs a))+ (Set.fromList (_tkDirectKeySigs b))+ ) ((kvmerge `on` _tkUIDs) a b) ((kvmerge `on` _tkUAts) a b) ((ukvmerge `on` _tkSubs) a b)@@ -409,7 +589,8 @@ , _tkStructuredWireRepRange :: Maybe ByteRange , _tkStructuredPrimaryKey :: (SomePKPayload, Maybe SKAddendum) , _tkStructuredPrimaryKeyRef :: PacketRefId- , _tkStructuredDirectSignatures :: [SignatureWithWireRef]+ , _tkStructuredRevs :: [SignatureWithWireRef]+ , _tkStructuredDirectKeySigs :: [SignatureWithWireRef] , _tkStructuredUIDs :: [UIDWithWireRefs] , _tkStructuredUAts :: [UATWithWireRefs] , _tkStructuredSubkeys :: [SubkeyWithWireRefs]@@ -606,7 +787,10 @@ buildTK <$> sortSignatureWithWireRefsCanonical structured- (_tkStructuredDirectSignatures structured)+ (_tkStructuredRevs structured)+ <*> sortSignatureWithWireRefsCanonical+ structured+ (_tkStructuredDirectKeySigs structured) <*> sortUIDWithWireRefsCanonical structured (_tkStructuredUIDs structured)@@ -617,10 +801,11 @@ structured (_tkStructuredSubkeys structured) where- buildTK directSigs uids uats subs =+ buildTK revs directKeySigs uids uats subs = TKUnknown { _tkuKey = _tkStructuredPrimaryKey structured- , _tkuRevs = map _signatureWithWireRefValue directSigs+ , _tkuRevs = map _signatureWithWireRefValue revs+ , _tkuDirectKeySigs = map _signatureWithWireRefValue directKeySigs , _tkuUIDs = map ( _uidWithWireRefsValue@@ -669,19 +854,22 @@ Nothing -> -- Primary key is the only packet; only valid if no revisions, UIDs, UATs, or subkeys if null (_tkuRevs tk)+ && null (_tkuDirectKeySigs tk) && null (_tkuUIDs tk) && null (_tkuUAts tk) && null (_tkuSubs tk) then Right z1' else Left "missing signatures/UIDs/subkeys after primary key packet"- (directSigs, z2) <-- consumeSigsZ "direct-key signatures" (_tkuRevs tk) z1- (uids, z3) <- consumeUIDsZ (_tkuUIDs tk) z2- (uats, z4) <- consumeUATsZ (_tkuUAts tk) z3- (subs, z5) <- consumeSubsZ (_tkuSubs tk) z4+ (revs, z2) <-+ consumeSigsZ "key-revocation signatures" (_tkuRevs tk) z1+ (directKeySigs, z3) <-+ consumeSigsZ "direct-key signatures" (_tkuDirectKeySigs tk) z2+ (uids, z4) <- consumeUIDsZ (_tkuUIDs tk) z3+ (uats, z5) <- consumeUATsZ (_tkuUAts tk) z4+ (subs, z6) <- consumeSubsZ (_tkuSubs tk) z5 -- Check if there are trailing packets AFTER the current focus (not including it)- case _zpAfter z5 of+ case _zpAfter z6 of [] -> Right ( TKStructuredWithWireRep@@ -689,7 +877,8 @@ (_tkWireRepRange tkWithRefs) (_tkuKey tk) (packetRefIdOf primaryRef)- directSigs+ revs+ directKeySigs uids uats subs
Data/Conduit/OpenPGP/Keyring/Instances.hs view
@@ -56,6 +56,7 @@ flattenTKPackets tk = [someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)] ++ map SignaturePkt (_tkuRevs tk)+ ++ map SignaturePkt (_tkuDirectKeySigs tk) ++ concatMap flattenUID (_tkuUIDs tk) ++ concatMap flattenUAT (_tkuUAts tk) ++ concatMap flattenSub (_tkuSubs tk)
Data/Conduit/OpenPGP/Verify.hs view
@@ -151,12 +151,12 @@ isOpeningOnePassSignature :: Pkt -> Bool isOpeningOnePassSignature ( OnePassSignaturePkt- (OPSPayloadV3Packet (OPSPayloadV3 _ _ _ _ _ False))+ (OPSPayloadV3Packet (OPSPayloadV3 _ _ _ _ _ (NestedFlag False))) ) = True isOpeningOnePassSignature ( OnePassSignaturePkt- (OPSPayloadV6Packet (OPSPayloadV6 _ _ _ _ _ False))+ (OPSPayloadV6Packet (OPSPayloadV6 _ _ _ _ _ (NestedFlag False))) ) = True isOpeningOnePassSignature _ = False
hOpenPGP.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP-Version: 3.3+Version: 3.4 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@@ -224,6 +224,7 @@ , Codec.Encryption.OpenPGP.Encrypt , Codec.Encryption.OpenPGP.Expirations , Codec.Encryption.OpenPGP.Fingerprint+ , Codec.Encryption.OpenPGP.KeyGeneration , Codec.Encryption.OpenPGP.KeyInfo , Codec.Encryption.OpenPGP.KeyringParser , Codec.Encryption.OpenPGP.KeySelection@@ -275,6 +276,7 @@ , Codec.Encryption.OpenPGP.Encrypt , Codec.Encryption.OpenPGP.Expirations , Codec.Encryption.OpenPGP.Fingerprint+ , Codec.Encryption.OpenPGP.KeyGeneration , Codec.Encryption.OpenPGP.KeyInfo , Codec.Encryption.OpenPGP.KeyringParser , Codec.Encryption.OpenPGP.KeySelection@@ -308,6 +310,7 @@ other-modules: Codec.Encryption.OpenPGP.Arbitrary , Tests.Common , Tests.Encryption+ , Tests.KeyGeneration , Tests.Keys , Tests.MessageAndArmor , Tests.Properties@@ -340,4 +343,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v3.3+ tag: v3.4
tests/Tests/Common.hs view
@@ -1604,7 +1604,7 @@ (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime case signDirectKeyWithRSA- SignatureDirectlyOnAKey+ DirectKeySignature signer (hashedExtras ++ hashed) unhashed@@ -1658,7 +1658,7 @@ , verificationMode = VerificationBatch } keyring- [ LiteralDataPkt BinaryData BL.empty 0 payload+ [ LiteralDataPkt BinaryData (FileName B.empty) 0 payload , SignaturePkt sigPayload ] @@ -1785,7 +1785,9 @@ messageIssuerSubpacketsAt signer creationTime case signKeyRevocationWithRSA signer- ( SigSubPacket False (ReasonForRevocation reasonCode "")+ ( SigSubPacket+ False+ (ReasonForRevocation reasonCode (RevocationReason "")) : hashedExtras ++ hashed )
tests/Tests/Encryption.hs view
@@ -1389,7 +1389,7 @@ [ esk , LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) "not-encrypted" ]@@ -1830,7 +1830,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -1915,7 +1915,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -2033,7 +2033,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -2251,7 +2251,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -3086,6 +3086,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signingPrimary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs =@@ -3126,6 +3127,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [])]@@ -3153,6 +3155,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signingPrimary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -3188,6 +3191,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]@@ -3223,6 +3227,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signingPrimary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -3262,6 +3267,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]@@ -3307,6 +3313,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs =@@ -3353,7 +3360,8 @@ let tk = TK { _tkPrimaryKey = KeyPktPublicPrimary primary- , _tkRevs = [directKeySig]+ , _tkRevs = []+ , _tkDirectKeySigs = [directKeySig] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]@@ -3402,6 +3410,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]@@ -3447,6 +3456,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]@@ -3487,6 +3497,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]@@ -3524,6 +3535,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]@@ -3557,6 +3569,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary primary , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]@@ -3637,7 +3650,9 @@ DC..| CL.consume case decrypted of [ OnePassSignaturePkt- (OPSPayloadV3Packet (OPSPayloadV3 3 BinarySig SHA256 RSA _ False))+ ( OPSPayloadV3Packet+ (OPSPayloadV3 3 BinarySig SHA256 RSA _ (NestedFlag False))+ ) , LiteralDataPkt _ _ _ gotPayload , SignaturePkt _ ] ->@@ -4177,7 +4192,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -4232,7 +4247,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) "payload" ]@@ -4307,7 +4322,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -4395,7 +4410,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -4509,7 +4524,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -4629,7 +4644,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -4740,7 +4755,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -4855,7 +4870,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -4987,7 +5002,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -5088,7 +5103,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -5216,7 +5231,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -5377,7 +5392,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -5513,7 +5528,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -5650,7 +5665,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -5810,7 +5825,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -5932,7 +5947,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -6029,7 +6044,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -6164,7 +6179,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -6300,7 +6315,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -6446,7 +6461,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -6574,7 +6589,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -6680,7 +6695,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]@@ -6786,7 +6801,7 @@ Block [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) payload ]
+ tests/Tests/KeyGeneration.hs view
@@ -0,0 +1,143 @@+-- 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.Monad.Trans.Except (runExceptT)+import Crypto.Random.Types (getRandomBytes)+import Data.Binary.Get (Get, runGetOrFail)+import Data.Binary.Put (runPut)+import qualified Data.ByteString.Lazy as BL+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit+ ( Assertion+ , assertEqual+ , assertFailure+ , testCase+ )++import Codec.Encryption.OpenPGP.KeyGeneration+ ( KeyGenSpec (..)+ , generateSecretKey+ )+import Codec.Encryption.OpenPGP.Serialize+ ( getSecretKey+ , putSKeyForPKPayload+ )+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+ ]+ ]++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 <-+ runExceptT $+ generateSecretKey (KeyGenRSA @V4 (ThirtyTwoBitTimeStamp 0) 1024)+ case result of+ Left err -> assertFailure ("generateSecretKey failed: " ++ err)+ Right (pkp, skey) -> roundTripAssertion "RSA V4" pkp skey++testRSAV6RoundTrip :: Assertion+testRSAV6RoundTrip = do+ result <-+ runExceptT $+ generateSecretKey (KeyGenRSA @V6 (ThirtyTwoBitTimeStamp 0) 1024)+ case result of+ Left err -> assertFailure ("generateSecretKey failed: " ++ err)+ Right (pkp, skey) -> 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 <-+ runExceptT $+ generateSecretKey (KeyGenEd25519 (ThirtyTwoBitTimeStamp 0))+ case result of+ Left err -> assertFailure ("generateSecretKey failed: " ++ err)+ Right (pkp, skey) -> roundTripAssertion "Ed25519 V6" pkp skey++testEd448V6RoundTrip :: Assertion+testEd448V6RoundTrip = do+ result <-+ runExceptT $+ generateSecretKey (KeyGenEd448 (ThirtyTwoBitTimeStamp 0))+ case result of+ Left err -> assertFailure ("generateSecretKey failed: " ++ err)+ Right (pkp, skey) -> roundTripAssertion "Ed448 V6" pkp skey++testX25519V6RoundTrip :: Assertion+testX25519V6RoundTrip = do+ result <-+ runExceptT $+ generateSecretKey (KeyGenX25519 (ThirtyTwoBitTimeStamp 0))+ case result of+ Left err -> assertFailure ("generateSecretKey failed: " ++ err)+ Right (pkp, skey) -> roundTripAssertion "X25519 V6" pkp skey++testX448V6RoundTrip :: Assertion+testX448V6RoundTrip = do+ result <-+ runExceptT $+ generateSecretKey (KeyGenX448 (ThirtyTwoBitTimeStamp 0))+ case result of+ Left err -> assertFailure ("generateSecretKey failed: " ++ err)+ Right (pkp, skey) -> roundTripAssertion "X448 V6" pkp skey
tests/Tests/Keys.hs view
@@ -593,7 +593,7 @@ packets = [ LiteralDataPkt BinaryData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) "payload" , SignaturePkt sigPayload@@ -633,6 +633,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary primarySigner , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -683,6 +684,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary primarySigner , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1072,6 +1074,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [longValidityCert, temporaryValidityCert])] , _tkUAts = [] , _tkSubs = []@@ -1137,6 +1140,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [firstCertification, secondCertification])] , _tkUAts = [] , _tkSubs = []@@ -1193,6 +1197,7 @@ TK (KeyPktPublicPrimary signer) []+ [] [(uidText, [certification])] [] []@@ -1256,6 +1261,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [certification, temporaryRevocation])] , _tkUAts = [] , _tkSubs = []@@ -1314,6 +1320,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [firstCertification, secondCertification])] , _tkUAts = [] , _tkSubs = []@@ -1345,12 +1352,13 @@ revocationTime [ SigSubPacket False- (ReasonForRevocation UserIdInfoNoLongerValid "")+ (ReasonForRevocation UserIdInfoNoLongerValid (RevocationReason "")) ] let tk :: TK 'PublicTK = TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [certification, retirementRevocation])] , _tkUAts = [] , _tkSubs = []@@ -1410,6 +1418,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary targetSigner , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [thirdPartyCertification])] , _tkUAts = [] , _tkSubs = []@@ -1418,6 +1427,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary thirdPartySigner , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1483,6 +1493,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary targetSigner , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [ ( uidText@@ -1500,6 +1511,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary thirdPartySigner , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1583,6 +1595,7 @@ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [ ( uidText@@ -1793,7 +1806,7 @@ testPolicySignatureContextValidation :: Assertion testPolicySignatureContextValidation = do let pkSigV4PK = SigV4 KeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| [])- pkSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| [])+ pkSigV4Direct = SigV4 DirectKeySignature RSA SHA512 [] [] 0 (MPI 0 :| []) pkSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) pkSigV6PK = SigV6@@ -1807,7 +1820,7 @@ (MPI 0 :| []) pkSigV6Direct = SigV6- SignatureDirectlyOnAKey+ DirectKeySignature EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x12))@@ -1827,7 +1840,7 @@ (MPI 0 :| []) skSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| []) skSigV4Revocation = SigV4 SubkeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| [])- skSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| [])+ skSigV4Direct = SigV4 DirectKeySignature RSA SHA512 [] [] 0 (MPI 0 :| []) skSigV6Binding = SigV6 SubkeyBindingSig@@ -1850,7 +1863,7 @@ (MPI 0 :| []) skSigV6Direct = SigV6- SignatureDirectlyOnAKey+ DirectKeySignature EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x16))@@ -1928,7 +1941,7 @@ "KeyRevocationSig allowed on primary key" (isAllowedPrimaryKeySig pkSigV4PK) assertTrue- "SignatureDirectlyOnAKey allowed on primary key"+ "DirectKeySignature allowed on primary key" (isAllowedPrimaryKeySig pkSigV4Direct) assertFalse "SubkeyBindingSig not allowed on primary key"@@ -1937,7 +1950,7 @@ "v6 KeyRevocationSig allowed on primary key" (isAllowedPrimaryKeySig pkSigV6PK) assertTrue- "v6 SignatureDirectlyOnAKey allowed on primary key"+ "v6 DirectKeySignature allowed on primary key" (isAllowedPrimaryKeySig pkSigV6Direct) assertFalse "v6 SubkeyBindingSig not allowed on primary key"@@ -1949,7 +1962,7 @@ "SubkeyRevocationSig allowed on subkey" (isAllowedSubkeySig skSigV4Revocation) assertFalse- "SignatureDirectlyOnAKey not allowed on subkey"+ "DirectKeySignature not allowed on subkey" (isAllowedSubkeySig skSigV4Direct) assertTrue "v6 SubkeyBindingSig allowed on subkey"@@ -1958,7 +1971,7 @@ "v6 SubkeyRevocationSig allowed on subkey" (isAllowedSubkeySig skSigV6Revocation) assertFalse- "v6 SignatureDirectlyOnAKey not allowed on subkey"+ "v6 DirectKeySignature not allowed on subkey" (isAllowedSubkeySig skSigV6Direct) assertTrue "GenericCert allowed on UID"@@ -2291,10 +2304,13 @@ case packets of (SecretKeyPkt pkp _ : _) -> case fromPrimaryKeyPktToSomeTK (PublicSubkeyPkt pkp) of- Left err ->+ Left PublicSubkeyHasPrimaryRole -> assertBool- "fromPrimaryKeyPktToSomeTK should report non-primary packet tags"- ("expected primary key packet" `isInfixOf` err)+ "fromPrimaryKeyPktToSomeTK should reject subkey packets"+ True+ Left _ ->+ assertFailure+ "fromPrimaryKeyPktToSomeTK should report PublicSubkeyHasPrimaryRole" Right _ -> assertFailure "fromPrimaryKeyPktToSomeTK should reject subkey packets"
tests/Tests/MessageAndArmor.hs view
@@ -971,7 +971,11 @@ salt = Salt (B.pack [0x20 .. 0x3f]) block = Block- [ LiteralDataPkt BinaryData BL.empty 0 (clearPayloadBytes payload)+ [ LiteralDataPkt+ BinaryData+ (FileName B.empty)+ 0+ (clearPayloadBytes payload) ] packets <- case encryptSEIPDv2WithSKESKBlock@@ -1042,7 +1046,9 @@ let passphraseBytes = "roundtrip-EAX" s2k = Argon2 (Salt16 (B.pack [0x10 .. 0x1f])) 1 4 15 salt = Salt (B.pack [0x20 .. 0x3f])- block = Block [LiteralDataPkt BinaryData BL.empty 0 "hello from EAX"]+ block =+ Block+ [LiteralDataPkt BinaryData (FileName B.empty) 0 "hello from EAX"] case encryptSEIPDv2WithSKESKBlock AES128 EAX@@ -1208,16 +1214,22 @@ >> fail "validateSEIPD1MDC failed" Right out -> pure out case parsePktsEither (BL.fromStrict cleartext) of- Right [LiteralDataPkt BinaryData filename timestamp clearPayload] -> do- assertEqual- "RFC4880 decrypted literal filename"- BL.empty- filename- assertEqual "RFC4880 decrypted literal timestamp" 0 timestamp- assertEqual- "RFC4880 decrypted literal payload"- (clearPayloadBytes payload)- clearPayload+ Right+ [ LiteralDataPkt+ BinaryData+ (FileName filename)+ timestamp+ clearPayload+ ] -> do+ assertEqual+ "RFC4880 decrypted literal filename"+ B.empty+ filename+ assertEqual "RFC4880 decrypted literal timestamp" 0 timestamp+ assertEqual+ "RFC4880 decrypted literal payload"+ (clearPayloadBytes payload)+ clearPayload Right other -> assertFailure ( "RFC4880 decrypted cleartext should contain exactly one literal packet, got "@@ -1387,11 +1399,14 @@ ) >> fail "unexpected RSA SigV6 signMessage output shape" let state =- emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ } keyring = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1439,11 +1454,14 @@ ) >> fail "unexpected Ed25519 signMessage output shape" let state =- emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ } keyring = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1498,11 +1516,14 @@ case signaturePkt of SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 _ _ _ _ _) -> do let state =- emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ } keyring = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1573,11 +1594,14 @@ ) >> fail "unexpected Ed448 signMessage output shape" let state =- emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ } keyring = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1696,12 +1720,15 @@ (signer, signingKey) <- loadDeterministicEd25519Signer let payload = "detached v4 eddsa payload without issuer hints" state =- emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ } keyring = mkTestKeyring [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1732,12 +1759,15 @@ (signer, signingKey) <- loadDeterministicEd25519Signer let payload = "detached v4 eddsa payload with fake issuer hint" state =- emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ } keyring = mkTestKeyring [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1772,11 +1802,14 @@ let payload = "detached v4 eddsa payload without issuer hints (verifyAgainstKeys)" state =- emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ } keys = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1809,11 +1842,14 @@ let payload = "detached v4 eddsa payload with fake issuer hint (verifyAgainstKeys)" state =- emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ } keys = [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1848,7 +1884,7 @@ { lastLD = LiteralDataPkt TextData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) "line1 \t\nline2\t \rline3\t \r\nline4 \t" }@@ -1868,7 +1904,7 @@ { lastLD = LiteralDataPkt TextData- BL.empty+ (FileName B.empty) (ThirtyTwoBitTimeStamp 0) "line1 \t\nline2\t \r\nline3" }@@ -2130,6 +2166,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -2385,7 +2422,9 @@ "fromPktEitherSomeSignatureV rejects non-signature packets" ( not ( isRight- (fromPktEitherSomeSignatureV (LiteralDataPkt BinaryData "" 0 ""))+ ( fromPktEitherSomeSignatureV+ (LiteralDataPkt BinaryData (FileName "") 0 "")+ ) ) ) @@ -2456,7 +2495,9 @@ assertEqual "recommendedArmorType defaults non-key/signature packets to message armor" (Just ArmorMessage)- (recommendedArmorType [LiteralDataPkt BinaryData "" 0 "payload"])+ ( recommendedArmorType+ [LiteralDataPkt BinaryData (FileName "") 0 "payload"]+ ) testSingleClearSignedBlock :: Assertion testSingleClearSignedBlock = do let clearSigned =@@ -2518,6 +2559,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation]+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -2556,6 +2598,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation]+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -2590,6 +2633,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation]+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -2624,6 +2668,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation]+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -2662,6 +2707,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation]+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -2711,6 +2757,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary signer , _tkRevs = [revocation]+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -2770,6 +2817,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary primarySigner , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = [(subkeyPacket, [bindingSig, revocationSig])]@@ -2893,12 +2941,15 @@ signerWithEd25519Pka let payload = "v4 eddsa signature with Ed25519 key algorithm" state =- emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ } keyring = mkTestKeyring [ TK { _tkPrimaryKey = KeyPktPublicPrimary signerWithEd25519Pka , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -3006,7 +3057,11 @@ state = emptyPSC { lastLD =- LiteralDataPkt BinaryData BL.empty 0 (BL.fromStrict fileContents)+ LiteralDataPkt+ BinaryData+ (FileName B.empty)+ 0+ (BL.fromStrict fileContents) } case verifySigWith defaultVerificationPolicy@@ -3059,6 +3114,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -3066,7 +3122,7 @@ ] state = emptyPSC- { lastLD = LiteralDataPkt BinaryData BL.empty 0 payload+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload } case verifySigWith defaultVerificationPolicy@@ -3118,6 +3174,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -3125,7 +3182,7 @@ ] state = emptyPSC- { lastLD = LiteralDataPkt BinaryData BL.empty 0 payload+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload } case verifySigWith defaultVerificationPolicy@@ -3160,7 +3217,7 @@ keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp)) sigPayload <- case signDataWithEd25519V6- SignatureDirectlyOnAKey+ DirectKeySignature salt edSecretKey hashed@@ -3177,6 +3234,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -3214,7 +3272,10 @@ [ SigSubPacket False (SigCreationTime 0) , SigSubPacket False- (ReasonForRevocation KeySuperseded "v6 fixture test")+ ( ReasonForRevocation+ KeySuperseded+ (RevocationReason "v6 fixture test")+ ) ] unhashed = [ SigSubPacket@@ -3241,6 +3302,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -3310,6 +3372,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [(uidText, [])] , _tkUAts = [] , _tkSubs = []
tests/Tests/Properties.hs view
@@ -237,10 +237,14 @@ Right structured -> let shuffled = structured- { _tkStructuredDirectSignatures =+ { _tkStructuredRevs = reverseIf reverseDirect- (_tkStructuredDirectSignatures structured)+ (_tkStructuredRevs structured)+ , _tkStructuredDirectKeySigs =+ reverseIf+ reverseDirect+ (_tkStructuredDirectKeySigs structured) , _tkStructuredUIDs = reverseIf reverseUIDs
tests/Tests/Serialization.hs view
@@ -1224,6 +1224,7 @@ [ TK { _tkPrimaryKey = KeyPktPublicPrimary pkp , _tkRevs = []+ , _tkDirectKeySigs = [] , _tkUIDs = [] , _tkUAts = [] , _tkSubs = []@@ -1231,7 +1232,7 @@ ] state = emptyPSC- { lastLD = LiteralDataPkt BinaryData BL.empty 0 payload+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload } testHash ha = do salt <- case signatureV6SaltSizeForHashAlgorithm ha of
tests/Tests/Utilities.hs view
@@ -225,7 +225,7 @@ (not (null images)) assertBool "uat.gpg should embed the uat.jpg payload"- (expectedImage `elem` images)+ (ImageData expectedImage `elem` images) testParsePktsUtil :: FilePath -> Assertion testParsePktsUtil fn = do@@ -439,6 +439,7 @@ TKUnknown (signer, Just secretAddendum) []+ [] [(uidText, [uidCertification])] [] [@@ -554,6 +555,7 @@ TKUnknown (signer, Just secretAddendum) []+ [] [(uidAText, [uidACert]), (uidBText, [uidBCert])] [] [(SecretSubkeyPkt authSubkey secretAddendum, [authBinding])]@@ -678,6 +680,7 @@ TKUnknown (signer, Just secretAddendum) []+ [] [(uidText, [uidCertification])] [] [@@ -966,7 +969,8 @@ (_tkStructuredSubkeys structured) refIds = _tkStructuredPrimaryKeyRef structured- : collectSigRefs (_tkStructuredDirectSignatures structured)+ : collectSigRefs (_tkStructuredRevs structured)+ ++ collectSigRefs (_tkStructuredDirectKeySigs structured) ++ uidRefs ++ uatRefs ++ subRefs@@ -994,8 +998,10 @@ Right structured -> do let shuffled = structured- { _tkStructuredDirectSignatures =- reverse (_tkStructuredDirectSignatures structured)+ { _tkStructuredRevs =+ reverse (_tkStructuredRevs structured)+ , _tkStructuredDirectKeySigs =+ reverse (_tkStructuredDirectKeySigs structured) , _tkStructuredUIDs = reverse ( map@@ -1071,7 +1077,8 @@ manualCanonicalizeStructured :: TKStructuredWithWireRep -> Either String TKUnknown manualCanonicalizeStructured structured = do- direct <- sortSigs (_tkStructuredDirectSignatures structured)+ revs <- sortSigs (_tkStructuredRevs structured)+ directKeySigs <- sortSigs (_tkStructuredDirectKeySigs structured) uids <- sortByRef _uidWithWireRefsRef =<< mapM@@ -1099,7 +1106,8 @@ Right $ TKUnknown { _tkuKey = _tkStructuredPrimaryKey structured- , _tkuRevs = map _signatureWithWireRefValue direct+ , _tkuRevs = map _signatureWithWireRefValue revs+ , _tkuDirectKeySigs = map _signatureWithWireRefValue directKeySigs , _tkuUIDs = map ( \(uid, sigs) ->@@ -1161,38 +1169,46 @@ Right structured -> do let badRef = PacketRefId src 999999 brokenWithBadRef =- case _tkStructuredDirectSignatures structured of+ case _tkStructuredRevs structured of (sig : rest) -> Just structured- { _tkStructuredDirectSignatures =+ { _tkStructuredRevs = sig {_signatureWithWireRefRef = badRef} : rest } [] ->- case _tkStructuredUIDs structured of- (uid : restUIDs) ->+ case _tkStructuredDirectKeySigs structured of+ (sig : rest) -> Just structured- { _tkStructuredUIDs =- uid {_uidWithWireRefsRef = badRef} : restUIDs+ { _tkStructuredDirectKeySigs =+ sig {_signatureWithWireRefRef = badRef} : rest } [] ->- case _tkStructuredUAts structured of- (uat : restUATs) ->+ case _tkStructuredUIDs structured of+ (uid : restUIDs) -> Just structured- { _tkStructuredUAts =- uat {_uatWithWireRefsRef = badRef} : restUATs+ { _tkStructuredUIDs =+ uid {_uidWithWireRefsRef = badRef} : restUIDs } [] ->- case _tkStructuredSubkeys structured of- (sub : restSubs) ->+ case _tkStructuredUAts structured of+ (uat : restUATs) -> Just structured- { _tkStructuredSubkeys =- sub {_subkeyWithWireRefsRef = badRef} : restSubs+ { _tkStructuredUAts =+ uat {_uatWithWireRefsRef = badRef} : restUATs }- [] -> Nothing+ [] ->+ case _tkStructuredSubkeys structured of+ (sub : restSubs) ->+ Just+ structured+ { _tkStructuredSubkeys =+ sub {_subkeyWithWireRefsRef = badRef} : restSubs+ }+ [] -> Nothing case brokenWithBadRef of Nothing -> assertFailure@@ -1542,6 +1558,7 @@ flattenTK tk = [someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)] ++ map SignaturePkt (_tkuRevs tk)+ ++ map SignaturePkt (_tkuDirectKeySigs tk) ++ concatMap flattenUID (_tkuUIDs tk) ++ concatMap flattenUAt (_tkuUAts tk) ++ concatMap flattenSub (_tkuSubs tk)
tests/suite.hs view
@@ -5,8 +5,10 @@ import Test.Tasty (TestTree, defaultMain, localOption, testGroup) import qualified Test.Tasty.QuickCheck as QC-import Test.Tasty.Runners (NumThreads(..))+import Test.Tasty.Runners (NumThreads (..))+ import Tests.Encryption (encryptionAndCompressionTests)+import Tests.KeyGeneration (keyGenerationTests) import Tests.Keys (keyAndVerificationTests) import Tests.MessageAndArmor (messageAndArmorTests) import Tests.Properties (propertiesTests)@@ -15,24 +17,26 @@ tests :: TestTree tests =- localOption- (NumThreads 4)- (testGroup- "Tests"- [ localOption (QC.QuickCheckTests 20) propertiesTests- , unitTests- ])+ localOption+ (NumThreads 4)+ ( testGroup+ "Tests"+ [ localOption (QC.QuickCheckTests 20) propertiesTests+ , unitTests+ ]+ ) unitTests :: TestTree unitTests =- testGroup- "Unit Tests"- [ serializationTests- , keyAndVerificationTests- , encryptionAndCompressionTests- , messageAndArmorTests- , utilityTests- ]+ testGroup+ "Unit Tests"+ [ keyGenerationTests+ , serializationTests+ , keyAndVerificationTests+ , encryptionAndCompressionTests+ , messageAndArmorTests+ , utilityTests+ ] main :: IO () main = defaultMain tests