hOpenPGP 3.4 → 3.5
raw patch · 26 files changed
+3993/−1659 lines, 26 files
Files
- Codec/Encryption/OpenPGP/Arbitrary.hs +20/−20
- Codec/Encryption/OpenPGP/Encrypt.hs +93/−60
- Codec/Encryption/OpenPGP/Fingerprint.hs +60/−40
- Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs +1/−2
- Codec/Encryption/OpenPGP/KeyGeneration.hs +1405/−134
- Codec/Encryption/OpenPGP/KeySelection.hs +25/−19
- Codec/Encryption/OpenPGP/Message.hs +13/−18
- Codec/Encryption/OpenPGP/S2K.hs +30/−23
- Codec/Encryption/OpenPGP/SecretKey.hs +140/−83
- Codec/Encryption/OpenPGP/Serialize.hs +94/−94
- Codec/Encryption/OpenPGP/SerializeForSigs.hs +12/−4
- Codec/Encryption/OpenPGP/Signatures.hs +323/−201
- Codec/Encryption/OpenPGP/Types/Internal/Base.hs +84/−56
- Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs +119/−91
- Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs +10/−9
- Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +29/−26
- Data/Conduit/OpenPGP/Decrypt.hs +49/−49
- hOpenPGP.cabal +2/−2
- tests/Tests/Common.hs +176/−130
- tests/Tests/Encryption.hs +349/−326
- tests/Tests/KeyGeneration.hs +321/−27
- tests/Tests/Keys.hs +90/−110
- tests/Tests/MessageAndArmor.hs +446/−65
- tests/Tests/Properties.hs +41/−21
- tests/Tests/Serialization.hs +53/−41
- tests/Tests/Utilities.hs +8/−8
Codec/Encryption/OpenPGP/Arbitrary.hs view
@@ -58,21 +58,21 @@ arbitrary = do rid <- oneof- [ pure BL.empty- , BL.pack <$> vector 20- , BL.pack . (4 :) <$> vector 20- , BL.pack <$> vector 32- , BL.pack . (6 :) <$> vector 32+ [ pure B.empty+ , B.pack <$> vector 20+ , B.pack . (4 :) <$> vector 20+ , B.pack <$> vector 32+ , B.pack . (6 :) <$> vector 32 ] pka <- arbitrary- esk <- BL.pack <$> listOf1 arbitrary+ esk <- B.pack <$> listOf1 arbitrary pure (PKESK6Packet rid pka esk) instance Arbitrary (SKESK 'SKESKV4) where arbitrary = do sa <- elements [AES128, AES192, AES256] s2k <- arbitrarySKESKv4S2K- esk <- oneof [pure Nothing, Just . BL.pack <$> listOf1 arbitrary]+ esk <- oneof [pure Nothing, Just . B.pack <$> listOf1 arbitrary] pure (SKESK4Packet sa s2k esk) instance Arbitrary (SKESK 'SKESKV6) where@@ -80,9 +80,9 @@ sa <- elements [AES128, AES192, AES256] aead <- elements [EAX, OCB, GCM] s2k <- arbitrarySKESKv6S2K- iv <- BL.pack <$> vector 16- esk <- BL.pack <$> listOf1 arbitrary- tag <- BL.pack <$> vector 16+ iv <- B.pack <$> vector 16+ esk <- B.pack <$> listOf1 arbitrary+ tag <- B.pack <$> vector 16 pure (SKESK6Packet sa aead s2k iv esk tag) arbitrarySKESKv4S2K :: Gen S2K@@ -103,7 +103,7 @@ <*> choose (3, 31) supportedSKESKHashAlgorithms :: [HashAlgorithm]-supportedSKESKHashAlgorithms = [SHA1, SHA256, SHA384, SHA512]+supportedSKESKHashAlgorithms = [SHA256, SHA384, SHA512, SHA224, SHA3_256, SHA3_512] instance Arbitrary Signature where arbitrary = fmap Signature arbitrary@@ -186,7 +186,7 @@ rk = arbitrary >>= \rcs -> arbitrary >>= \pka ->- fmap (RevocationKey rcs pka . Fingerprint . BL.pack) (vector 20)+ fmap (RevocationKey rcs pka . Fingerprint . B.pack) (vector 20) i = fmap Issuer arbitrary nd = arbitrary >>= \nfs ->@@ -215,16 +215,16 @@ fmap (IssuerFingerprint v) ( if v == IssuerFingerprintV6- then fmap (Fingerprint . BL.pack) (vector 32)- else fmap (Fingerprint . BL.pack) (vector 20)+ then fmap (Fingerprint . B.pack) (vector 32)+ else fmap (Fingerprint . B.pack) (vector 20) ) irfp = elements [IssuerFingerprintV4, IssuerFingerprintV6] >>= \v -> fmap (IntendedRecipient v) ( if v == IssuerFingerprintV6- then fmap (Fingerprint . BL.pack) (vector 32)- else fmap (Fingerprint . BL.pack) (vector 20)+ then fmap (Fingerprint . B.pack) (vector 32)+ else fmap (Fingerprint . B.pack) (vector 20) ) pacs = fmap PreferredAEADCiphersuites arbitrary udss =@@ -270,14 +270,14 @@ arbitrary = elements [RSA, DSA, ECDH, ECDSA, DH, EdDSALegacy] instance Arbitrary EightOctetKeyId where- arbitrary = fmap (EightOctetKeyId . BL.pack) (vector 8)+ arbitrary = fmap (EightOctetKeyId . B.pack) (vector 8) instance Arbitrary Fingerprint where arbitrary = oneof- [ fmap (Fingerprint . BL.pack) (vector 16) -- v3- , fmap (Fingerprint . BL.pack) (vector 20) -- v4- , fmap (Fingerprint . BL.pack) (vector 32) -- v6+ [ fmap (Fingerprint . B.pack) (vector 16) -- v3+ , fmap (Fingerprint . B.pack) (vector 20) -- v4+ , fmap (Fingerprint . B.pack) (vector 32) -- v6 ] instance Arbitrary MPI where
Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -144,6 +144,7 @@ import Codec.Encryption.OpenPGP.Fingerprint ( eightOctetKeyID , fingerprint+ , keyIdFromFingerprint ) import Codec.Encryption.OpenPGP.Internal ( checksum16Bytes@@ -210,6 +211,7 @@ | OPSBuildMissingIssuerFingerprint | OPSBuildFingerprintWrongLength Int64 | OPSBuildUnsupportedSigVersion PacketVersion+ | OPSBuildIssuerKeyIdProhibitedInV6 deriving (Eq, Show) renderOPSBuildError :: OPSBuildError -> String@@ -223,6 +225,8 @@ renderOPSBuildError (OPSBuildUnsupportedSigVersion v) = "cannot build one-pass signature packet for unsupported signature version " ++ show v+renderOPSBuildError OPSBuildIssuerKeyIdProhibitedInV6 =+ "cannot build OPS3 packet: Issuer Key ID subpacket is prohibited in v6 signatures" -- | Typed failures surfaced by encrypt-side PKESK and SEIPD-v2 helpers. data PKESKEncryptError@@ -972,7 +976,7 @@ { passphraseEncryptVersionPolicy :: PassphraseSKESKVersionPolicy , passphraseEncryptSymmetricAlgorithm :: SymmetricAlgorithm , passphraseEncryptS2K :: S2K- , passphraseEncryptPassphrase :: BL.ByteString+ , passphraseEncryptPassphrase :: Passphrase , passphraseEncryptPayload :: B.ByteString , passphraseEncryptSEIPDv1IVOverride :: Maybe IV , passphraseEncryptSEIPDv2AEADOverride :: Maybe AEADAlgorithm@@ -1116,18 +1120,18 @@ <$> canonicalizeRecipientKeyIdentifier rid canonicalizeRecipientKeyIdentifier- :: BL.ByteString -> Either PKESKEncryptError BL.ByteString+ :: B.ByteString -> Either PKESKEncryptError B.ByteString canonicalizeRecipientKeyIdentifier rid- | BL.length rid == 20 || BL.length rid == 32 = Right rid- | BL.length rid == 21 && BL.head rid == 0x04 =- Right (BL.tail rid)- | BL.length rid == 33 && BL.head rid == 0x06 =- Right (BL.tail rid)+ | B.length rid == 20 || B.length rid == 32 = Right rid+ | B.length rid == 21 && B.head rid == 0x04 =+ Right (B.tail rid)+ | B.length rid == 33 && B.head rid == 0x06 =+ Right (B.tail rid) | otherwise = Left ( InvalidRecipientIdentifier ( "unsupported PKESK recipient identifier length/prefix: "- ++ show (BL.length rid)+ ++ show (B.length rid) ) ) @@ -1818,14 +1822,14 @@ _ _ ) ->- case signatureIssuerKeyId hashedSubpackets unhashedSubpackets of- Just issuerKeyId ->+ case signatureIssuerKeyId 4 hashedSubpackets unhashedSubpackets of+ Right issuerKeyId -> Right ( OPSPayloadV3Packet (OPSPayloadV3 3 sigType hashAlgo pubkeyAlgo issuerKeyId nestedFlag) )- Nothing ->- Left OPSBuildMissingIssuerKeyId+ Left err ->+ Left err OnePassSignatureBuildCaseV6 ( SigPayloadV6Data sigType@@ -1844,7 +1848,7 @@ hashedSubpackets unhashedSubpackets of Just signerFingerprint- | BL.length signerFingerprint == 32 ->+ | B.length (unFingerprint signerFingerprint) == 32 -> Right ( OPSPayloadV6Packet ( OPSPayloadV6@@ -1858,51 +1862,77 @@ ) | otherwise -> Left- (OPSBuildFingerprintWrongLength (BL.length signerFingerprint))+ ( OPSBuildFingerprintWrongLength+ (fromIntegral (B.length (unFingerprint signerFingerprint)))+ ) Nothing -> Left OPSBuildMissingIssuerFingerprint OnePassSignatureBuildCaseOther version -> Left (OPSBuildUnsupportedSigVersion version) signatureIssuerKeyId- :: [SigSubPacket] -> [SigSubPacket] -> Maybe EightOctetKeyId-signatureIssuerKeyId hashedSubpackets unhashedSubpackets =- case findIssuerKeyId hashedSubpackets of- Just issuerKeyId -> Just issuerKeyId- Nothing ->- case findIssuerKeyId unhashedSubpackets of- Just issuerKeyId -> Just issuerKeyId+ :: PacketVersion+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> Either OPSBuildError EightOctetKeyId+signatureIssuerKeyId version hashedSubpackets unhashedSubpackets =+ case version of+ 4 ->+ case findIssuerKeyId hashedSubpackets of+ Just issuerKeyId -> Right issuerKeyId Nothing ->- case signatureIssuerFingerprint- ( BTypes.issuerFingerprintVersionToPacketVersion- BTypes.IssuerFingerprintV4- )- hashedSubpackets- unhashedSubpackets of- Just issuerFingerprintBytes ->- if BL.length issuerFingerprintBytes >= 8- then- Just- ( EightOctetKeyId- ( BL.drop- (BL.length issuerFingerprintBytes - 8)- issuerFingerprintBytes- )- )- else Nothing- Nothing -> Nothing+ case findIssuerKeyId unhashedSubpackets of+ Just issuerKeyId -> Right issuerKeyId+ Nothing ->+ case signatureIssuerFingerprint+ ( BTypes.issuerFingerprintVersionToPacketVersion+ BTypes.IssuerFingerprintV4+ )+ hashedSubpackets+ unhashedSubpackets of+ Just issuerFingerprint ->+ case keyIdFromFingerprint issuerFingerprint of+ Right keyId -> Right keyId+ Left _ ->+ Left+ ( OPSBuildFingerprintWrongLength+ (fromIntegral (B.length (unFingerprint issuerFingerprint)))+ )+ Nothing -> Left OPSBuildMissingIssuerKeyId+ 6 ->+ case findIssuerKeyId hashedSubpackets of+ Just _ -> Left OPSBuildIssuerKeyIdProhibitedInV6+ Nothing ->+ case findIssuerKeyId unhashedSubpackets of+ Just _ -> Left OPSBuildIssuerKeyIdProhibitedInV6+ Nothing ->+ case signatureIssuerFingerprint+ ( BTypes.issuerFingerprintVersionToPacketVersion+ BTypes.IssuerFingerprintV6+ )+ hashedSubpackets+ unhashedSubpackets of+ Just issuerFingerprint ->+ case keyIdFromFingerprint issuerFingerprint of+ Right keyId -> Right keyId+ Left _ ->+ Left+ ( OPSBuildFingerprintWrongLength+ (fromIntegral (B.length (unFingerprint issuerFingerprint)))+ )+ Nothing -> Left OPSBuildMissingIssuerFingerprint+ _ -> Left (OPSBuildUnsupportedSigVersion version) signatureIssuerFingerprint :: PacketVersion -> [SigSubPacket] -> [SigSubPacket]- -> Maybe BL.ByteString+ -> Maybe Fingerprint signatureIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets =- unFingerprint- <$> findIssuerFingerprint- expectedVersion- hashedSubpackets- unhashedSubpackets+ findIssuerFingerprint+ expectedVersion+ hashedSubpackets+ unhashedSubpackets findIssuerKeyId :: [SigSubPacket] -> Maybe EightOctetKeyId findIssuerKeyId subpackets =@@ -1952,7 +1982,10 @@ fmap ( \esk -> let mpiEsk = runPut (put (MPI (os2ip esk)))- in PKESKPayloadV6 (recipientKeyIdentifier recipient) RSA mpiEsk+ in PKESKPayloadV6+ (recipientKeyIdentifier recipient)+ RSA+ (BL.toStrict mpiEsk) ) (first (RecipientKeyWrapFailure RSA . show) encrypted) _ ->@@ -2238,7 +2271,7 @@ ( PKESKPayloadV6 (recipientKeyIdentifier recipient) X25519- (BL.fromStrict esk)+ esk ) buildX448PKESKv6@@ -2271,7 +2304,7 @@ ( PKESKPayloadV6 (recipientKeyIdentifier recipient) X448- (BL.fromStrict esk)+ esk ) buildEcdhV6Esk@@ -2300,7 +2333,7 @@ ( PKESKPayloadV6 (recipientKeyIdentifier recipient) pka- (BL.fromStrict esk)+ esk ) buildEcdhV3Payload@@ -2333,7 +2366,7 @@ (MPI (os2ip ephemeralBytes) :| [MPI (os2ip wrapped)]) ) -recipientKeyIdentifier :: SomePKPayload -> BL.ByteString+recipientKeyIdentifier :: SomePKPayload -> B.ByteString recipientKeyIdentifier = unFingerprint . fingerprint encodeV6EcdhEsk@@ -2535,10 +2568,10 @@ => SymmetricAlgorithm -> S2K -> Maybe IV- -> BL.ByteString+ -> Passphrase -> B.ByteString -> m (Either SEIPDv2Failure [Pkt])-encryptSEIPDv1WithSKESK symalgo s2k ivOverride passphrase literalPayload = do+encryptSEIPDv1WithSKESK symalgo s2k ivOverride (Passphrase passphrase) literalPayload = do let eSessionKey = do keyLen <- symKeySize symalgo first SEIPDv2SessionKeyError (string2Key s2k keyLen passphrase)@@ -2577,10 +2610,10 @@ -> Word8 -> Salt -> S2K- -> BL.ByteString+ -> Passphrase -> B.ByteString -> Either SEIPDv2Failure [Pkt]-encryptSEIPDv2WithSKESK symalgo aead chunkSize salt s2k passphrase literalPayload = do+encryptSEIPDv2WithSKESK symalgo aead chunkSize salt s2k (Passphrase passphrase) literalPayload = do keyLen <- symKeySize symalgo sessionKeyMaterial <- first SEIPDv2SessionKeyError (string2Key s2k keyLen passphrase)@@ -2612,9 +2645,9 @@ symalgo aead s2k- (BL.fromStrict skeskIV)- (BL.fromStrict wrappedSessionKey)- (BL.fromStrict skeskTag)+ skeskIV+ wrappedSessionKey+ skeskTag ) ) , SymEncIntegrityProtectedDataPkt@@ -2627,7 +2660,7 @@ -> Word8 -> Salt -> S2K- -> BL.ByteString+ -> Passphrase -> Block Pkt -> Either SEIPDv2Failure [Pkt] encryptSEIPDv2WithSKESKBlock symalgo aead chunkSize salt s2k passphrase packetBlock =@@ -2646,7 +2679,7 @@ -> Word8 -> Salt -> S2K- -> BL.ByteString+ -> Passphrase -> B.ByteString -> Either SEIPDv2Failure [Pkt] encryptSEIPDv2LiteralDataWithSKESK symalgo aead chunkSize salt s2k passphrase payload =@@ -2783,7 +2816,7 @@ -> Word8 -> Salt -> S2K- -> BL.ByteString+ -> Passphrase -> B.ByteString -> Maybe [Pkt] -> Either SEIPDv2Failure [Pkt]
Codec/Encryption/OpenPGP/Fingerprint.hs view
@@ -2,14 +2,14 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} module Codec.Encryption.OpenPGP.Fingerprint- ( eightOctetKeyID- , fingerprint- ) where+ ( eightOctetKeyID+ , fingerprint+ , keyIdFromFingerprint+ ) where import Crypto.Hash (Digest, hashlazy) import Crypto.Hash.Algorithms (MD5, SHA1, SHA256)@@ -20,52 +20,72 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL -import Codec.Encryption.OpenPGP.SerializeForSigs (putPKPforFingerprinting)+import Codec.Encryption.OpenPGP.SerializeForSigs+ ( putPKPforFingerprinting+ ) import Codec.Encryption.OpenPGP.Types eightOctetKeyID :: SomePKPayload -> Either String EightOctetKeyId eightOctetKeyID pkp =- case classifyFingerprintingKey pkp of- FingerprintingV3RSA _ rp -> Right (v3RSAKeyId rp)- FingerprintingV3NonRSA _ ->- Left "Cannot calculate the key ID of a non-RSA V3 key"- FingerprintingV4 pkpV4 ->- Right (EightOctetKeyId (BL.drop 12 (unFingerprint (fingerprintV4 pkpV4))))- FingerprintingV6 pkpV6 ->- Right (EightOctetKeyId (BL.take 8 (unFingerprint (fingerprintV6 pkpV6))))+ case classifyFingerprintingKey pkp of+ FingerprintingV3RSA _ rp -> Right (v3RSAKeyId rp)+ FingerprintingV3NonRSA _ ->+ Left "Cannot calculate the key ID of a non-RSA V3 key"+ FingerprintingV4 pkpV4 ->+ keyIdFromFingerprint (fingerprintV4 pkpV4)+ FingerprintingV6 pkpV6 ->+ keyIdFromFingerprint (fingerprintV6 pkpV6) +keyIdFromFingerprint+ :: Fingerprint -> Either String EightOctetKeyId+keyIdFromFingerprint (Fingerprint bs)+ | B.length bs == 20 = Right (EightOctetKeyId (B.drop 12 bs))+ | B.length bs == 32 = Right (EightOctetKeyId (B.take 8 bs))+ | otherwise =+ Left "cannot derive key ID from fingerprint of unexpected length"+ fingerprint :: SomePKPayload -> Fingerprint fingerprint pkp =- case classifyFingerprintingKey pkp of- FingerprintingV3RSA pkpV3 _ -> fingerprintV3 pkpV3- FingerprintingV3NonRSA pkpV3 -> fingerprintV3 pkpV3- FingerprintingV4 pkpV4 -> fingerprintV4 pkpV4- FingerprintingV6 pkpV6 -> fingerprintV6 pkpV6+ case classifyFingerprintingKey pkp of+ FingerprintingV3RSA pkpV3 _ -> fingerprintV3 pkpV3+ FingerprintingV3NonRSA pkpV3 -> fingerprintV3 pkpV3+ FingerprintingV4 pkpV4 -> fingerprintV4 pkpV4+ FingerprintingV6 pkpV6 -> fingerprintV6 pkpV6 data FingerprintingKey where- FingerprintingV3RSA ::- PKPayload 'DeprecatedV3- -> RSA.PublicKey- -> FingerprintingKey- FingerprintingV3NonRSA :: PKPayload 'DeprecatedV3 -> FingerprintingKey- FingerprintingV4 :: PKPayload 'V4 -> FingerprintingKey- FingerprintingV6 :: PKPayload 'V6 -> FingerprintingKey+ FingerprintingV3RSA+ :: PKPayload 'DeprecatedV3+ -> RSA.PublicKey+ -> FingerprintingKey+ FingerprintingV3NonRSA+ :: PKPayload 'DeprecatedV3 -> FingerprintingKey+ FingerprintingV4 :: PKPayload 'V4 -> FingerprintingKey+ FingerprintingV6 :: PKPayload 'V6 -> FingerprintingKey classifyFingerprintingKey :: SomePKPayload -> FingerprintingKey-classifyFingerprintingKey (SomePKPayload pkp@(PKPayloadV3 _ _ pka (RSAPubKey (RSA_PublicKey rp))))- | pka == RSA || pka == DeprecatedRSAEncryptOnly || pka == DeprecatedRSASignOnly =- FingerprintingV3RSA pkp rp+classifyFingerprintingKey+ ( SomePKPayload+ pkp@(PKPayloadV3 _ _ pka (RSAPubKey (RSA_PublicKey rp)))+ )+ | pka == RSA+ || pka == DeprecatedRSAEncryptOnly+ || pka == DeprecatedRSASignOnly =+ FingerprintingV3RSA pkp rp classifyFingerprintingKey (SomePKPayload pkp@PKPayloadV3 {}) =- FingerprintingV3NonRSA pkp+ FingerprintingV3NonRSA pkp classifyFingerprintingKey (SomePKPayload pkp@PKPayloadV4 {}) =- FingerprintingV4 pkp+ FingerprintingV4 pkp classifyFingerprintingKey (SomePKPayload pkp@PKPayloadV6 {}) =- FingerprintingV6 pkp+ FingerprintingV6 pkp v3RSAKeyId :: RSA.PublicKey -> EightOctetKeyId v3RSAKeyId =- EightOctetKeyId .- BL.reverse . BL.take 8 . BL.reverse . BL.fromStrict . i2osp . RSA.public_n+ EightOctetKeyId+ . B.reverse+ . B.take 8+ . B.reverse+ . i2osp+ . RSA.public_n fingerprintV3 :: PKPayload 'DeprecatedV3 -> Fingerprint fingerprintV3 = fingerprintFromDigestMD5 . serializeForFingerprinting@@ -78,19 +98,19 @@ serializeForFingerprinting :: PKPayload v -> BL.ByteString serializeForFingerprinting =- runPut . putPKPforFingerprinting . PublicKeyPkt . SomePKPayload+ runPut . putPKPforFingerprinting . PublicKeyPkt . SomePKPayload fingerprintFromDigestMD5 :: BL.ByteString -> Fingerprint fingerprintFromDigestMD5 serialized =- let digest = hashlazy serialized :: Digest MD5- in Fingerprint (BL.fromStrict (BA.convert digest :: B.ByteString))+ let digest = hashlazy serialized :: Digest MD5+ in Fingerprint (BA.convert digest) fingerprintFromDigestSHA1 :: BL.ByteString -> Fingerprint fingerprintFromDigestSHA1 serialized =- let digest = hashlazy serialized :: Digest SHA1- in Fingerprint (BL.fromStrict (BA.convert digest :: B.ByteString))+ let digest = hashlazy serialized :: Digest SHA1+ in Fingerprint (BA.convert digest) fingerprintFromDigestSHA256 :: BL.ByteString -> Fingerprint fingerprintFromDigestSHA256 serialized =- let digest = hashlazy serialized :: Digest SHA256- in Fingerprint (BL.fromStrict (BA.convert digest :: B.ByteString))+ let digest = hashlazy serialized :: Digest SHA256+ in Fingerprint (BA.convert digest)
Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs view
@@ -13,7 +13,6 @@ import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import Data.Bifunctor (first) import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL import Codec.Encryption.OpenPGP.BlockCipher ( keySize@@ -51,7 +50,7 @@ ( <> B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA] <> "Anonymous Sender "- <> BL.toStrict (unFingerprint (fingerprint recipientPKP))+ <> unFingerprint (fingerprint recipientPKP) ) <$> encodedCurveOid where
Codec/Encryption/OpenPGP/KeyGeneration.hs view
@@ -1,134 +1,1405 @@--- 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)+-- KeyGeneration.hs: OpenPGP (RFC9580) key generation and DSL+-- Copyright © 2026 Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}++module Codec.Encryption.OpenPGP.KeyGeneration+ ( -- * Legacy API (backward compatible)+ KeyGenSpec (..)+ , generateSecretKey++ -- * Duration DSL+ , Duration+ , seconds+ , minutes+ , hours+ , days+ , weeks+ , years++ -- * TK Generation DSL+ , TKGen+ , TKGenState+ , SubkeySpec+ , SignatureSpec+ , TKGenError (..)+ , newKey+ , addUID+ , addUIDWith+ , addSubkey+ , setKeySize+ , setExpiration+ , setSEIPDv1SymmetricPreferences+ , setHashPreferences+ , setCompressionPreferences+ , setAEADPreferences+ , setKeyServerPreferences+ , setFeatures+ , runTKGen+ , runTKGenWithSeed+ , withKeyVersionAndTimestamp+ ) where++import Control.Applicative (Alternative (..))+import Control.Monad (unless)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except+ ( ExceptT (..)+ , runExceptT+ , throwE+ )+import Control.Monad.Trans.RWS.Strict+ ( RWST (..)+ , ask+ , gets+ , modify+ , runRWST+ )+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+ ( ChaChaDRG+ , MonadPseudoRandom+ , drgNewSeed+ , seedFromBinary+ , withDRG+ )+import Crypto.Random.Types (MonadRandom, getRandomBytes)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import Data.Data (Data)+import Data.Kind (Type)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Text (Text)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Data.Typeable (Typeable)+import Data.Word (Word32)+import GHC.Generics (Generic)++import Codec.Encryption.OpenPGP.Fingerprint+ ( eightOctetKeyID+ , fingerprint+ )+import Codec.Encryption.OpenPGP.Internal+ ( PktStreamContext (..)+ , emptyPSC+ )+import Codec.Encryption.OpenPGP.SerializeForSigs+ ( payloadForSig+ )+import Codec.Encryption.OpenPGP.Signatures+ ( signDataWithEd25519Builder+ , signDataWithEd25519V6Builder+ , signDataWithEd448Builder+ , signDataWithEd448V6Builder+ , signDataWithRSABuilder+ , signDataWithRSAV6Builder+ )+import Codec.Encryption.OpenPGP.Subpackets+ ( addHashedSubs+ , addUnhashedSubs+ , listToHashedSubs+ , listToUnhashedSubs+ , sigBuilderInit+ , sigBuilderInitV6+ )+import Codec.Encryption.OpenPGP.Types++-- -----------------------------------------------------------------------------+-- V4/V6 algorithm mapping+-- -----------------------------------------------------------------------------++{- | Map a user-facing algorithm to the correct 'PubKeyAlgorithm' identifier+for the given key version. This ensures that V4 keys use the legacy+algorithm identifiers (e.g. 'EdDSALegacy' instead of 'Ed25519') while+V6 keys use the modern identifiers.+-}+algorithmForVersion+ :: KeyVersion -> PubKeyAlgorithm -> PubKeyAlgorithm+algorithmForVersion V4 Ed25519 = EdDSALegacy+algorithmForVersion V6 Ed25519 = Ed25519+algorithmForVersion V4 X25519 = ECDH+algorithmForVersion V6 X25519 = X25519+algorithmForVersion _ algo = algo++{- | Return the signing parameters (name, signature length, limb length, PKA)+for a given key version and algorithm. Used by the builder-based signing+functions in "Codec.Encryption.OpenPGP.Signatures".+-}+signingParams+ :: KeyVersion+ -> PubKeyAlgorithm+ -> (String, Int, Int, PubKeyAlgorithm)+signingParams V4 Ed25519 = ("Ed25519", 64, 32, EdDSALegacy)+signingParams V6 Ed25519 = ("Ed25519", 64, 32, Ed25519)+signingParams _ algo = error ("unsupported signing algorithm: " ++ show algo)++-- -----------------------------------------------------------------------------+-- Legacy API+-- -----------------------------------------------------------------------------++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 V6 ts+ KeyGenEd448 ts -> ed448Generate V6 ts+ KeyGenX25519 ts -> x25519Generate V6 ts+ KeyGenX448 ts -> x448Generate V6 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 _kv 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 _kv 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)++-- -----------------------------------------------------------------------------+-- Duration DSL+-- -----------------------------------------------------------------------------++newtype Duration = Duration+ { toThirtyTwoBitDuration :: ThirtyTwoBitDuration+ }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++seconds :: Word32 -> Duration+seconds n = Duration (ThirtyTwoBitDuration n)++minutes :: Word32 -> Duration+minutes n = Duration (ThirtyTwoBitDuration (n * 60))++hours :: Word32 -> Duration+hours n = Duration (ThirtyTwoBitDuration (n * 3600))++days :: Word32 -> Duration+days n = Duration (ThirtyTwoBitDuration (n * 86400))++weeks :: Word32 -> Duration+weeks n = Duration (ThirtyTwoBitDuration (n * 604800))++years :: Word32 -> Duration+years n = Duration (ThirtyTwoBitDuration (n * 31536000))++-- 365 days per year, no leap seconds++instance Semigroup Duration where+ Duration (ThirtyTwoBitDuration a) <> Duration (ThirtyTwoBitDuration b) =+ Duration (ThirtyTwoBitDuration (a + b))++-- -----------------------------------------------------------------------------+-- TK Generation DSL+-- -----------------------------------------------------------------------------++newtype TKGen (m :: Type -> Type) (v :: TKKind) a = TKGen+ { unTKGen+ :: RWST+ (KeyVersion, ThirtyTwoBitTimeStamp)+ [String]+ TKGenState+ (ExceptT TKGenError m)+ a+ }+ deriving newtype (Applicative, Functor, Monad)++data TKGenState = TKGenState+ { _tkGenPrimary :: Maybe (SomePKPayload, SKey)+ , _tkGenUIDs :: [Text]+ , _tkGenSubkeys :: [SubkeySpec]+ , _tkGenExpiration :: Maybe ThirtyTwoBitDuration+ , _tkGenPrefs :: Preferences+ , _tkGenLog :: [String]+ , _tkGenKeySizes :: Map PubKeyAlgorithm Int+ }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Semigroup TKGenState where+ a <> b =+ TKGenState+ { _tkGenPrimary = case _tkGenPrimary a of+ Nothing -> _tkGenPrimary b+ Just _ -> _tkGenPrimary a+ , _tkGenUIDs = _tkGenUIDs a <> _tkGenUIDs b+ , _tkGenSubkeys = _tkGenSubkeys a <> _tkGenSubkeys b+ , _tkGenExpiration = _tkGenExpiration a <|> _tkGenExpiration b+ , _tkGenPrefs = _tkGenPrefs a <> _tkGenPrefs b+ , _tkGenLog = _tkGenLog a <> _tkGenLog b+ , _tkGenKeySizes = _tkGenKeySizes a <> _tkGenKeySizes b+ }++instance Monoid TKGenState where+ mempty =+ TKGenState+ { _tkGenPrimary = Nothing+ , _tkGenUIDs = mempty+ , _tkGenSubkeys = mempty+ , _tkGenExpiration = Nothing+ , _tkGenPrefs = mempty+ , _tkGenLog = mempty+ , _tkGenKeySizes = mempty+ }++data Preferences = Preferences+ { _prefSymmetric :: [SymmetricAlgorithm]+ , _prefHash :: [HashAlgorithm]+ , _prefCompress :: [CompressionAlgorithm]+ , _prefAEAD :: [(SymmetricAlgorithm, AEADAlgorithm)]+ , _prefKeyServer :: Set KSPFlag+ , _prefFeatures :: Set FeatureFlag+ }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++instance Semigroup Preferences where+ a <> b =+ Preferences+ { _prefSymmetric = _prefSymmetric a <> _prefSymmetric b+ , _prefHash = _prefHash a <> _prefHash b+ , _prefCompress = _prefCompress a <> _prefCompress b+ , _prefAEAD = _prefAEAD a <> _prefAEAD b+ , _prefKeyServer = _prefKeyServer a <> _prefKeyServer b+ , _prefFeatures = _prefFeatures a <> _prefFeatures b+ }++instance Monoid Preferences where+ mempty =+ Preferences+ { _prefSymmetric = mempty+ , _prefHash = mempty+ , _prefCompress = mempty+ , _prefAEAD = mempty+ , _prefKeyServer = mempty+ , _prefFeatures = mempty+ }++data SubkeySpec = SubkeySpec+ { _subkeyPayload :: SomePKPayload+ , _subkeySKey :: SKey+ , _subkeyUsage :: Set KeyFlag+ , _subkeyTimestamp :: Maybe ThirtyTwoBitTimeStamp+ }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++data TKGenError+ = NoPrimaryKey+ | KeyGenFailed String+ | SignatureFailed String+ | SerializationFailed String+ | InvalidConfiguration String+ deriving (Eq, Show)++data SignatureSpec = SignatureSpec+ { _sigSpecExpiration :: Maybe Duration+ , _sigSpecKeyFlags :: Maybe (Set KeyFlag)+ }+ deriving (Data, Eq, Generic, Ord, Show, Typeable)++{- | Run a key-generation action with the given key version and timestamp.++The base monad @m@ must satisfy 'MonadRandom' because key material and+signature salts are drawn from it. No explicit seed is required; the+caller is responsible for providing a suitable random source (e.g. 'IO').+-}+runTKGen+ :: MonadRandom m+ => (KeyVersion, ThirtyTwoBitTimeStamp)+ -> TKGen m 'SecretTK a+ -> m (Either TKGenError (a, TK 'SecretTK))+runTKGen kvts (TKGen {unTKGen = action}) = do+ result <- runExceptT $ do+ (a, state, _log) <- runRWST action kvts mempty+ tk <- finalize state+ pure (a, tk)+ pure result++{- | Run a key-generation action with a deterministic seed.++This is useful for testing, where reproducible key material is required.+The seed is used to initialize a 'ChaChaDRG', and the final DRG state+is returned alongside the result so that the random sequence can be+continued if needed.+-}+runTKGenWithSeed+ :: B.ByteString+ -> (KeyVersion, ThirtyTwoBitTimeStamp)+ -> TKGen (MonadPseudoRandom ChaChaDRG) 'SecretTK a+ -> (Either TKGenError (a, TK 'SecretTK), ChaChaDRG)+runTKGenWithSeed seedBytes kvts (TKGen {unTKGen = action}) =+ case CE.eitherCryptoError (seedFromBinary seedBytes) of+ Left err -> error ("invalid seed: " ++ show err)+ Right seed' ->+ let drg = drgNewSeed seed'+ in withDRG drg $ runExceptT $ do+ (a, state, _log) <- runRWST action kvts mempty+ tk <- finalize state+ pure (a, tk)++{- | Obtain the current creation time paired with a chosen 'KeyVersion'.++Call this at the application boundary before 'runTKGen'.+-}+withKeyVersionAndTimestamp+ :: KeyVersion -> IO (KeyVersion, ThirtyTwoBitTimeStamp)+withKeyVersionAndTimestamp kv = do+ posix <- getPOSIXTime+ let ts = ThirtyTwoBitTimeStamp (fromIntegral (floor posix :: Word32))+ pure (kv, ts)++{- | Generate the primary key pair using the key version and timestamp from+the Reader. Uses a default RSA key size of 4096 bits for RSA keys.+-}+newKey+ :: forall m+ . MonadRandom m+ => PubKeyAlgorithm+ -> TKGen m 'SecretTK (SomePKPayload, SKey)+newKey algo = do+ (kv, ct) <- TKGen ask+ msize <- TKGen $ gets (Map.lookup algo . _tkGenKeySizes)+ let rsaSize = fromMaybe 4096 msize+ (pkp, skey) <- TKGen $ lift $ generateKey kv ct algo rsaSize+ TKGen $ modify $ \s -> s {_tkGenPrimary = Just (pkp, skey)}+ pure (pkp, skey)++{- | Set the key size for a variable-size algorithm (currently only RSA).+Calling this for a fixed-size algorithm (Ed25519, X25519, Ed448, X448,+etc.) will fail with 'InvalidConfiguration'.+-}+setKeySize+ :: forall m+ . Monad m+ => PubKeyAlgorithm+ -> Int+ -> TKGen m 'SecretTK ()+setKeySize algo size = case algo of+ RSA -> TKGen $ modify $ \s ->+ s {_tkGenKeySizes = Map.insert algo size (_tkGenKeySizes s)}+ _ ->+ TKGen $+ lift $+ throwE+ ( InvalidConfiguration+ ("key size can only be set for RSA, not " ++ show algo)+ )++-- | Append a user ID to the certificate.+addUID+ :: forall m+ . Monad m+ => Text+ -> TKGen m 'SecretTK ()+addUID uid = TKGen $ modify $ \s ->+ s {_tkGenUIDs = _tkGenUIDs s ++ [uid]}++-- | Append a user ID with an explicit 'SignatureSpec' override.+addUIDWith+ :: forall m+ . Monad m+ => Text+ -> SignatureSpec+ -> TKGen m 'SecretTK ()+addUIDWith _ _ = pure ()++-- SignatureSpec overrides are stored for finalization.+-- This placeholder preserves the API surface; the runtime+-- currently ignores per-UID overrides and uses the defaults.++{- | Generate a subkey (same key version as the primary) with the+specified key flags. Uses a default RSA key size of 4096 bits for+RSA keys.+-}+addSubkey+ :: MonadRandom m+ => PubKeyAlgorithm+ -> [KeyFlag]+ -> TKGen m 'SecretTK (SomePKPayload, SKey)+addSubkey algo flags = do+ (kv, ct) <- TKGen ask+ msize <- TKGen $ gets (Map.lookup algo . _tkGenKeySizes)+ let rsaSize = fromMaybe 4096 msize+ (pkp, skey) <- TKGen $ lift $ generateKey kv ct algo rsaSize+ TKGen $ modify $ \s ->+ s+ { _tkGenSubkeys =+ _tkGenSubkeys+ s+ ++ [ SubkeySpec+ { _subkeyPayload = pkp+ , _subkeySKey = skey+ , _subkeyUsage = Set.fromList flags+ , _subkeyTimestamp = Nothing+ }+ ]+ }+ pure (pkp, skey)++{- | Set a creation-time expiration for the whole certificate (relative+to the primary key's creation time). Omit the call entirely for a+non-expiring certificate.+-}+setExpiration+ :: forall m+ . Monad m+ => Duration+ -> TKGen m 'SecretTK ()+setExpiration dur = TKGen $ modify $ \s ->+ s {_tkGenExpiration = Just (toThirtyTwoBitDuration dur)}++-- | Attach symmetric algorithm preferences for SEIPDv1 that flow into every binding signature.+setSEIPDv1SymmetricPreferences+ :: forall m+ . Monad m+ => [SymmetricAlgorithm]+ -> TKGen m 'SecretTK ()+setSEIPDv1SymmetricPreferences sym = TKGen $ modify $ \s ->+ s {_tkGenPrefs = (_tkGenPrefs s) {_prefSymmetric = sym}}++-- | Attach hash algorithm preferences that flow into every binding signature.+setHashPreferences+ :: forall m+ . Monad m+ => [HashAlgorithm]+ -> TKGen m 'SecretTK ()+setHashPreferences hash = TKGen $ modify $ \s ->+ s {_tkGenPrefs = (_tkGenPrefs s) {_prefHash = hash}}++-- | Attach compression algorithm preferences that flow into every binding signature.+setCompressionPreferences+ :: forall m+ . Monad m+ => [CompressionAlgorithm]+ -> TKGen m 'SecretTK ()+setCompressionPreferences comp = TKGen $ modify $ \s ->+ s {_tkGenPrefs = (_tkGenPrefs s) {_prefCompress = comp}}++-- | Attach AEAD ciphersuite preferences that flow into every binding signature.+setAEADPreferences+ :: forall m+ . Monad m+ => [(SymmetricAlgorithm, AEADAlgorithm)]+ -> TKGen m 'SecretTK ()+setAEADPreferences aead = TKGen $ modify $ \s ->+ s {_tkGenPrefs = (_tkGenPrefs s) {_prefAEAD = aead}}++-- | Attach key server preferences that flow into every binding signature.+setKeyServerPreferences+ :: forall m+ . Monad m+ => Set KSPFlag+ -> TKGen m 'SecretTK ()+setKeyServerPreferences ksp = TKGen $ modify $ \s ->+ s {_tkGenPrefs = (_tkGenPrefs s) {_prefKeyServer = ksp}}++-- | Attach feature flags that flow into every binding signature.+setFeatures+ :: forall m+ . Monad m+ => Set FeatureFlag+ -> TKGen m 'SecretTK ()+setFeatures ff = TKGen $ modify $ \s ->+ s {_tkGenPrefs = (_tkGenPrefs s) {_prefFeatures = ff}}++-- -----------------------------------------------------------------------------+-- Internal key generation+-- -----------------------------------------------------------------------------++generateKey+ :: forall m+ . MonadRandom m+ => KeyVersion+ -> ThirtyTwoBitTimeStamp+ -> PubKeyAlgorithm+ -> Int+ -> ExceptT TKGenError m (SomePKPayload, SKey)+generateKey kv ts algo rsaSize = case algo of+ RSA -> rsaGenerate kv ts rsaSize+ EdDSALegacy -> ed25519Generate kv ts+ Ed448 -> ed448Generate kv ts+ ECDH -> x25519Generate kv ts+ X25519 -> x25519Generate kv ts+ X448 -> x448Generate kv ts+ Ed25519 -> ed25519Generate kv ts+ _ ->+ throwE+ ( KeyGenFailed+ ("unsupported algorithm for key generation: " ++ show algo)+ )+ where+ rsaGenerate kv ts keySizeBits = do+ unless (keySizeBits `mod` 8 == 0) $+ throwE (KeyGenFailed "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 V4 ts = do+ seed <- lift $ getRandomBytes 32+ secretKey <-+ either+ ( throwE+ . KeyGenFailed+ . ("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+ pure (PKPayload V4 ts 0 EdDSALegacy pkey, skey)+ ed25519Generate V6 ts = do+ seed <- lift $ getRandomBytes 32+ secretKey <-+ either+ ( throwE+ . KeyGenFailed+ . ("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+ pure (PKPayload V6 ts 0 Ed25519 pkey, skey)+ ed25519Generate DeprecatedV3 _ts =+ throwE (InvalidConfiguration "Ed25519 V3 is not supported")+ ed448Generate _kv ts = do+ seed <- lift $ getRandomBytes 57+ secretKey <-+ either+ ( throwE+ . KeyGenFailed+ . ("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 V4 ts = do+ secretRaw <- lift $ getRandomBytes 32+ secretKey <-+ either+ ( throwE+ . KeyGenFailed+ . ("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+ pure (PKPayload V4 ts 0 ECDH pkey, skey)+ x25519Generate V6 ts = do+ secretRaw <- lift $ getRandomBytes 32+ secretKey <-+ either+ ( throwE+ . KeyGenFailed+ . ("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+ pure (PKPayload V6 ts 0 X25519 pkey, skey)+ x25519Generate DeprecatedV3 _ts =+ throwE (InvalidConfiguration "X25519 V3 is not supported")+ x448Generate _kv ts = do+ secretRaw <- lift $ getRandomBytes 56+ secretKey <-+ either+ ( throwE+ . KeyGenFailed+ . ("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)++-- -----------------------------------------------------------------------------+-- Finalization+-- -----------------------------------------------------------------------------++finalize+ :: forall m+ . MonadRandom m+ => TKGenState+ -> ExceptT TKGenError m (TK 'SecretTK)+finalize state = do+ (primaryPkp, primarySKey) <-+ maybe (throwE NoPrimaryKey) pure (_tkGenPrimary state)+ let primaryPkt = KeyPktSecretPrimary primaryPkp (SUSUnprotected primarySKey 0)+ (kv, ct) = case primaryPkp of+ PKPayload _ ts _ _ _ -> (_keyVersion primaryPkp, ts)++ mdkSig <- case kv of+ DeprecatedV3 -> pure []+ _ ->+ signDirectKey+ kv+ primaryPkp+ primarySKey+ ct+ (_tkGenExpiration state)+ (_tkGenPrefs state)++ uids <-+ mapM (mkUID primaryPkp primarySKey kv ct) (_tkGenUIDs state)++ subs <-+ mapM+ (mkSubkey primaryPkp primarySKey kv ct)+ (_tkGenSubkeys state)++ let tk =+ TK+ { _tkPrimaryKey = primaryPkt+ , _tkRevs = []+ , _tkDirectKeySigs = mdkSig+ , _tkUIDs = uids+ , _tkUAts = []+ , _tkSubs = subs+ }+ pure tk+ where+ issuerFingerprintSub+ :: KeyVersion -> SomePKPayload -> SigSubPacket+ issuerFingerprintSub V4 pkp =+ SigSubPacket+ False+ (IssuerFingerprint IssuerFingerprintV4 (fingerprint pkp))+ issuerFingerprintSub V6 pkp =+ SigSubPacket+ False+ (IssuerFingerprint IssuerFingerprintV6 (fingerprint pkp))+ issuerFingerprintSub DeprecatedV3 pkp =+ SigSubPacket+ False+ (IssuerFingerprint IssuerFingerprintV4 (fingerprint pkp))++ issuerKeyIdSub :: SomePKPayload -> SigSubPacket+ issuerKeyIdSub pkp = case eightOctetKeyID pkp of+ Left err -> error ("failed to derive issuer key id: " ++ err)+ Right eoki -> SigSubPacket False (Issuer eoki)++ baseHashedSubs+ :: KeyVersion+ -> SomePKPayload+ -> ThirtyTwoBitTimeStamp+ -> Maybe ThirtyTwoBitDuration+ -> [SigSubPacket]+ baseHashedSubs kv pkp ct mExp =+ [ issuerFingerprintSub kv pkp+ , SigSubPacket True (SigCreationTime ct)+ ]+ ++ case mExp of+ Just dur -> [SigSubPacket False (SigExpirationTime dur)]+ Nothing -> []++ baseUnhashedSubs :: KeyVersion -> SomePKPayload -> [SigSubPacket]+ baseUnhashedSubs V4 pkp = [issuerKeyIdSub pkp]+ baseUnhashedSubs DeprecatedV3 pkp = [issuerKeyIdSub pkp]+ baseUnhashedSubs V6 _pkp = []++ signCertification+ :: KeyVersion+ -> SomePKPayload+ -> SKey+ -> ThirtyTwoBitTimeStamp+ -> Text+ -> [SigSubPacket]+ -> ExceptT TKGenError m SignaturePayload+ signCertification kv primaryPkp primarySKey ct uid hashedExtras = do+ let ctx =+ emptyPSC+ { lastPrimaryKey = PublicKeyPkt primaryPkp+ , lastUIDorUAt = UserIdPkt uid+ }+ payload = payloadForSig GenericCert ctx+ rawHashed =+ hashedExtras+ ++ baseHashedSubs kv primaryPkp ct (_tkGenExpiration state)+ rawUnhashed = baseUnhashedSubs kv primaryPkp+ in case (kv, primarySKey) of+ (V4, RSAPrivateKey rsaPriv) ->+ either (throwE . SignatureFailed . show) pure $+ signDataWithRSABuilder+ (mkBuilderV4 rawHashed rawUnhashed)+ (unRSA_PrivateKey rsaPriv)+ payload+ (V6, RSAPrivateKey rsaPriv) -> do+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) pure $+ signDataWithRSAV6Builder+ (mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))+ (unRSA_PrivateKey rsaPriv)+ payload+ (V4, Ed25519PrivateKey seed) ->+ signEd25519V4 rawHashed rawUnhashed seed payload+ (V6, Ed25519PrivateKey seed) ->+ signEd25519V6 rawHashed rawUnhashed seed payload+ (V4, EdDSAPrivateKey EdSigningCurve25519 seed) ->+ signEd25519V4 rawHashed rawUnhashed seed payload+ (V6, EdDSAPrivateKey EdSigningCurve25519 seed) ->+ signEd25519V6 rawHashed rawUnhashed seed payload+ (V4, EdDSAPrivateKey EdSigningCurve448 seed) ->+ signEd448V4 rawHashed rawUnhashed seed payload+ (V6, EdDSAPrivateKey EdSigningCurve448 seed) ->+ signEd448V6 rawHashed rawUnhashed seed payload+ (V4, Ed448PrivateKey seed) ->+ signEd448V4 rawHashed rawUnhashed seed payload+ (V6, Ed448PrivateKey seed) ->+ signEd448V6 rawHashed rawUnhashed seed payload+ _ ->+ throwE+ ( InvalidConfiguration+ ( "unsupported primary key type for certification: "+ ++ show primarySKey+ )+ )+ where+ mkBuilderV4 rawHashed rawUnhashed =+ addUnhashedSubs+ (listToUnhashedSubs rawUnhashed)+ ( addHashedSubs+ (listToHashedSubs rawHashed)+ (sigBuilderInit GenericCert SHA512)+ )+ mkBuilderV6 rawHashed rawUnhashed salt =+ addUnhashedSubs+ (listToUnhashedSubs rawUnhashed)+ ( addHashedSubs+ (listToHashedSubs rawHashed)+ (sigBuilderInitV6 GenericCert SHA512 salt)+ )++ signEd25519V4 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed25519.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))+ Right sk ->+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd25519Builder+ (mkBuilderV4 rawHashed rawUnhashed)+ sk+ payload+ signEd25519V6 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed25519.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))+ Right sk -> do+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd25519V6Builder+ (mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))+ sk+ payload+ signEd448V4 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed448.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))+ Right sk ->+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd448Builder+ (mkBuilderV4 rawHashed rawUnhashed)+ sk+ payload+ signEd448V6 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed448.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))+ Right sk -> do+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd448V6Builder+ (mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))+ sk+ payload++ mkUID+ :: SomePKPayload+ -> SKey+ -> KeyVersion+ -> ThirtyTwoBitTimeStamp+ -> Text+ -> ExceptT TKGenError m (Text, [SignaturePayload])+ mkUID primaryPkp primarySKey kv ct uid = do+ sig <- signCertification kv primaryPkp primarySKey ct uid []+ pure (uid, [sig])++ signDirectKey+ :: KeyVersion+ -> SomePKPayload+ -> SKey+ -> ThirtyTwoBitTimeStamp+ -> Maybe ThirtyTwoBitDuration+ -> Preferences+ -> ExceptT TKGenError m [SignaturePayload]+ signDirectKey kv primaryPkp primarySKey ct mExp prefs =+ let ctx = emptyPSC {lastPrimaryKey = PublicKeyPkt primaryPkp}+ payload = payloadForSig DirectKeySignature ctx+ rawHashed =+ [ issuerFingerprintSub kv primaryPkp+ , SigSubPacket True (SigCreationTime ct)+ , SigSubPacket True (KeyFlags (Set.fromList [CertifyKeysKey]))+ ]+ ++ maybe+ []+ (\dur -> [SigSubPacket False (SigExpirationTime dur)])+ mExp+ ++ preferenceSubs prefs+ rawUnhashed = case kv of+ V4 -> [issuerKeyIdSub primaryPkp]+ _ -> []+ in case (kv, primarySKey) of+ (V4, RSAPrivateKey rsaPriv) -> do+ sig <-+ either (throwE . SignatureFailed . show) pure $+ signDataWithRSABuilder+ (mkBuilderV4 rawHashed rawUnhashed)+ (unRSA_PrivateKey rsaPriv)+ payload+ pure [sig]+ (V6, RSAPrivateKey rsaPriv) -> do+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ sig <-+ either (throwE . SignatureFailed . show) pure $+ signDataWithRSAV6Builder+ (mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))+ (unRSA_PrivateKey rsaPriv)+ payload+ pure [sig]+ (V4, Ed25519PrivateKey seed) -> do+ sig <- signEd25519V4 rawHashed rawUnhashed seed payload+ pure [sig]+ (V6, Ed25519PrivateKey seed) -> do+ sig <- signEd25519V6 rawHashed rawUnhashed seed payload+ pure [sig]+ (V4, EdDSAPrivateKey EdSigningCurve25519 seed) -> do+ sig <- signEd25519V4 rawHashed rawUnhashed seed payload+ pure [sig]+ (V6, EdDSAPrivateKey EdSigningCurve25519 seed) -> do+ sig <- signEd25519V6 rawHashed rawUnhashed seed payload+ pure [sig]+ (V4, EdDSAPrivateKey EdSigningCurve448 seed) -> do+ sig <- signEd448V4 rawHashed rawUnhashed seed payload+ pure [sig]+ (V6, EdDSAPrivateKey EdSigningCurve448 seed) -> do+ sig <- signEd448V6 rawHashed rawUnhashed seed payload+ pure [sig]+ (V4, Ed448PrivateKey seed) -> do+ sig <- signEd448V4 rawHashed rawUnhashed seed payload+ pure [sig]+ (V6, Ed448PrivateKey seed) -> do+ sig <- signEd448V6 rawHashed rawUnhashed seed payload+ pure [sig]+ _ -> pure []+ where+ mkBuilderV4 rawHashed rawUnhashed =+ addUnhashedSubs+ (listToUnhashedSubs rawUnhashed)+ ( addHashedSubs+ (listToHashedSubs rawHashed)+ (sigBuilderInit DirectKeySignature SHA512)+ )+ mkBuilderV6 rawHashed rawUnhashed salt =+ addUnhashedSubs+ (listToUnhashedSubs rawUnhashed)+ ( addHashedSubs+ (listToHashedSubs rawHashed)+ (sigBuilderInitV6 DirectKeySignature SHA512 salt)+ )+ signEd25519V4 rawHashed rawUnhashed seed payload =+ case CE.eitherCryptoError (Ed25519.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))+ Right sk ->+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd25519Builder+ (mkBuilderV4 rawHashed rawUnhashed)+ sk+ payload+ signEd25519V6 rawHashed rawUnhashed seed payload =+ case CE.eitherCryptoError (Ed25519.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))+ Right sk -> do+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd25519V6Builder+ (mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))+ sk+ payload+ signEd448V4 rawHashed rawUnhashed seed payload =+ case CE.eitherCryptoError (Ed448.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))+ Right sk ->+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd448Builder+ (mkBuilderV4 rawHashed rawUnhashed)+ sk+ payload+ signEd448V6 rawHashed rawUnhashed seed payload =+ case CE.eitherCryptoError (Ed448.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))+ Right sk -> do+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd448V6Builder+ (mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))+ sk+ payload+ preferenceSubs :: Preferences -> [SigSubPacket]+ preferenceSubs (Preferences sym hash comp aead ksp ff) =+ ( if null sym+ then []+ else [SigSubPacket False (PreferredSymmetricAlgorithms sym)]+ )+ ++ ( if null hash+ then []+ else [SigSubPacket False (PreferredHashAlgorithms hash)]+ )+ ++ ( if null comp+ then []+ else [SigSubPacket False (PreferredCompressionAlgorithms comp)]+ )+ ++ ( if null aead+ then []+ else [SigSubPacket False (PreferredAEADCiphersuites aead)]+ )+ ++ ( if null ksp+ then []+ else [SigSubPacket False (KeyServerPreferences ksp)]+ )+ ++ ( if null ff+ then []+ else [SigSubPacket False (Features ff)]+ )++ signSubkeyBinding+ :: KeyVersion+ -> SomePKPayload+ -> SKey+ -> ThirtyTwoBitTimeStamp+ -> SubkeySpec+ -> ExceptT TKGenError m SignaturePayload+ signSubkeyBinding kv primaryPkp primarySKey ct spec = do+ let subkp = _subkeyPayload spec+ subSKey = _subkeySKey spec+ usage = _subkeyUsage spec+ ctx =+ emptyPSC+ { lastPrimaryKey = PublicKeyPkt primaryPkp+ , lastSubkey = PublicSubkeyPkt subkp+ }+ payload = payloadForSig SubkeyBindingSig ctx+ keyFlagsSub = [SigSubPacket True (KeyFlags usage)]+ isSigning = not . Set.null . Set.intersection usage . Set.fromList+ signingCapable = isSigning [SignDataKey, CertifyKeysKey, AuthKey]+ in do+ embSig <-+ if signingCapable+ then do+ let bindCtx =+ emptyPSC+ { lastPrimaryKey = PublicKeyPkt primaryPkp+ , lastSubkey = PublicSubkeyPkt subkp+ }+ bindPayload = payloadForSig PrimaryKeyBindingSig bindCtx+ bindHashed =+ [ SigSubPacket True (SigCreationTime ct)+ , SigSubPacket True (KeyFlags usage)+ , issuerFingerprintSub kv subkp+ ]+ bindUnhashed = baseUnhashedSubs kv subkp+ signPrimaryKeyBinding+ kv+ subSKey+ bindHashed+ bindUnhashed+ bindPayload+ else pure Nothing+ let embSub = case embSig of+ Just sig -> [SigSubPacket True (EmbeddedSignature sig)]+ Nothing -> []+ rawHashed =+ keyFlagsSub+ ++ embSub+ ++ baseHashedSubs kv primaryPkp ct (_tkGenExpiration state)+ rawUnhashed = baseUnhashedSubs kv primaryPkp+ in case (kv, primarySKey) of+ (V4, RSAPrivateKey rsaPriv) ->+ either (throwE . SignatureFailed . show) pure $+ signDataWithRSABuilder+ (mkBuilderV4 rawHashed rawUnhashed)+ (unRSA_PrivateKey rsaPriv)+ payload+ (V6, RSAPrivateKey rsaPriv) -> do+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) pure $+ signDataWithRSAV6Builder+ (mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))+ (unRSA_PrivateKey rsaPriv)+ payload+ (V4, Ed25519PrivateKey seed) ->+ signEd25519V4 rawHashed rawUnhashed seed payload+ (V6, Ed25519PrivateKey seed) ->+ signEd25519V6 rawHashed rawUnhashed seed payload+ (V4, EdDSAPrivateKey EdSigningCurve25519 seed) ->+ signEd25519V4 rawHashed rawUnhashed seed payload+ (V6, EdDSAPrivateKey EdSigningCurve25519 seed) ->+ signEd25519V6 rawHashed rawUnhashed seed payload+ (V4, EdDSAPrivateKey EdSigningCurve448 seed) ->+ signEd448V4 rawHashed rawUnhashed seed payload+ (V6, EdDSAPrivateKey EdSigningCurve448 seed) ->+ signEd448V6 rawHashed rawUnhashed seed payload+ (V4, Ed448PrivateKey seed) ->+ signEd448V4 rawHashed rawUnhashed seed payload+ (V6, Ed448PrivateKey seed) ->+ signEd448V6 rawHashed rawUnhashed seed payload+ _ ->+ throwE+ ( InvalidConfiguration+ ( "unsupported primary key type for subkey binding: "+ ++ show primarySKey+ )+ )+ where+ mkBuilderV4 rawHashed rawUnhashed =+ addUnhashedSubs+ (listToUnhashedSubs rawUnhashed)+ ( addHashedSubs+ (listToHashedSubs rawHashed)+ (sigBuilderInit SubkeyBindingSig SHA512)+ )+ mkBuilderV6 rawHashed rawUnhashed salt =+ addUnhashedSubs+ (listToUnhashedSubs rawUnhashed)+ ( addHashedSubs+ (listToHashedSubs rawHashed)+ (sigBuilderInitV6 SubkeyBindingSig SHA512 salt)+ )++ mkPkBuilderV4 rawHashed rawUnhashed =+ addUnhashedSubs+ (listToUnhashedSubs rawUnhashed)+ ( addHashedSubs+ (listToHashedSubs rawHashed)+ (sigBuilderInit PrimaryKeyBindingSig SHA512)+ )+ mkPkBuilderV6 rawHashed rawUnhashed salt =+ addUnhashedSubs+ (listToUnhashedSubs rawUnhashed)+ ( addHashedSubs+ (listToHashedSubs rawHashed)+ (sigBuilderInitV6 PrimaryKeyBindingSig SHA512 salt)+ )++ signPrimaryKeyBinding V4 sKey h u p =+ case sKey of+ RSAPrivateKey rsaPriv ->+ either (throwE . SignatureFailed . show) (pure . Just) $+ signDataWithRSABuilder+ (mkPkBuilderV4 h u)+ (unRSA_PrivateKey rsaPriv)+ p+ Ed25519PrivateKey seed -> do+ sk <-+ either+ (throwE . SignatureFailed . show)+ pure+ (CE.eitherCryptoError (Ed25519.secretKey seed))+ either (throwE . SignatureFailed . show) (pure . Just) $+ signDataWithEd25519Builder (mkPkBuilderV4 h u) sk p+ EdDSAPrivateKey EdSigningCurve25519 seed -> do+ sk <-+ either+ (throwE . SignatureFailed . show)+ pure+ (CE.eitherCryptoError (Ed25519.secretKey seed))+ either (throwE . SignatureFailed . show) (pure . Just) $+ signDataWithEd25519Builder (mkPkBuilderV4 h u) sk p+ EdDSAPrivateKey EdSigningCurve448 seed -> do+ sk <-+ either+ (throwE . SignatureFailed . show)+ pure+ (CE.eitherCryptoError (Ed448.secretKey seed))+ either (throwE . SignatureFailed . show) (pure . Just) $+ signDataWithEd448Builder (mkPkBuilderV4 h u) sk p+ Ed448PrivateKey seed -> do+ sk <-+ either+ (throwE . SignatureFailed . show)+ pure+ (CE.eitherCryptoError (Ed448.secretKey seed))+ either (throwE . SignatureFailed . show) (pure . Just) $+ signDataWithEd448Builder (mkPkBuilderV4 h u) sk p+ _ -> pure Nothing+ signPrimaryKeyBinding V6 sKey h u p =+ case sKey of+ RSAPrivateKey rsaPriv -> do+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) (pure . Just) $+ signDataWithRSAV6Builder+ (mkPkBuilderV6 h u (SignatureSalt salt))+ (unRSA_PrivateKey rsaPriv)+ p+ Ed25519PrivateKey seed -> do+ sk <-+ either+ (throwE . SignatureFailed . show)+ pure+ (CE.eitherCryptoError (Ed25519.secretKey seed))+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) (pure . Just) $+ signDataWithEd25519V6Builder+ (mkPkBuilderV6 h u (SignatureSalt salt))+ sk+ p+ EdDSAPrivateKey EdSigningCurve25519 seed -> do+ sk <-+ either+ (throwE . SignatureFailed . show)+ pure+ (CE.eitherCryptoError (Ed25519.secretKey seed))+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) (pure . Just) $+ signDataWithEd25519V6Builder+ (mkPkBuilderV6 h u (SignatureSalt salt))+ sk+ p+ EdDSAPrivateKey EdSigningCurve448 seed -> do+ sk <-+ either+ (throwE . SignatureFailed . show)+ pure+ (CE.eitherCryptoError (Ed448.secretKey seed))+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) (pure . Just) $+ signDataWithEd448V6Builder+ (mkPkBuilderV6 h u (SignatureSalt salt))+ sk+ p+ Ed448PrivateKey seed -> do+ sk <-+ either+ (throwE . SignatureFailed . show)+ pure+ (CE.eitherCryptoError (Ed448.secretKey seed))+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) (pure . Just) $+ signDataWithEd448V6Builder+ (mkPkBuilderV6 h u (SignatureSalt salt))+ sk+ p+ _ -> pure Nothing++ signEd25519V4 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed25519.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))+ Right sk ->+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd25519Builder+ (mkBuilderV4 rawHashed rawUnhashed)+ sk+ payload+ signEd25519V6 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed25519.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed25519 signing failed: " ++ show err))+ Right sk -> do+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd25519V6Builder+ (mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))+ sk+ payload+ signEd448V4 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed448.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))+ Right sk ->+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd448Builder+ (mkBuilderV4 rawHashed rawUnhashed)+ sk+ payload+ signEd448V6 rawHashed rawUnhashed seed payload = case CE.eitherCryptoError (Ed448.secretKey seed) of+ Left err ->+ throwE (SignatureFailed ("Ed448 signing failed: " ++ show err))+ Right sk -> do+ (salt :: B.ByteString) <- lift $ getRandomBytes 32+ either (throwE . SignatureFailed . show) pure $+ signDataWithEd448V6Builder+ (mkBuilderV6 rawHashed rawUnhashed (SignatureSalt salt))+ sk+ payload++ signBinding+ :: KeyVersion+ -> SomePKPayload+ -> SKey+ -> ThirtyTwoBitTimeStamp+ -> SubkeySpec+ -> ExceptT TKGenError m SignaturePayload+ signBinding kv primaryPkp primarySKey ct spec =+ signSubkeyBinding kv primaryPkp primarySKey ct spec++ mkSubkey+ :: SomePKPayload+ -> SKey+ -> KeyVersion+ -> ThirtyTwoBitTimeStamp+ -> SubkeySpec+ -> ExceptT TKGenError m (KeyPkt 'SecretPkt, [SignaturePayload])+ mkSubkey primaryPkp primarySKey kv ct spec = do+ let subPkt =+ KeyPktSecretSubkey+ (_subkeyPayload spec)+ (SUSUnprotected (_subkeySKey spec) 0)+ sig <- signBinding kv primaryPkp primarySKey ct spec+ pure (subPkt, [sig])++-- -----------------------------------------------------------------------------+-- Helper+-- -----------------------------------------------------------------------------
Codec/Encryption/OpenPGP/KeySelection.hs view
@@ -2,40 +2,46 @@ -- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE OverloadedStrings #-} module Codec.Encryption.OpenPGP.KeySelection- ( parseEightOctetKeyId- , parseFingerprint- ) where+ ( parseEightOctetKeyId+ , parseFingerprint+ ) where -import Codec.Encryption.OpenPGP.Types import Control.Applicative (optional, (<|>)) import Control.Monad ((<=<)) import Crypto.Number.Serialize (i2osp) import Data.Attoparsec.Text- ( Parser- , asciiCI- , count- , hexadecimal- , inClass- , parseOnly- , satisfy- )+ ( Parser+ , asciiCI+ , count+ , hexadecimal+ , inClass+ , parseOnly+ , satisfy+ )+import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Text (Text, toUpper) import qualified Data.Text as T +import Codec.Encryption.OpenPGP.Types+ parseEightOctetKeyId :: Text -> Either String EightOctetKeyId parseEightOctetKeyId =- fmap EightOctetKeyId .- (parseOnly hexes <=< parseOnly (hexPrefix *> hexen 16)) . toUpper+ fmap EightOctetKeyId+ . (parseOnly hexes <=< parseOnly (hexPrefix *> hexen 16))+ . toUpper parseFingerprint :: Text -> Either String Fingerprint parseFingerprint =- fmap Fingerprint .- (parseOnly hexes <=< parseOnly (hexen 64 <|> hexen 40 <|> hexen 32)) . toUpper . T.filter (/= ' ')+ fmap Fingerprint+ . ( parseOnly hexes+ <=< parseOnly (hexen 64 <|> hexen 40 <|> hexen 32)+ )+ . toUpper+ . T.filter (/= ' ') hexPrefix :: Parser (Maybe Text) hexPrefix = optional (asciiCI "0x")@@ -43,5 +49,5 @@ hexen :: Int -> Parser Text hexen n = T.pack <$> count n (satisfy (inClass "A-F0-9")) -hexes :: Parser BL.ByteString-hexes = BL.fromStrict . i2osp <$> hexadecimal+hexes :: Parser B.ByteString+hexes = i2osp <$> hexadecimal
Codec/Encryption/OpenPGP/Message.hs view
@@ -12,8 +12,7 @@ {-# LANGUAGE TypeFamilies #-} module Codec.Encryption.OpenPGP.Message- ( Passphrase- , EncryptedPayload+ ( EncryptedPayload , mkEncryptedPayload , encryptedPayloadBytes , ClearPayload@@ -36,8 +35,7 @@ , MessageParseFailure (..) , renderMessageParseFailure , MDCFailure (..)- , AEADFailure (..)- , renderAEADFailure+ , renderMDCFailure , PayloadDecryptFailure (..) , renderPayloadDecryptFailure , MessageDecryptFailure (..)@@ -54,9 +52,6 @@ , decryptMessage , signMessage , signMessageWith- , ConduitMessage.VerificationPolicy (..)- , ConduitMessage.VerificationOptions (..)- , ConduitMessage.defaultVerificationOptions , verifySignedMessage ) where @@ -493,7 +488,7 @@ iv ) s2k- (unPassphrase passphrase)+ passphrase ( Block [ LiteralDataPkt BinaryData@@ -754,7 +749,7 @@ randomSHA512SignatureSalt :: MonadRandom m => m SignatureSalt randomSHA512SignatureSalt =- SignatureSalt . BL.fromStrict <$> getRandomBytes 32+ SignatureSalt <$> getRandomBytes 32 signV4WithIssuers :: PKPayload 'V4@@ -849,9 +844,9 @@ :: SymmetricAlgorithm -> AEADAlgorithm -> S2K- -> BL.ByteString- -> BL.ByteString- -> BL.ByteString+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString -> Word8 -> Salt -> B.ByteString@@ -974,9 +969,9 @@ :: SymmetricAlgorithm -> AEADAlgorithm -> S2K- -> BL.ByteString- -> BL.ByteString- -> BL.ByteString+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString -> SEIPDv2SKESKInfo 'V6 data ParsedEncryptedPayload (k :: ParsedEncryptedPayloadKind) where@@ -1087,9 +1082,9 @@ sa aead kek- (BL.toStrict iv)- (BL.toStrict esk)- (BL.toStrict tag)+ iv+ esk+ tag deriveSessionKeyBytes :: Passphrase
Codec/Encryption/OpenPGP/S2K.hs view
@@ -24,7 +24,6 @@ import Data.Bits (shiftL) import qualified Data.ByteArray as BA import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL import Data.Word (Word16, Word8) import Codec.Encryption.OpenPGP.BlockCipher@@ -103,33 +102,40 @@ ++ renderEncodedSessionKeyError err string2Key- :: S2K -> Int -> BL.ByteString -> Either S2KError B.ByteString+ :: S2K -> Int -> B.ByteString -> Either S2KError B.ByteString string2Key (Simple ha) ksz bs = B.take (fromIntegral ksz) <$> hashpp ha ksz bs string2Key (Salted ha salt) ksz bs = string2Key (Simple ha) ksz- (BL.append (BL.fromStrict (unSalt8 salt)) bs)+ (B.append (unSalt8 salt) bs) string2Key (IteratedSalted ha salt cnt) ksz bs = string2Key (Simple ha) ksz- ( BL.take (fromIntegral cnt) . BL.cycle $- BL.append (BL.fromStrict (unSalt8 salt)) bs- )+ (cycleTake (fromIntegral cnt) $ B.append (unSalt8 salt) bs) string2Key (Argon2 salt t p encodedM) ksz pass = argon2String2Key salt t p encodedM ksz pass string2Key (OtherS2K t _) _ _ = Left (S2KUnsupportedSpecifier t) +cycleTake :: Int -> B.ByteString -> B.ByteString+cycleTake n bs+ | B.null bs = B.empty+ | n <= B.length bs = B.take n bs+ | otherwise =+ B.take n $+ B.concat $+ replicate ((n + B.length bs - 1) `div` B.length bs) bs+ skesk2Key- :: SKESK 'SKESKV4 -> BL.ByteString -> Either S2KError B.ByteString+ :: SKESK 'SKESKV4 -> B.ByteString -> Either S2KError B.ByteString skesk2Key skesk pass = snd <$> skesk2SessionKey skesk pass skesk2SessionKey :: SKESK 'SKESKV4- -> BL.ByteString+ -> B.ByteString -> Either S2KError (SymmetricAlgorithm, B.ByteString) skesk2SessionKey (SKESK4Packet sa s2k Nothing) pass = do keyLen <- first S2KUnsupportedAlgorithm (keySize sa)@@ -147,7 +153,7 @@ paddedCfbDecrypt cipher (B.replicate (blockSize cipher) 0)- (BL.toStrict esk)+ esk ) first S2KEncryptedSessionKeyDecodeError@@ -224,7 +230,7 @@ -> Word8 -> Word8 -> Int- -> BL.ByteString+ -> B.ByteString -> Either S2KError B.ByteString argon2String2Key salt t p encodedM keyLen pass | t == 0 =@@ -241,7 +247,7 @@ "Argon2 S2K encoded_m is too small for parallelism" ) | otherwise =- case Argon2.hash opts (BL.toStrict pass) (unSalt16 salt) keyLen of+ case Argon2.hash opts pass (unSalt16 salt) keyLen of CryptoPassed k -> Right k CryptoFailed e -> Left (S2KArgon2Failed (show e)) where@@ -268,7 +274,7 @@ hashpp :: HashAlgorithm -> Int- -> BL.ByteString+ -> B.ByteString -> Either S2KError B.ByteString hashpp ha keysize pp = B.concat <$> unfoldrM step (0, B.empty)@@ -276,17 +282,18 @@ step (ctr, acc) | B.length acc >= keysize = return Nothing | otherwise = do- digest <- hf ha (nulpad ctr `BL.append` pp)+ digest <- hf ha (nulpad ctr `B.append` pp) return (Just (digest, (ctr + 1, acc `B.append` digest)))- nulpad = BL.pack . flip replicate 0+ nulpad = B.pack . flip replicate 0 hf- :: HashAlgorithm -> BL.ByteString -> Either S2KError B.ByteString- hf DeprecatedMD5 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.MD5))- hf SHA1 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA1))- hf SHA224 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA224))- hf SHA256 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA256))- hf SHA384 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA384))- hf SHA512 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA512))- hf SHA3_256 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA3_256))- hf SHA3_512 bs = Right (BA.convert (CH.hashlazy bs :: CH.Digest CH.SHA3_512))+ :: HashAlgorithm -> B.ByteString -> Either S2KError B.ByteString+ hf DeprecatedMD5 bs = Right (BA.convert (CH.hash bs :: CH.Digest CH.MD5))+ hf SHA1 bs = Right (BA.convert (CH.hash bs :: CH.Digest CH.SHA1))+ hf SHA224 bs = Right (BA.convert (CH.hash bs :: CH.Digest CH.SHA224))+ hf SHA256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CH.SHA256))+ hf SHA384 bs = Right (BA.convert (CH.hash bs :: CH.Digest CH.SHA384))+ hf SHA512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CH.SHA512))+ hf SHA3_256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CH.SHA3_256))+ hf SHA3_512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CH.SHA3_512))+ hf RIPEMD160 bs = Right (BA.convert (CH.hash bs :: CH.Digest CH.RIPEMD160)) hf (OtherHA ha') _ = Left (S2KUnsupportedHashAlgorithm (OtherHA ha'))
Codec/Encryption/OpenPGP/SecretKey.hs view
@@ -125,13 +125,15 @@ , skeoIV :: Maybe IV } +{-# DEPRECATED decryptPrivateKey "Use decryptSecretKeyAddendum" #-} decryptPrivateKey :: (SomePKPayload, SKAddendum)- -> BL.ByteString+ -> Passphrase -> Either String SKAddendum-decryptPrivateKey (pkp, ska) pp =+decryptPrivateKey (pkp, ska) (Passphrase pp) = fromSKAddendumForPKPayload pkp ska >>= \case- SomeSKAddendumV skaV -> toSKAddendum <$> decryptPrivateKeyTyped pkp skaV pp+ SomeSKAddendumV skaV ->+ toSKAddendum <$> decryptPrivateKeyTyped pkp skaV (Passphrase pp) decryptSecretKey :: SecretKey@@ -151,11 +153,11 @@ -> Passphrase -> Either SecretKeyError (SKey, SKAddendum) decryptSecretKeyAddendum pkp ska pp =- case decryptPrivateKey (pkp, ska) (unPassphrase pp) of+ case decryptPrivateKey (pkp, ska) pp of Left err -> Left $ SecretKeyDecryptError err Right decrypted -> case decrypted of- SUUnencrypted skey _ -> Right (skey, decrypted)+ SUSUnprotected skey _ -> Right (skey, decrypted) _ -> Left $ SecretKeyDecryptError@@ -193,7 +195,7 @@ salt iv ska- (unPassphrase newPassphrase)+ newPassphrase ) return result @@ -230,9 +232,9 @@ decrypted <- except $ first SecretKeyDecryptError $- decryptPrivateKey (pkp, originalSka) (unPassphrase oldPassphrase)+ decryptPrivateKey (pkp, originalSka) oldPassphrase case decrypted of- SUUnencrypted skey _ -> do+ SUSUnprotected skey _ -> do let pp = unPassphrase newPassphrase (salt, iv) <- if skeoGenerateSaltAndIV opts@@ -254,7 +256,7 @@ salt iv skey- pp+ (Passphrase pp) (skeoPolicy opts) return $ sk {_secretKeySKAddendum = newSka} _ ->@@ -269,10 +271,10 @@ -> Salt -> IV -> SKey- -> BL.ByteString+ -> Passphrase -> OpenPGPPolicy -> Either SecretKeyError SKAddendum-reencryptWithPolicyAndSaltAndIV pkp originalSka salt iv skey pp policy =+reencryptWithPolicyAndSaltAndIV pkp originalSka salt iv skey (Passphrase pp) policy = first SecretKeyEncryptError (fromSKAddendumForPKPayload pkp originalSka)@@ -287,7 +289,7 @@ salt iv skey- pp+ (Passphrase pp) reencryptSecretKeyRandom :: MonadRandom m@@ -311,9 +313,9 @@ decryptPrivateKeyTyped :: SomePKPayload -> SKAddendumV v- -> BL.ByteString+ -> Passphrase -> Either String (SKAddendumV v)-decryptPrivateKeyTyped pkp (SKA16bit sa s2k iv payload) pp = do+decryptPrivateKeyTyped pkp (SKAMalleableCFB sa s2k iv payload) pp = do (sk, cksum) <- decryptS2KProtectedPayload pkp@@ -323,8 +325,8 @@ payload pp parse16BitProtectedSecretKey- pure (SKAUnencryptedLegacy sk cksum)-decryptPrivateKeyTyped pkp (SKASHA1Legacy sa s2k iv payload) pp = do+ pure (SKAUnprotectedLegacy sk cksum)+decryptPrivateKeyTyped pkp (SKACFBLegacy sa s2k iv payload) pp = do (sk, cksum) <- decryptS2KProtectedPayload pkp@@ -334,8 +336,8 @@ payload pp parseSHA1ProtectedSecretKey- pure (SKAUnencryptedLegacy sk cksum)-decryptPrivateKeyTyped pkp (SKASHA1V6 sa s2k iv payload) pp = do+ pure (SKAUnprotectedLegacy sk cksum)+decryptPrivateKeyTyped pkp (SKACFBV6 sa s2k iv payload) pp = do (sk, _) <- decryptS2KProtectedPayload pkp@@ -345,39 +347,41 @@ payload pp parseSHA1ProtectedSecretKey- pure (SKAUnencryptedV6 sk)+ pure (SKAUnprotectedV6 sk) decryptPrivateKeyTyped pkp (SKAAEADV6 sa aa s2k iv payload) pp = do- sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp- pure (SKAUnencryptedV6 sk)+ sk <-+ decryptAEADPayloadCore pkp sa aa s2k iv (BL.toStrict payload) pp+ pure (SKAUnprotectedV6 sk) decryptPrivateKeyTyped pkp (SKAAEADLegacy sa aa s2k iv payload) pp = do- sk <- decryptAEADPayloadCore pkp sa aa s2k iv payload pp- pure (SKAUnencryptedLegacy sk 0)-decryptPrivateKeyTyped pkp (SKASymLegacy sa iv payload) pp = do+ sk <-+ decryptAEADPayloadCore pkp sa aa s2k iv (BL.toStrict payload) pp+ pure (SKAUnprotectedLegacy sk 0)+decryptPrivateKeyTyped pkp (SKALegacyCFBLegacy sa iv payload) pp = do keyLen <- first renderCipherError (keySize sa) dek <- first renderS2KError- (string2Key (Simple DeprecatedMD5) keyLen pp)+ (string2Key (Simple DeprecatedMD5) keyLen (unPassphrase pp)) p <- first renderCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek) (sk, cksum) <- parse16BitProtectedSecretKey pkp p- pure (SKAUnencryptedLegacy sk cksum)-decryptPrivateKeyTyped pkp (SKASymV6 sa iv payload) pp = do+ pure (SKAUnprotectedLegacy sk cksum)+decryptPrivateKeyTyped pkp (SKALegacyCFBV6 sa iv payload) pp = do keyLen <- first renderCipherError (keySize sa) dek <- first renderS2KError- (string2Key (Simple DeprecatedMD5) keyLen pp)+ (string2Key (Simple DeprecatedMD5) keyLen (unPassphrase pp)) p <- first renderCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek) (sk, _) <- parse16BitProtectedSecretKey pkp p- pure (SKAUnencryptedV6 sk)-decryptPrivateKeyTyped _ ska@(SKAUnencryptedLegacy {}) _ = Right ska-decryptPrivateKeyTyped _ ska@(SKAUnencryptedV6 {}) _ = Right ska+ pure (SKAUnprotectedV6 sk)+decryptPrivateKeyTyped _ ska@(SKAUnprotectedLegacy {}) _ = Right ska+decryptPrivateKeyTyped _ ska@(SKAUnprotectedV6 {}) _ = Right ska mkUnencryptedSKAddendum :: SomePKPayload -> SKey -> Either String SKAddendum@@ -387,7 +391,7 @@ case _keyVersion pkp of V6 -> 0 _ -> checksum16 (BL.toStrict payload)- pure (SUUnencrypted skey checksum)+ pure (SUSUnprotected skey checksum) decryptS2KProtectedPayload :: SomePKPayload@@ -395,10 +399,10 @@ -> S2K -> IV -> BL.ByteString- -> BL.ByteString+ -> Passphrase -> (SomePKPayload -> B.ByteString -> Either String (SKey, Word16)) -> Either String (SKey, Word16)-decryptS2KProtectedPayload pkp sa s2k iv payload pp parser = do+decryptS2KProtectedPayload pkp sa s2k iv payload (Passphrase pp) parser = do dek <- first renderS2KError (skesk2Key (SKESK4Packet sa s2k Nothing) pp) decrypted <-@@ -460,10 +464,10 @@ -> AEADAlgorithm -> S2K -> IV- -> BL.ByteString- -> BL.ByteString+ -> B.ByteString+ -> Passphrase -> Either String SKey-decryptAEADPayloadCore pkp sa aa s2k iv payload pp = do+decryptAEADPayloadCore pkp sa aa s2k iv payload (Passphrase pp) = do keyLen <- first renderCipherError (keySize sa) keyMaterial <- first renderS2KError (string2Key s2k keyLen pp) let keyCandidates = [keyMaterial]@@ -480,7 +484,7 @@ [B.cons tagByte pkpBytes | tagByte <- tagCandidates] aaCandidates = [aa] nonce = unIV iv- payloadStrict = BL.toStrict payload+ payloadStrict = payload tagLen = 16 tryDecrypt candidateKeyMaterial info ad aaTry = do when (B.length payloadStrict < tagLen) $@@ -617,24 +621,28 @@ keyVersionByte V4 = 4 keyVersionByte V6 = 6 +{-# DEPRECATED+ encryptPrivateKeyWithPolicyAndSaltAndIV+ "Use encryptSecretKeyWithPolicy"+ #-} encryptPrivateKeyWithPolicyAndSaltAndIV :: OpenPGPPolicy -> SomePKPayload -> Salt -> IV -> SKAddendum- -> BL.ByteString+ -> Passphrase -> Either String SKAddendum-encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska pp =+encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska (Passphrase pp) = case ska of- SUUnencrypted skey _ ->+ SUSUnprotected skey _ -> encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey- pp+ (Passphrase pp) _ -> Right ska encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV@@ -643,12 +651,39 @@ -> Salt -> IV -> SKey- -> BL.ByteString+ -> Passphrase -> Either String SKAddendum-encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey pp = do- (sa, aa, s2k) <- secretKeyProtectionDefaults policy pkp salt iv- (\payload -> SUSAEAD sa aa s2k iv (BL.fromStrict payload))- <$> encryptV6SKey pkp skey sa aa s2k iv pp+encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey (Passphrase pp) = do+ (sa, _aa, s2k) <- secretKeyProtectionDefaults policy pkp salt iv+ let retargetedS2K = retargetS2K salt s2k+ case _keyVersion pkp of+ V6 ->+ (\payload -> SUSAEAD sa _aa s2k iv (BL.fromStrict payload))+ <$> encryptV6SKey pkp skey sa _aa s2k iv (Passphrase pp)+ V4 ->+ if policyRFC policy == RFC9580+ then+ (\payload -> SUSAEAD sa _aa s2k iv (BL.fromStrict payload))+ <$> encryptV6SKey pkp skey sa _aa s2k iv (Passphrase pp)+ else do+ keyLen <- first renderCipherError (keySize sa)+ keyMaterial <-+ first renderS2KError (string2Key retargetedS2K keyLen pp)+ cleartext <- legacySecretKeyPayload pkp skey+ let clearWithSHA1 =+ BL.toStrict cleartext+ <> BA.convert+ ( CH.hash+ (BL.toStrict cleartext)+ :: CH.Digest CH.SHA1+ )+ encrypted <-+ first+ renderCipherError+ (encryptNoNonce sa retargetedS2K iv clearWithSHA1 keyMaterial)+ pure (SUSCFB sa retargetedS2K iv (BL.fromStrict encrypted))+ DeprecatedV3 ->+ Left "v3 secret key encryption is not supported" encodeSKeyMaterial :: SKey -> Either String BL.ByteString encodeSKeyMaterial keyMaterial =@@ -689,9 +724,9 @@ -> AEADAlgorithm -> S2K -> IV- -> BL.ByteString+ -> Passphrase -> Either String B.ByteString-encryptV6SKey pkp skey sa aa s2k iv pp = do+encryptV6SKey pkp skey sa aa s2k iv (Passphrase pp) = do keyLen <- first renderCipherError (keySize sa) keyMaterial <- first renderS2KError (string2Key s2k keyLen pp) payload <- encodeSKeyMaterial skey@@ -713,9 +748,11 @@ :: OpenPGPPolicy -> SomePKPayload -> Either String (Int, Int) secretKeyProtectionMaterialLengths policy pkp = case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of- Just policy ->- Right- (secretKeyS2KSaltOctets policy, secretKeyAEADNonceOctets policy)+ Just skPolicy ->+ let saltLen = case _keyVersion pkp of+ V4 -> 8+ _ -> secretKeyS2KSaltOctets skPolicy+ in Right (saltLen, secretKeyAEADNonceOctets skPolicy) Nothing -> Left legacySecretKeyProtectionErrorMessage generateSecretKeyProtectionMaterial@@ -739,28 +776,45 @@ -> Either String (SymmetricAlgorithm, AEADAlgorithm, S2K) secretKeyProtectionDefaults policy pkp salt iv = case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of- Just policy -> do- when (B.length (unSalt salt) /= secretKeyS2KSaltOctets policy) $+ Just skPolicy -> do+ let expectedSaltLen = case _keyVersion pkp of+ V4 -> 8+ _ -> secretKeyS2KSaltOctets skPolicy+ when (B.length (unSalt salt) /= expectedSaltLen) $ Left- ( "v6 secret key S2K salt must be "- ++ show (secretKeyS2KSaltOctets policy)+ ( "secret key S2K salt must be "+ ++ show expectedSaltLen ++ " octets" )- when (B.length (unIV iv) /= secretKeyAEADNonceOctets policy) $- Left+ when+ ( _keyVersion pkp == V6+ && B.length (unIV iv) /= secretKeyAEADNonceOctets skPolicy+ )+ $ Left ( "v6 secret key AEAD nonce must be "- ++ show (secretKeyAEADNonceOctets policy)+ ++ show (secretKeyAEADNonceOctets skPolicy) ++ " octets" )- pure- ( secretKeyDefaultSymmetricAlgorithm policy- , secretKeyDefaultAEADAlgorithm policy- , secretKeyDefaultS2KForSalt policy salt- )+ let defaultS2K = secretKeyDefaultS2KForSalt skPolicy salt+ s2k = case _keyVersion pkp of+ V4 ->+ case defaultS2K of+ Argon2 {} ->+ IteratedSalted+ SHA512+ (Salt8 (B.take 8 (unSalt salt)))+ 1024+ _ -> defaultS2K+ _ -> defaultS2K+ let sa = secretKeyDefaultSymmetricAlgorithm skPolicy+ aa = secretKeyDefaultAEADAlgorithm skPolicy+ pure (sa, aa, s2k) Nothing -> Left legacySecretKeyProtectionErrorMessage secretKeyProtectionPolicyForEncryption :: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy+secretKeyProtectionPolicyForEncryption policy V4 =+ policySecretKeyProtection policy secretKeyProtectionPolicyForEncryption policy V6 = secretKeyProtectionPolicyForKeyVersion policy V6 secretKeyProtectionPolicyForEncryption policy _@@ -797,16 +851,18 @@ >>= \aead -> pure (CCT.aeadSimpleEncrypt aead ad plaintext 16) +{-# DEPRECATED reencryptPrivateKeyTyped "Use reencryptSecretKey" #-} reencryptPrivateKeyTyped :: SomePKPayload -> SKAddendumV v -> Salt -> IV -> SKey- -> BL.ByteString+ -> Passphrase -> Either String (SKAddendumV v) reencryptPrivateKeyTyped = reencryptPrivateKeyTypedWithPolicy defaultPolicy +{-# DEPRECATED reencryptPrivateKeyTypedWithPolicy "Use reencryptSecretKey" #-} reencryptPrivateKeyTypedWithPolicy :: OpenPGPPolicy -> SomePKPayload@@ -814,15 +870,15 @@ -> Salt -> IV -> SKey- -> BL.ByteString+ -> Passphrase -> Either String (SKAddendumV v) reencryptPrivateKeyTypedWithPolicy policy pkp skaV salt iv skey pp = case skaV of SKAAEADV6 {} -> reencryptV6 policy- SKASHA1V6 {} -> reencryptV6 policy- SKASymV6 {} -> reencryptV6 policy- SKAUnencryptedV6 {} -> reencryptV6 policy- SKA16bit sa s2k _ _ ->+ SKACFBV6 {} -> reencryptV6 policy+ SKALegacyCFBV6 {} -> reencryptV6 policy+ SKAUnprotectedV6 {} -> reencryptV6 policy+ SKAMalleableCFB sa s2k _ _ -> reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km -> encryptProtectedSecretKey sa'@@ -831,8 +887,8 @@ ct km checksum16Trailer- (SKA16bit sa' s2k' iv')- SKASHA1Legacy sa s2k _ _ ->+ (SKAMalleableCFB sa' s2k' iv')+ SKACFBLegacy sa s2k _ _ -> reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km -> encryptProtectedSecretKey sa'@@ -841,7 +897,7 @@ ct km sha1Trailer- (SKASHA1Legacy sa' s2k' iv')+ (SKACFBLegacy sa' s2k' iv') SKAAEADLegacy sa _aa s2k _ _ -> reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k $ \sa' s2k' iv' ct km -> encryptProtectedSecretKey@@ -851,20 +907,20 @@ ct km sha1Trailer- (SKASHA1Legacy sa' s2k' iv')- SKASymLegacy sa _ _ -> do+ (SKACFBLegacy sa' s2k' iv')+ SKALegacyCFBLegacy sa _ _ -> do keyLen <- first renderCipherError (keySize sa) keyMaterial <- first renderS2KError- (string2Key (Simple DeprecatedMD5) keyLen pp)+ (string2Key (Simple DeprecatedMD5) keyLen (unPassphrase pp)) cleartext <- legacySecretKeyPayload pkp skey let clearWithChecksum = BL.toStrict ( cleartext <> runPut (putWord16be (checksum16 (BL.toStrict cleartext))) )- (\encrypted -> SKASymLegacy sa iv (BL.fromStrict encrypted))+ (\encrypted -> SKALegacyCFBLegacy sa iv (BL.fromStrict encrypted)) <$> first renderCipherError ( encryptNoNonce@@ -874,32 +930,33 @@ clearWithChecksum keyMaterial )- SKAUnencryptedLegacy _ _ -> Left legacySecretKeyProtectionErrorMessage+ SKAUnprotectedLegacy _ _ -> Left legacySecretKeyProtectionErrorMessage where reencryptV6 pol = do (sa, aa, s2k) <- secretKeyProtectionDefaults pol pkp salt iv (\payload -> SKAAEADV6 sa aa s2k iv (BL.fromStrict payload)) <$> encryptV6SKey pkp skey sa aa s2k iv pp +{-# DEPRECATED reencryptPrivateKeyWithSaltAndIV "Use reencryptSecretKey" #-} reencryptPrivateKeyWithSaltAndIV :: SomePKPayload -> SKAddendum -> Salt -> IV -> SKey- -> BL.ByteString+ -> Passphrase -> Either String SKAddendum-reencryptPrivateKeyWithSaltAndIV pkp originalSka salt iv skey pp =+reencryptPrivateKeyWithSaltAndIV pkp originalSka salt iv skey (Passphrase pp) = fromSKAddendumForPKPayload pkp originalSka >>= \(SomeSKAddendumV skaV) -> toSKAddendum- <$> reencryptPrivateKeyTyped pkp skaV salt iv skey pp+ <$> reencryptPrivateKeyTyped pkp skaV salt iv skey (Passphrase pp) reencryptS2KProtectedSecretKey :: SomePKPayload -> Salt -> IV -> SKey- -> BL.ByteString+ -> Passphrase -> SymmetricAlgorithm -> S2K -> ( SymmetricAlgorithm@@ -910,7 +967,7 @@ -> Either String r ) -> Either String r-reencryptS2KProtectedSecretKey pkp salt iv skey pp sa s2k encryptFn = do+reencryptS2KProtectedSecretKey pkp salt iv skey (Passphrase pp) sa s2k encryptFn = do keyLen <- first renderCipherError (keySize sa) let retargetedS2K = retargetS2K salt s2k keyMaterial <-
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -371,7 +371,7 @@ rclass <- getWord8 guard (testBit rclass 7) algid <- get- fp <- getLazyByteString (fromIntegral l - 3)+ fp <- getByteString (fromIntegral l - 3) return $ SigSubPacket crit@@ -383,7 +383,7 @@ getIssuer :: SigSubPacketParser getIssuer _pt crit l = do- keyid <- getLazyByteString (l - 1)+ keyid <- getByteString (fromIntegral l - 1) return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid)) getNotationData :: SigSubPacketParser@@ -502,8 +502,8 @@ Just ifVersion -> do fp <- case kv of- 4 -> getLazyByteString (fromIntegral fpLen)- 6 -> getLazyByteString (fromIntegral fpLen)+ 4 -> getByteString (fromIntegral fpLen)+ 6 -> getByteString (fromIntegral fpLen) _ -> fail ("invalid issuer fingerprint version marker: " ++ show kv) return $@@ -512,11 +512,11 @@ getIntendedRecipient :: SigSubPacketParser getIntendedRecipient _pt crit l = do kv <- getWord8- fp <- getLazyByteString (l - 2)- when (BL.length fp /= 20 && BL.length fp /= 32) $+ fp <- getByteString (fromIntegral l - 2)+ when (B.length fp /= 20 && B.length fp /= 32) $ fail ( "invalid intended recipient fingerprint length: "- ++ show (BL.length fp)+ ++ show (B.length fp) ) case BTypes.packetVersionToIssuerFingerprintVersion kv of Nothing ->@@ -633,19 +633,19 @@ -> Fingerprint -> Put putRevocationKey crit rclass algid fp = do- let fpLen = BL.length (unFingerprint fp)+ let fpLen = B.length (unFingerprint fp) putSubPacketLength (fromIntegral (3 + fpLen)) putSigSubPacketType crit 12 putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $ Set.insert (RClOther 0) rclass put algid- putLazyByteString (unFingerprint fp)+ putByteString (unFingerprint fp) putIssuer :: Bool -> EightOctetKeyId -> Put putIssuer crit keyid = do putSubPacketLength 9 putSigSubPacketType crit 16- putLazyByteString (unEOKI keyid)+ putByteString (unEOKI keyid) putNotationData :: Bool@@ -753,28 +753,28 @@ putIssuerFingerprint crit kv fp = do let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv let fpb = unFingerprint fp- when (BL.length fpb /= 20 && BL.length fpb /= 32) $+ when (B.length fpb /= 20 && B.length fpb /= 32) $ error- ("invalid issuer fingerprint length: " ++ show (BL.length fpb))- putSubPacketLength . fromIntegral $ (2 + BL.length fpb)+ ("invalid issuer fingerprint length: " ++ show (B.length fpb))+ putSubPacketLength . fromIntegral $ (2 + B.length fpb) putSigSubPacketType crit 33 putWord8 kv'- putLazyByteString fpb+ putByteString fpb putIntendedRecipient :: Bool -> IssuerFingerprintVersion -> Fingerprint -> Put putIntendedRecipient crit kv irf = do let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv let fpb = unFingerprint irf- when (BL.length fpb /= 20 && BL.length fpb /= 32) $+ when (B.length fpb /= 20 && B.length fpb /= 32) $ error ( "invalid intended-recipient fingerprint length: "- ++ show (BL.length fpb)+ ++ show (B.length fpb) )- putSubPacketLength . fromIntegral $ (2 + BL.length fpb)+ putSubPacketLength . fromIntegral $ (2 + B.length fpb) putSigSubPacketType crit 35 putWord8 kv'- putLazyByteString fpb+ putByteString fpb putPreferredAEADCiphersuites :: Bool -> [(SymmetricAlgorithm, AEADAlgorithm)] -> Put@@ -1026,7 +1026,7 @@ bimap (\(_, _, e) -> e) id $ runGetOrFail ( do- eokeyid <- getLazyByteString 8+ eokeyid <- getByteString 8 pka <- getWord8 mpib <- getRemainingLazyByteString pure (eokeyid, pka, mpib)@@ -1159,7 +1159,7 @@ | otherwise = Nothing validateV4SKESKEncryptedSessionKeyS2K- :: S2K -> Maybe BL.ByteString -> Get ()+ :: S2K -> Maybe B.ByteString -> Get () validateV4SKESKEncryptedSessionKeyS2K _ Nothing = pure () validateV4SKESKEncryptedSessionKeyS2K Simple {} (Just _) = fail@@ -1184,7 +1184,11 @@ pure $ PKESKPkt ( PKESKPayloadV6Packet- (PKESKPayloadV6 recipientKeyIdentifier (toFVal pka) esk)+ ( PKESKPayloadV6+ (BL.toStrict recipientKeyIdentifier)+ (toFVal pka)+ (BL.toStrict esk)+ ) ) where validateV6PKESKRecipientIdentifier@@ -1242,7 +1246,7 @@ 7 -> getSecretSubkey len 8 -> getCompressedData len 9 -> SymEncDataPkt <$> getLazyByteString len- 10 -> MarkerPkt <$> getLazyByteString len+ 10 -> MarkerPkt <$> getByteString (fromIntegral len) 11 -> getLiteralData len 12 -> TrustPkt <$> getLazyByteString len 13 ->@@ -1251,7 +1255,7 @@ 14 -> getPublicSubkey len 17 -> getPublicAttribute len 18 -> getSEIPD len- 19 -> ModificationDetectionCodePkt <$> getLazyByteString 20+ 19 -> ModificationDetectionCodePkt <$> getByteString 20 21 -> PaddingPkt <$> getLazyByteString len _ -> OtherPacketPkt t <$> getLazyByteString len @@ -1293,7 +1297,7 @@ let symalgo = toFVal symalgoWord aead = toFVal aeadWord ivLen = fromIntegral (aeadNonceSize aead)- iv <- getLazyByteString ivLen+ iv <- getByteString ivLen pure (symalgo, aead, s2k, iv) paramsLen <- getWord8 params <- getLazyByteString (fromIntegral paramsLen)@@ -1317,15 +1321,15 @@ aead s2k iv- esk- tag+ (BL.toStrict esk)+ (BL.toStrict tag) ) ) getSKESKV4 = do symalgo <- getWord8 s2k <- getS2K esk <- getRemainingLazyByteString- let mesk = if BL.null esk then Nothing else Just esk+ let mesk = fmap BL.toStrict $ if BL.null esk then Nothing else Just esk validateV4SKESKEncryptedSessionKeyS2K s2k mesk return $ SKESKPkt@@ -1355,7 +1359,7 @@ -> PubKeyAlgorithm -> Get Pkt getOPSV3 pv sigtype ha pka = do- skeyid <- getLazyByteString 8+ skeyid <- getByteString 8 nested <- getWord8 >>= parseOPSNestedFlag return $ OnePassSignaturePkt@@ -1396,8 +1400,8 @@ ++ show saltSize ) salt <-- SignatureSalt <$> getLazyByteString (fromIntegral saltSize)- signerFingerprint <- getLazyByteString 32+ SignatureSalt <$> getByteString (fromIntegral saltSize)+ signerFingerprint <- getByteString 32 nested <- getWord8 >>= parseOPSNestedFlag return $ OnePassSignaturePkt@@ -1407,7 +1411,7 @@ ha pka salt- signerFingerprint+ (Fingerprint signerFingerprint) nested ) )@@ -1598,23 +1602,23 @@ let bsk = runPut $ putPKESKv3SessionKeyMaterial pka mpis putPacketLength . fromIntegral $ 10 + BL.length bsk putWord8 3- putLazyByteString (unEOKI eokeyid)+ putByteString (unEOKI eokeyid) putWord8 $ fromIntegral . fromFVal $ pka putLazyByteString bsk putPKESKV6 :: PKESKPayloadV6 -> Put putPKESKV6 (PKESKPayloadV6 recipientKeyIdentifier pka esk) = do putWord8 (0xc0 .|. 1)- let keyIdentifierLen = BL.length recipientKeyIdentifier+ let keyIdentifierLen = B.length recipientKeyIdentifier when (keyIdentifierLen > 255) $ error "PKESK v6 recipient key identifier must fit in one octet" putPacketLength . fromIntegral $- 3 + keyIdentifierLen + BL.length esk+ 3 + keyIdentifierLen + B.length esk putWord8 6 putWord8 (fromIntegral keyIdentifierLen)- putLazyByteString recipientKeyIdentifier+ putByteString recipientKeyIdentifier putWord8 $ fromIntegral . fromFVal $ pka- putLazyByteString esk+ putByteString esk putSignature :: SignaturePayload -> Put putSignature sp = do@@ -1625,34 +1629,34 @@ putSKESKV4 :: SKESKPayloadV4 -> Put putSKESKV4 (SKESKPayloadV4 symalgo s2k mesk) = do putWord8 (0xc0 .|. 3)- let bs2k = fromS2K s2k- let bsk = fromMaybe BL.empty mesk+ let bs2k = BL.toStrict (fromS2K s2k)+ let bsk = fromMaybe B.empty mesk putPacketLength . fromIntegral $- 2 + BL.length bs2k + BL.length bsk+ 2 + B.length bs2k + B.length bsk putWord8 4 putWord8 $ fromIntegral . fromFVal $ symalgo- putLazyByteString bs2k- putLazyByteString bsk+ putByteString bs2k+ putByteString bsk putSKESKV6 :: SKESKPayloadV6 -> Put putSKESKV6 (SKESKPayloadV6 symalgo aead s2k iv esk tag) = do putWord8 (0xc0 .|. 3)- let bs2k = fromS2K s2k+ let bs2k = BL.toStrict (fromS2K s2k) let params =- BL.pack+ B.pack [ fromIntegral (fromFVal symalgo) , fromIntegral (fromFVal aead)- , fromIntegral (BL.length bs2k)+ , fromIntegral (B.length bs2k) ] <> bs2k <> iv putPacketLength . fromIntegral $- 2 + BL.length params + BL.length esk + BL.length tag+ 2 + B.length params + B.length esk + B.length tag putWord8 6- putWord8 (fromIntegral (BL.length params))- putLazyByteString params- putLazyByteString esk- putLazyByteString tag+ putWord8 (fromIntegral (B.length params))+ putByteString params+ putByteString esk+ putByteString tag putOPSV3 :: OPSPayloadV3 -> Put putOPSV3 (OPSPayloadV3 pv sigtype ha pka skeyid nested) = do@@ -1663,7 +1667,7 @@ putWord8 $ fromIntegral . fromFVal $ sigtype putWord8 $ fromIntegral . fromFVal $ ha putWord8 $ fromIntegral . fromFVal $ pka- putLazyByteString (unEOKI skeyid)+ putByteString (unEOKI skeyid) putWord8 . fromIntegral . fromEnum $ not (unNestedFlag nested) putLengthThenPayload bs @@ -1671,7 +1675,7 @@ putOPSV6 (OPSPayloadV6 sigtype ha pka salt signerFingerprint nested) = do putWord8 (0xc0 .|. 4) let saltBytes = unSignatureSalt salt- saltSize = BL.length saltBytes+ saltSize = B.length saltBytes expectedSaltSize = maybe ( error@@ -1690,7 +1694,7 @@ ++ ", got " ++ show saltSize )- when (BL.length signerFingerprint /= 32) $+ when (B.length (unFingerprint signerFingerprint) /= 32) $ error "OPS v6 signer fingerprint must be exactly 32 octets" let bs = runPut $ do@@ -1699,8 +1703,8 @@ putWord8 $ fromIntegral . fromFVal $ ha putWord8 $ fromIntegral . fromFVal $ pka putWord8 (fromIntegral saltSize)- putLazyByteString saltBytes- putLazyByteString signerFingerprint+ putByteString saltBytes+ putByteString (unFingerprint signerFingerprint) putWord8 . fromIntegral . fromEnum $ not (unNestedFlag nested) putLengthThenPayload bs @@ -1736,10 +1740,10 @@ putWord8 (0xc0 .|. 9) putLengthThenPayload b -putMarker :: BL.ByteString -> Put+putMarker :: B.ByteString -> Put putMarker b = do putWord8 (0xc0 .|. 10)- putLengthThenPayload b+ putLengthThenPayload (BL.fromStrict b) putLiteralData :: LiteralDataType@@ -1817,10 +1821,10 @@ putByteString (unSalt salt) putLazyByteString b -putModificationDetectionCode :: BL.ByteString -> Put+putModificationDetectionCode :: B.ByteString -> Put putModificationDetectionCode hash = do putWord8 (0xc0 .|. 19)- putLengthThenPayload hash+ putLengthThenPayload (BL.fromStrict hash) putPadding :: BL.ByteString -> Put putPadding padding = do@@ -1843,7 +1847,7 @@ ( PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier _ _)) ) = do- let keyIdentifierLen = BL.length recipientKeyIdentifier+ let keyIdentifierLen = B.length recipientKeyIdentifier when (keyIdentifierLen > 255) $ Left "PKESK v6 recipient key identifier must fit in one octet (max 255 bytes)"@@ -1853,7 +1857,7 @@ (OPSPayloadV6Packet (OPSPayloadV6 _ ha _ salt signerFingerprint _)) ) = do let saltBytes = unSignatureSalt salt- saltSize = BL.length saltBytes+ saltSize = B.length saltBytes expectedSaltSize <- case v6SaltSizeForHashAlgorithm ha of Nothing ->@@ -1870,7 +1874,7 @@ ++ ", got " ++ show saltSize )- when (BL.length signerFingerprint /= 32) $+ when (B.length (unFingerprint signerFingerprint) /= 32) $ Left "OPS v6 signer fingerprint must be exactly 32 octets" Right () validatePkt@@ -2638,7 +2642,7 @@ case pkp of PKPayloadV6 {} -> do sk <- getSecretKey pkpSome- return (SKAUnencryptedV6 sk)+ return (SKAUnprotectedV6 sk) PKPayloadV3 {} -> do rest <- lookAhead getRemainingLazyByteString secretLen <-@@ -2663,7 +2667,7 @@ ++ ", got " ++ show checksum )- return (SKAUnencryptedLegacy sk checksum)+ return (SKAUnprotectedLegacy sk checksum) PKPayloadV4 {} -> do rest <- lookAhead getRemainingLazyByteString secretLen <-@@ -2688,15 +2692,15 @@ ++ ", got " ++ show checksum )- return (SKAUnencryptedLegacy sk checksum)+ return (SKAUnprotectedLegacy sk checksum) 255 -> case pkp of PKPayloadV6 {} -> fail "v6 secret key packets MUST NOT use s2k usage 255" PKPayloadV3 {} ->- getLegacyS2KProtected SKA16bit+ getLegacyS2KProtected SKAMalleableCFB PKPayloadV4 {} ->- getLegacyS2KProtected SKA16bit+ getLegacyS2KProtected SKAMalleableCFB 254 -> case pkp of PKPayloadV6 {} -> do@@ -2710,11 +2714,11 @@ fail "unexpected trailing v6 CFB parameters" | otherwise -> pure parsed encryptedblock <- getRemainingLazyByteString- return (SKASHA1V6 symenc s2k (IV iv) encryptedblock)+ return (SKACFBV6 symenc s2k (IV iv) encryptedblock) PKPayloadV3 {} ->- getLegacyS2KProtected SKASHA1Legacy+ getLegacyS2KProtected SKACFBLegacy PKPayloadV4 {} ->- getLegacyS2KProtected SKASHA1Legacy+ getLegacyS2KProtected SKACFBLegacy where getV6CFBParams = do symencWord <- getWord8@@ -2790,35 +2794,31 @@ pure (toFVal symencWord, aead, s2k, iv) symenc -> case pkp of- PKPayloadV6 {} -> do- paramsLen <- getWord8- iv <- getByteString (fromIntegral paramsLen)- let symencAlg = toFVal symenc- blockSize <- either fail pure (symEncBlockSize symencAlg)- when (B.length iv /= blockSize) $- fail "invalid v6 CFB IV length"- encryptedblock <- getRemainingLazyByteString- return (SKASymV6 symencAlg (IV iv) encryptedblock)+ PKPayloadV6 {} ->+ fail+ "v6 secret key packets MUST NOT use LegacyCFB (known cipher algo ID)" PKPayloadV3 {} -> do blockSize <- either fail pure (symEncBlockSize (toFVal symenc)) iv <- getByteString blockSize encryptedblock <- getRemainingLazyByteString- return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock)+ return+ (SKALegacyCFBLegacy (toFVal symenc) (IV iv) encryptedblock) PKPayloadV4 {} -> do blockSize <- either fail pure (symEncBlockSize (toFVal symenc)) iv <- getByteString blockSize encryptedblock <- getRemainingLazyByteString- return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock)+ return+ (SKALegacyCFBLegacy (toFVal symenc) (IV iv) encryptedblock) putSKAddendum :: SKAddendum -> Either String Put-putSKAddendum (SUS16bit symenc s2k iv encryptedblock) =+putSKAddendum (SUSMalleableCFB symenc s2k iv encryptedblock) = Right $ do putWord8 255 put symenc put s2k putByteString (unIV iv) putLazyByteString encryptedblock-putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) =+putSKAddendum (SUSCFB symenc s2k iv encryptedblock) = Right $ do putWord8 254 put symenc@@ -2833,12 +2833,12 @@ put s2k putByteString (unIV iv) putLazyByteString encryptedblock-putSKAddendum (SUSym symenc iv encryptedblock) =+putSKAddendum (SUSLegacyCFB symenc iv encryptedblock) = Right $ do put symenc putByteString (unIV iv) putLazyByteString encryptedblock-putSKAddendum (SUUnencrypted sk checksum) =+putSKAddendum (SUSUnprotected sk checksum) = do putSecret <- putSKey sk Right $ do@@ -2881,7 +2881,7 @@ :: SomePKPayload -> SKAddendumV v -> Put-putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedLegacy sk checksum) = do+putSKAddendumForPKPayloadTyped pkp (SKAUnprotectedLegacy sk checksum) = do let skb = runPut ( case putSKeyForPKPayload pkp sk of@@ -2898,9 +2898,9 @@ skb else checksum )-putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedV6 sk) =+putSKAddendumForPKPayloadTyped pkp (SKAUnprotectedV6 sk) = putUnencryptedSKAddendum pkp sk-putSKAddendumForPKPayloadTyped _ (SKASHA1V6 symenc s2k iv encryptedblock) = do+putSKAddendumForPKPayloadTyped _ (SKACFBV6 symenc s2k iv encryptedblock) = do let s2kbs = runPut (put s2k) paramsLen = 1 + 1 + BL.length s2kbs + fromIntegral (B.length (unIV iv)) putWord8 254@@ -2929,7 +2929,7 @@ put s2k putByteString (unIV iv) putLazyByteString encryptedblock-putSKAddendumForPKPayloadTyped _ (SKASymV6 symenc iv encryptedblock) = do+putSKAddendumForPKPayloadTyped _ (SKALegacyCFBV6 symenc iv encryptedblock) = do putWord8 (fromFVal symenc) putWord8 (fromIntegral (B.length (unIV iv))) putByteString (unIV iv)@@ -3239,7 +3239,7 @@ guard (hashlen == 5) st <- getWord8 ctime <- fmap ThirtyTwoBitTimeStamp getWord32be- eok <- getLazyByteString 8+ eok <- getByteString 8 pka <- get ha <- get left16 <- getWord16be@@ -3360,7 +3360,7 @@ ++ show saltSize ) saltbs <- getByteString (fromIntegral saltSize)- let salt = SignatureSalt (BL.fromStrict saltbs)+ let salt = SignatureSalt saltbs if pka == BTypes.Ed25519 then do sig <- getByteString 64@@ -3417,7 +3417,7 @@ putWord8 5 -- hashlen put st putWord32be . unThirtyTwoBitTimeStamp $ ctime- putLazyByteString (unEOKI eok)+ putByteString (unEOKI eok) put pka put ha putWord16be left16@@ -3462,7 +3462,7 @@ ) id (v6SaltSizeForHashAlgorithm ha)- actualSaltSize = fromIntegral (BL.length (unSignatureSalt salt))+ actualSaltSize = fromIntegral (B.length (unSignatureSalt salt)) when (actualSaltSize /= expectedSaltSize) $ error ( "v6 signature salt size mismatch for "@@ -3483,8 +3483,8 @@ putWord32be . fromIntegral . BL.length $ ub putLazyByteString ub putWord16be left16- putWord8 . fromIntegral . BL.length . unSignatureSalt $ salt- putByteString (BL.toStrict (unSignatureSalt salt))+ putWord8 . fromIntegral . B.length . unSignatureSalt $ salt+ putByteString (unSignatureSalt salt) if pka == BTypes.Ed25519 then case NE.toList mpis of [MPI r, MPI s] -> do
Codec/Encryption/OpenPGP/SerializeForSigs.hs view
@@ -10,7 +10,9 @@ , putPartialSigforSigning , putSigTrailer , putUforSigning+ , putUserIdForSigning , putUIDforSigning+ , putUserAttributeForSigning , putUAtforSigning , putKeyforSigning , putSigforSigning@@ -162,20 +164,26 @@ putUforSigning u@(UserAttributePkt _) = putUAtforSigning u putUforSigning _ = error "This should never happen (putUforSigning)" -putUIDforSigning :: Pkt -> Put-putUIDforSigning (UserIdPkt u) = do+putUserIdForSigning :: UserId -> Put+putUserIdForSigning (UserId u) = do putWord8 0xB4 let bs = encodeUtf8 u putWord32be . fromIntegral . B.length $ bs putByteString bs++putUIDforSigning :: Pkt -> Put+putUIDforSigning (UserIdPkt u) = putUserIdForSigning (UserId u) putUIDforSigning _ = error "This should never happen (putUIDforSigning)" -putUAtforSigning :: Pkt -> Put-putUAtforSigning (UserAttributePkt us) = do+putUserAttributeForSigning :: UserAttribute -> Put+putUserAttributeForSigning (UserAttribute us) = do putWord8 0xD1 let bs = runPut (mapM_ put us) putWord32be . fromIntegral . BL.length $ bs putLazyByteString bs++putUAtforSigning :: Pkt -> Put+putUAtforSigning (UserAttributePkt us) = putUserAttributeForSigning (UserAttribute us) putUAtforSigning _ = error "This should never happen (putUAtforSigning)" putSigforSigning :: Pkt -> Put
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -27,12 +27,12 @@ , verifyAgainstPKPs , verifyAgainstPKPsWithPolicy , verifyTKWith- , signCertificationWithRSA- , signDirectKeyWithRSA- , signKeyRevocationWithRSA- , signSubkeyRevocationWithRSA- , signCertRevocationWithRSA- , signUserIDwithRSA+ , signUserId+ , signUat+ , signDirectKey+ , signSubkeyBinding+ , signSubkeyRevocation+ , signCertRevocation , crossSignSubkeyWithRSA , signDataWithEd25519 , signDataWithEd25519Legacy@@ -41,7 +41,21 @@ , signDataWithEd448V6 , signDataWithRSA , signDataWithRSAV6+ , signDataV6 + -- * Payload builders+ , payloadForUserId+ , payloadForUat+ , payloadForDirectKey+ , payloadForSubkeyRevocation+ , payloadForCertRevocation+ , payloadForSubkeyBinding+ , payloadForPrimaryKeyBinding++ -- * SignablePrivateKey typeclass+ , SignablePrivateKey (..)+ , SignablePrivateKeyV6 (..)+ -- * Builder-based API (Phase 2) , signDataWithRSABuilder , signDataWithRSAV6Builder@@ -69,6 +83,7 @@ import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.RSA.PKCS15 as P15 import qualified Crypto.PubKey.RSA.Types as RSATypes+import Crypto.Random.Types (MonadRandom, getRandomBytes) import Data.Bifunctor (first) import Data.Binary.Put (runPut) import qualified Data.ByteArray as BA@@ -1463,8 +1478,7 @@ v6Salt (SignaturePkt sigPayload) = case fromSignaturePayloadVerifiableSignatureV sigPayload of Just- (VerifiableSignatureV6 (SigPayloadV6Data _ _ _ salt _ _ _ _)) ->- unSignatureSalt salt+ (VerifiableSignatureV6 (SigPayloadV6Data _ _ _ salt _ _ _ _)) -> BL.fromStrict (unSignatureSalt salt) _ -> BL.empty v6Salt _ = BL.empty trailer :: Pkt -> ByteString@@ -1531,6 +1545,24 @@ ed448Signer sk prehash = BA.convert (Ed448.sign sk (Ed448.toPublic sk) prehash) +eddsaPrehash+ :: HashAlgorithm+ -> (B.ByteString -> B.ByteString)+eddsaPrehash ha = case ha of+ SHA1 -> BA.convert . hashWith CHA.SHA1+ SHA224 -> BA.convert . hashWith CHA.SHA224+ SHA256 -> BA.convert . hashWith CHA.SHA256+ SHA384 -> BA.convert . hashWith CHA.SHA384+ SHA512 -> BA.convert . hashWith CHA.SHA512+ SHA3_256 -> BA.convert . hashWith CHA.SHA3_256+ SHA3_512 -> BA.convert . hashWith CHA.SHA3_512+ RIPEMD160 -> BA.convert . hashWith CHA.RIPEMD160+ _ ->+ error+ ( "unsupported hash algorithm for EdDSA prehash: "+ ++ show ha+ )+ rsaPKCS15Sign :: HashAlgorithm -> RSATypes.PrivateKey@@ -1569,7 +1601,7 @@ validateV6SaltSize :: HashAlgorithm -> SignatureSalt -> Either SignError () validateV6SaltSize ha salt =- let saltBytes = BL.toStrict (unSignatureSalt salt)+ let saltBytes = unSignatureSalt salt actualSaltLen = B.length saltBytes in case signatureV6SaltSizeForHashAlgorithm ha of Nothing ->@@ -1585,6 +1617,16 @@ else Left (SignV6SaltSizeMismatch ha expectedSaltLen actualSaltLen) +randomSignatureSalt+ :: MonadRandom m+ => HashAlgorithm -> m SignatureSalt+randomSignatureSalt ha = case signatureV6SaltSizeForHashAlgorithm ha of+ Just n -> SignatureSalt <$> getRandomBytes (fromIntegral n)+ Nothing ->+ error $+ "signature hash algorithm does not define a V6 salt size: "+ ++ show ha+ signEdDSAV4 :: String -> Int@@ -1602,7 +1644,8 @@ let normalizedPayload = normalizePayloadForSigTypeWith mode st payload sig0 = SigV4 st pka ha has [] 0 (NE.fromList [MPI 0, MPI 0]) prehash =- hashWithSHA512+ eddsaPrehash+ ha (BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload)) sigBytes = signer prehash if B.length sigBytes /= sigLen@@ -1642,7 +1685,8 @@ let normalizedPayload = normalizePayloadForSigTypeWith mode st payload sig0 = SigV6 st pka ha salt has [] 0 (NE.fromList [MPI 0, MPI 0]) prehash =- hashWithSHA512+ eddsaPrehash+ ha (BL.toStrict (finalPayload (SignaturePkt sig0) normalizedPayload)) sigBytes = signer prehash if B.length sigBytes /= sigLen@@ -1664,155 +1708,28 @@ ) <$> first SignBackendError (left16FromHashPrefix prehash) -signUserIDwithRSA- :: SomePKPayload- -- ^ public key "payload" of user ID being signed+signUserId+ :: (MonadRandom m, SignablePrivateKey key, SignablePrivateKeyV6 key)+ => HashAlgorithm+ -> SigType+ -> KeyPkt 'SecretPkt -> UserId- -- ^ user ID being signed -> [SigSubPacket]- -- ^ hashed signature subpackets -> [SigSubPacket]- -- ^ unhashed signature subpackets- -> RSATypes.PrivateKey- -- ^ RSA signing key- -> Either SignError SignaturePayload-signUserIDwithRSA = signCertificationWithRSA PositiveCert--signCertificationWithRSA- :: SigType- -- ^ certification type (GenericCert, PersonaCert, CasualCert, PositiveCert)- -> SomePKPayload- -- ^ public key "payload" of user ID being signed- -> UserId- -- ^ user ID being signed- -> [SigSubPacket]- -- ^ hashed signature subpackets- -> [SigSubPacket]- -- ^ unhashed signature subpackets- -> RSATypes.PrivateKey- -- ^ RSA signing key- -> Either SignError SignaturePayload-signCertificationWithRSA st pkp uid hsigsubs usigsubs prv- | st `elem` [GenericCert, PersonaCert, CasualCert, PositiveCert] = do- let payloadToSign = BL.toStrict (finalPayload (SignaturePkt uidsigp) uidpayload)- uidsigp'- <$> left16FromSignedPayloadForSign SHA512 payloadToSign- <*> first- (SignBackendError . show)- ( P15.sign- Nothing- (Just CHA.SHA512)- prv- payloadToSign- )- | otherwise =- Left (SignUnsupportedCertificationType st)- where- uidpayload =- runPut- ( sequence_- [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)]- )- uidsigp =- SigV4 st RSA SHA512 hsigsubs usigsubs 0 (NE.fromList [MPI 0])- uidsigp' left16 us =- SigV4- st- RSA- SHA512- hsigsubs- usigsubs- left16- (NE.fromList [MPI (os2ip us)])--signDirectKeyWithRSA- :: SigType- -- ^ key-scoped signature type (DirectKeySignature or KeyRevocationSig)- -> SomePKPayload- -- ^ primary key "payload" being signed- -> [SigSubPacket]- -- ^ hashed signature subpackets- -> [SigSubPacket]- -- ^ unhashed signature subpackets- -> RSATypes.PrivateKey- -- ^ RSA signing key- -> Either SignError SignaturePayload-signDirectKeyWithRSA st pkp hsigsubs usigsubs prv- | st `elem` [DirectKeySignature, KeyRevocationSig] =- signDataWithRSA st prv hsigsubs usigsubs keypayload- | otherwise =- Left (SignUnsupportedKeySignatureType st)- where- keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp))--signKeyRevocationWithRSA- :: SomePKPayload- -- ^ primary key "payload" being revoked- -> [SigSubPacket]- -- ^ hashed signature subpackets- -> [SigSubPacket]- -- ^ unhashed signature subpackets- -> RSATypes.PrivateKey- -- ^ RSA signing key- -> Either SignError SignaturePayload-signKeyRevocationWithRSA = signDirectKeyWithRSA KeyRevocationSig--signSubkeyRevocationWithRSA- :: SomePKPayload- -- ^ primary key "payload"- -> SomePKPayload- -- ^ public subkey "payload" being revoked- -> [SigSubPacket]- -- ^ hashed signature subpackets- -> [SigSubPacket]- -- ^ unhashed signature subpackets- -> RSATypes.PrivateKey- -- ^ RSA signing key- -> Either SignError SignaturePayload-signSubkeyRevocationWithRSA pkp subpkp hsigsubs usigsubs prv =- signDataWithRSA- SubkeyRevocationSig- prv- hsigsubs- usigsubs- subkeypayload- where- subkeypayload =- runPut- ( sequence_- [ putKeyforSigning (PublicKeyPkt pkp)- , putKeyforSigning (PublicSubkeyPkt subpkp)- ]- )--signCertRevocationWithRSA- :: SomePKPayload- -- ^ primary key "payload"- -> UserId- -- ^ user ID certification being revoked- -> [SigSubPacket]- -- ^ hashed signature subpackets- -> [SigSubPacket]- -- ^ unhashed signature subpackets- -> RSATypes.PrivateKey- -- ^ RSA signing key- -> Either SignError SignaturePayload-signCertRevocationWithRSA pkp uid hsigsubs usigsubs prv =- signDataWithRSA- CertRevocationSig- prv- hsigsubs- usigsubs- certpayload- where- certpayload =- runPut- ( sequence_- [putKeyforSigning (PublicKeyPkt pkp), putUforSigning (toPkt uid)]- )+ -> key+ -> m (Either SignError SignaturePayload)+signUserId ha st kp uid hs us key = do+ let payload = payloadForUserId (keyPktPKPayload kp) uid+ case keyPktPKPayload kp of+ PKPayload V4 _ _ _ _ -> pure $ signPayloadWith ha st hs us payload key+ PKPayload V6 _ _ _ _ -> do+ salt <- randomSignatureSalt ha+ pure $ signPayloadWithV6 ha st salt hs us payload key+ PKPayload DeprecatedV3 _ _ _ _ -> pure $ signPayloadWith ha st hs us payload key crossSignSubkeyWithRSA- :: SomePKPayload+ :: HashAlgorithm+ -> SomePKPayload -- ^ public key "payload" of key being signed -> SomePKPayload -- ^ public subkey "payload" of key being signed@@ -1829,7 +1746,7 @@ -> RSATypes.PrivateKey -- ^ RSA signing subkey -> Either SignError SignaturePayload-crossSignSubkeyWithRSA pkp subpkp subhsigsubs subusigsubs embhsigsubs embusigsubs prv ssb = do+crossSignSubkeyWithRSA ha pkp subpkp subhsigsubs subusigsubs embhsigsubs embusigsubs prv ssb = do let embPayloadToSign = BL.toStrict (finalPayload (SignaturePkt embsigp) subkeypayload) subPayloadToSign =@@ -1837,24 +1754,10 @@ ( \embleft16 subleft16 embsig subsig -> subsigp' (embsigp' embleft16 embsig) subleft16 subsig )- <$> left16FromSignedPayloadForSign SHA512 embPayloadToSign- <*> left16FromSignedPayloadForSign SHA512 subPayloadToSign- <*> first- (SignBackendError . show)- ( P15.sign- Nothing- (Just CHA.SHA512)- ssb- embPayloadToSign- )- <*> first- (SignBackendError . show)- ( P15.sign- Nothing- (Just CHA.SHA512)- prv- subPayloadToSign- )+ <$> left16FromSignedPayloadForSign ha embPayloadToSign+ <*> left16FromSignedPayloadForSign ha subPayloadToSign+ <*> rsaPKCS15Sign ha ssb embPayloadToSign+ <*> rsaPKCS15Sign ha prv subPayloadToSign where subkeypayload = runPut@@ -1867,7 +1770,7 @@ SigV4 PrimaryKeyBindingSig RSA- SHA512+ ha embhsigsubs embusigsubs 0@@ -1876,7 +1779,7 @@ SigV4 PrimaryKeyBindingSig RSA- SHA512+ ha embhsigsubs embusigsubs left16@@ -1885,7 +1788,7 @@ SigV4 SubkeyBindingSig RSA- SHA512+ ha subhsigsubs [] 0@@ -1895,7 +1798,7 @@ SigV4 SubkeyBindingSig RSA- SHA512+ ha subhsigsubs (sspes es : subusigsubs) left16@@ -1960,25 +1863,28 @@ ) signDataWithRSA- :: SigType+ :: HashAlgorithm+ -> SigType -> RSATypes.PrivateKey -> [SigSubPacket] -> [SigSubPacket] -> ByteString -> Either SignError SignaturePayload-signDataWithRSA st prv has uhas payload =- signRSAV4Core CleartextCompat st SHA512 has uhas prv payload+signDataWithRSA ha st prv has uhas payload =+ signRSAV4Core CleartextCompat st ha has uhas prv payload -signDataWithRSAV6- :: SigType+signDataV6+ :: SignablePrivateKeyV6 key+ => HashAlgorithm+ -> SigType -> SignatureSalt- -> RSATypes.PrivateKey -> [SigSubPacket] -> [SigSubPacket] -> ByteString+ -> key -> Either SignError SignaturePayload-signDataWithRSAV6 st salt prv has uhas payload =- signRSAV6Core CleartextCompat st SHA512 salt has uhas prv payload+signDataV6 ha st salt hs us payload key =+ signPayloadWithV6 ha st salt hs us payload key -- FIXME: clean this up ed25519Params@@ -2040,55 +1946,58 @@ payload signDataWithEd25519- :: SigType+ :: HashAlgorithm+ -> SigType -> Ed25519.SecretKey -> [SigSubPacket] -> [SigSubPacket] -> ByteString -> Either SignError SignaturePayload-signDataWithEd25519 st sk has uhas payload =+signDataWithEd25519 ha st sk has uhas payload = signDataWithEdDSAV4Generic ed25519Params (ed25519Signer sk) CleartextCompat- SHA512+ ha st has uhas payload signDataWithEd25519Legacy- :: SigType+ :: HashAlgorithm+ -> SigType -> Ed25519.SecretKey -> [SigSubPacket] -> [SigSubPacket] -> ByteString -> Either SignError SignaturePayload-signDataWithEd25519Legacy st sk has uhas payload =+signDataWithEd25519Legacy ha st sk has uhas payload = signDataWithEdDSAV4Generic ed25519LegacyParams (ed25519Signer sk) CleartextCompat- SHA512+ ha st has uhas payload signDataWithEd25519V6- :: SigType+ :: HashAlgorithm+ -> SigType -> SignatureSalt -> Ed25519.SecretKey -> [SigSubPacket] -> [SigSubPacket] -> ByteString -> Either SignError SignaturePayload-signDataWithEd25519V6 st salt sk has uhas payload =+signDataWithEd25519V6 ha st salt sk has uhas payload = signDataWithEdDSAV6Generic ed25519Params (ed25519Signer sk) CleartextCompat- SHA512+ ha st salt has@@ -2096,37 +2005,39 @@ payload signDataWithEd448- :: SigType+ :: HashAlgorithm+ -> SigType -> Ed448.SecretKey -> [SigSubPacket] -> [SigSubPacket] -> ByteString -> Either SignError SignaturePayload-signDataWithEd448 st sk has uhas payload =+signDataWithEd448 ha st sk has uhas payload = signDataWithEdDSAV4Generic ed448Params (ed448Signer sk) CleartextCompat- SHA512+ ha st has uhas payload signDataWithEd448V6- :: SigType+ :: HashAlgorithm+ -> SigType -> SignatureSalt -> Ed448.SecretKey -> [SigSubPacket] -> [SigSubPacket] -> ByteString -> Either SignError SignaturePayload-signDataWithEd448V6 st salt sk has uhas payload =+signDataWithEd448V6 ha st salt sk has uhas payload = signDataWithEdDSAV6Generic ed448Params (ed448Signer sk) CleartextCompat- SHA512+ ha st salt has@@ -2281,6 +2192,217 @@ (sbHashedSubs builder) (sbUnhashedSubs builder) payload++payloadForUserId :: SomePKPayload -> UserId -> ByteString+payloadForUserId pkp uid =+ runPut+ ( sequence_+ [ putKeyforSigning (PublicKeyPkt pkp)+ , putUforSigning (toPkt uid)+ ]+ )++payloadForUat :: SomePKPayload -> UserAttribute -> ByteString+payloadForUat pkp uat =+ runPut+ ( sequence_+ [ putKeyforSigning (PublicKeyPkt pkp)+ , putUforSigning (toPkt uat)+ ]+ )++payloadForDirectKey :: SomePKPayload -> ByteString+payloadForDirectKey pkp =+ runPut (putKeyforSigning (PublicKeyPkt pkp))++payloadForSubkeyRevocation+ :: SomePKPayload -> SomePKPayload -> ByteString+payloadForSubkeyRevocation pkp subpkp =+ runPut+ ( sequence_+ [ putKeyforSigning (PublicKeyPkt pkp)+ , putKeyforSigning (PublicSubkeyPkt subpkp)+ ]+ )++payloadForCertRevocation :: SomePKPayload -> UserId -> ByteString+payloadForCertRevocation pkp uid =+ runPut+ ( sequence_+ [ putKeyforSigning (PublicKeyPkt pkp)+ , putUforSigning (toPkt uid)+ ]+ )++payloadForSubkeyBinding+ :: SomePKPayload -> SomePKPayload -> ByteString+payloadForSubkeyBinding = payloadForSubkeyRevocation++payloadForPrimaryKeyBinding+ :: SomePKPayload -> SomePKPayload -> ByteString+payloadForPrimaryKeyBinding = payloadForSubkeyRevocation++signDataWithRSAV6+ :: HashAlgorithm+ -> SigType+ -> SignatureSalt+ -> RSATypes.PrivateKey+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> ByteString+ -> Either SignError SignaturePayload+signDataWithRSAV6 ha st salt prv has uhas payload =+ signRSAV6Core CleartextCompat st ha salt has uhas prv payload++class SignablePrivateKey key where+ signPayloadWith+ :: HashAlgorithm+ -> SigType+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> ByteString+ -> key+ -> Either SignError SignaturePayload++instance SignablePrivateKey RSATypes.PrivateKey where+ signPayloadWith ha st has uhas payload prv =+ signDataWithRSA ha st prv has uhas payload++instance SignablePrivateKey Ed25519.SecretKey where+ signPayloadWith ha st has uhas payload sk =+ signDataWithEd25519 ha st sk has uhas payload++instance SignablePrivateKey Ed448.SecretKey where+ signPayloadWith ha st has uhas payload sk =+ signDataWithEd448 ha st sk has uhas payload++class SignablePrivateKeyV6 key where+ signPayloadWithV6+ :: HashAlgorithm+ -> SigType+ -> SignatureSalt+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> ByteString+ -> key+ -> Either SignError SignaturePayload++instance SignablePrivateKeyV6 RSATypes.PrivateKey where+ signPayloadWithV6 ha st salt has uhas payload prv =+ signDataWithRSAV6 ha st salt prv has uhas payload++instance SignablePrivateKeyV6 Ed25519.SecretKey where+ signPayloadWithV6 ha st salt has uhas payload sk =+ signDataWithEd25519V6 ha st salt sk has uhas payload++instance SignablePrivateKeyV6 Ed448.SecretKey where+ signPayloadWithV6 ha st salt has uhas payload sk =+ signDataWithEd448V6 ha st salt sk has uhas payload++signUat+ :: (MonadRandom m, SignablePrivateKey key, SignablePrivateKeyV6 key)+ => HashAlgorithm+ -> SigType+ -> KeyPkt 'SecretPkt+ -> UserAttribute+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> key+ -> m (Either SignError SignaturePayload)+signUat ha st kp uat hs us key = do+ let payload = payloadForUat (keyPktPKPayload kp) uat+ case keyPktPKPayload kp of+ PKPayload V4 _ _ _ _ -> pure $ signPayloadWith ha st hs us payload key+ PKPayload V6 _ _ _ _ -> do+ salt <- randomSignatureSalt ha+ pure $ signPayloadWithV6 ha st salt hs us payload key+ PKPayload DeprecatedV3 _ _ _ _ -> pure $ signPayloadWith ha st hs us payload key++signDirectKey+ :: (MonadRandom m, SignablePrivateKey key, SignablePrivateKeyV6 key)+ => HashAlgorithm+ -> SigType+ -> KeyPkt 'SecretPkt+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> key+ -> m (Either SignError SignaturePayload)+signDirectKey ha st kp hs us key+ | st `notElem` [DirectKeySignature, KeyRevocationSig] =+ pure $ Left (SignUnsupportedKeySignatureType st)+ | otherwise = do+ let payload = payloadForDirectKey (keyPktPKPayload kp)+ case keyPktPKPayload kp of+ PKPayload V4 _ _ _ _ -> pure $ signPayloadWith ha st hs us payload key+ PKPayload V6 _ _ _ _ -> do+ salt <- randomSignatureSalt ha+ pure $ signPayloadWithV6 ha st salt hs us payload key+ PKPayload DeprecatedV3 _ _ _ _ -> pure $ signPayloadWith ha st hs us payload key++signSubkeyBinding+ :: (MonadRandom m, SignablePrivateKey key, SignablePrivateKeyV6 key)+ => HashAlgorithm+ -> KeyPkt 'SecretPkt+ -> KeyPkt 'SecretPkt+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> key+ -> m (Either SignError SignaturePayload)+signSubkeyBinding ha kp subkp hs us key = do+ let payload =+ payloadForSubkeyBinding+ (keyPktPKPayload kp)+ (keyPktPKPayload subkp)+ case keyPktPKPayload kp of+ PKPayload V4 _ _ _ _ -> pure $ signPayloadWith ha SubkeyBindingSig hs us payload key+ PKPayload V6 _ _ _ _ -> do+ salt <- randomSignatureSalt ha+ pure $+ signPayloadWithV6 ha SubkeyBindingSig salt hs us payload key+ PKPayload DeprecatedV3 _ _ _ _ -> pure $ signPayloadWith ha SubkeyBindingSig hs us payload key++signSubkeyRevocation+ :: (MonadRandom m, SignablePrivateKey key, SignablePrivateKeyV6 key)+ => HashAlgorithm+ -> KeyPkt 'SecretPkt+ -> KeyPkt 'SecretPkt+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> key+ -> m (Either SignError SignaturePayload)+signSubkeyRevocation ha kp subkp hs us key = do+ let payload =+ payloadForSubkeyRevocation+ (keyPktPKPayload kp)+ (keyPktPKPayload subkp)+ case keyPktPKPayload kp of+ PKPayload V4 _ _ _ _ ->+ pure $ signPayloadWith ha SubkeyRevocationSig hs us payload key+ PKPayload V6 _ _ _ _ -> do+ salt <- randomSignatureSalt ha+ pure $+ signPayloadWithV6 ha SubkeyRevocationSig salt hs us payload key+ PKPayload DeprecatedV3 _ _ _ _ ->+ pure $ signPayloadWith ha SubkeyRevocationSig hs us payload key++signCertRevocation+ :: (MonadRandom m, SignablePrivateKey key, SignablePrivateKeyV6 key)+ => HashAlgorithm+ -> KeyPkt 'SecretPkt+ -> UserId+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> key+ -> m (Either SignError SignaturePayload)+signCertRevocation ha kp uid hs us key = do+ let payload = payloadForCertRevocation (keyPktPKPayload kp) uid+ case keyPktPKPayload kp of+ PKPayload V4 _ _ _ _ -> pure $ signPayloadWith ha CertRevocationSig hs us payload key+ PKPayload V6 _ _ _ _ -> do+ salt <- randomSignatureSalt ha+ pure $+ signPayloadWithV6 ha CertRevocationSig salt hs us payload key+ PKPayload DeprecatedV3 _ _ _ _ -> pure $ signPayloadWith ha CertRevocationSig hs us payload key {- | Algorithm-agnostic signature builder dispatcher (Phase 2)
Codec/Encryption/OpenPGP/Types/Internal/Base.hs view
@@ -47,9 +47,7 @@ , ByteRange (..) , rangeOffset , rangeLength- , WireRepSourceId (..) , WireRepRef (..)- , wireRepSourceId , wireRepLength , wireRepName , wireRepWasOriginallyArmored@@ -136,21 +134,21 @@ import qualified Data.Aeson.Key as AK import qualified Data.Aeson.TH as ATH import Data.Bits ((.&.))-import Data.ByteArray (ByteArrayAccess)+import Data.ByteArray (ByteArray, ByteArrayAccess) import Data.ByteArray.Encoding ( Base (..) , convertFromBase , convertToBase ) import qualified Data.ByteString as B-import qualified Data.ByteString.Base16.Lazy as B16L+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Char8 as BC8 import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BLC8 import Data.Char (toLower, toUpper) import Data.Data (Data) import Data.Hashable (Hashable (..))-import Data.IORef (IORef, atomicModifyIORef', newIORef) import Data.Int (Int64) import Data.Kind (Type) import Data.List (unfoldr)@@ -173,7 +171,6 @@ import Network.URI (URI (..), nullURI, parseURI, uriToString) import Numeric (readHex) import Prettyprinter (Pretty (..), hsep, punctuate, space, (<+>))-import System.IO.Unsafe (unsafePerformIO) import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils ( prettyBS@@ -285,16 +282,9 @@ } deriving (Data, Eq, Generic, Ord, Show, Typeable) -newtype WireRepSourceId- = WireRepSourceId- { _unWireRepSourceId :: Int64- }- deriving (Data, Eq, Generic, Ord, Show, Typeable)- data WireRepRef = WireRepRef- { _wireRepSourceId :: WireRepSourceId- , _wireRepLength :: Int64+ { _wireRepLength :: Int64 , _wireRepName :: Maybe Text , _wireRepWasOriginallyArmored :: Bool }@@ -313,8 +303,7 @@ :: Maybe Text -> Bool -> Int64 -> WireRepRef mkWireRepRefWithLength mname wasOriginallyArmored payloadLen = WireRepRef- { _wireRepSourceId = freshWireRepSourceId payloadLen- , _wireRepLength = payloadLen+ { _wireRepLength = payloadLen , _wireRepName = mname , _wireRepWasOriginallyArmored = wasOriginallyArmored }@@ -323,19 +312,6 @@ mkWireRepRef mname wasOriginallyArmored = mkWireRepRefWithLength mname wasOriginallyArmored . BL.length -wireRepSourceCounter :: IORef Int64-wireRepSourceCounter = unsafePerformIO (newIORef 0)-{-# NOINLINE wireRepSourceCounter #-}-freshWireRepSourceId :: Int64 -> WireRepSourceId-freshWireRepSourceId !_ =- unsafePerformIO $- atomicModifyIORef'- wireRepSourceCounter- ( \n ->- let n' = n + 1- in (n', WireRepSourceId n')- )-{-# NOINLINE freshWireRepSourceId #-} rangeEnd :: ByteRange -> Int64 rangeEnd r = _rangeOffset r + _rangeLength r @@ -682,7 +658,7 @@ -} newtype Fingerprint = Fingerprint- { unFingerprint :: ByteString+ { unFingerprint :: B.ByteString } deriving (Data, Eq, Generic, Ord, Show, Typeable) @@ -693,7 +669,7 @@ let ws = hexToW8s (filter (/= ' ') s) in if null ws then []- else [(Fingerprint (BL.pack (map fst ws)), snd (last ws))]+ else [(Fingerprint (B.pack (map fst ws)), snd (last ws))] instance Hashable Fingerprint @@ -727,8 +703,8 @@ . unFingerprint . op SpacedFingerprint -bsToHexUpper :: ByteString -> String-bsToHexUpper = map toUpper . BLC8.unpack . B16L.encode+bsToHexUpper :: B.ByteString -> String+bsToHexUpper = map toUpper . BC8.unpack . B16.encode hexToW8s :: ReadS Word8 hexToW8s = concatMap readHex . chunksOf 2 . map toLower@@ -803,7 +779,7 @@ newtype EightOctetKeyId = EightOctetKeyId- { unEOKI :: ByteString+ { unEOKI :: B.ByteString } deriving (Data, Eq, Generic, Ord, Typeable) @@ -817,7 +793,7 @@ instance Read EightOctetKeyId where readsPrec _ =- map ((EightOctetKeyId . BL.pack *** concat) . unzip)+ map ((EightOctetKeyId . B.pack *** concat) . unzip) . chunksOf 8 . hexToW8s @@ -1309,20 +1285,27 @@ newtype SignatureSalt = SignatureSalt- { unSignatureSalt :: ByteString+ { unSignatureSalt :: B.ByteString }- deriving (Data, Eq, Generic, Show, Typeable)--instance Ord SignatureSalt where- compare (SignatureSalt a) (SignatureSalt b) = compare a b--instance Hashable SignatureSalt+ deriving+ ( ByteArray+ , ByteArrayAccess+ , Data+ , Eq+ , Generic+ , Hashable+ , Monoid+ , Ord+ , Semigroup+ , Show+ , Typeable+ ) instance Pretty SignatureSalt where- pretty (SignatureSalt bs) = prettyLBS bs+ pretty (SignatureSalt bs) = prettyBS bs instance A.ToJSON SignatureSalt where- toJSON (SignatureSalt bs) = A.toJSON (BL.unpack bs)+ toJSON (SignatureSalt bs) = A.toJSON (B.unpack bs) data SignaturePayloadVersion = SigPayloadV3@@ -1878,7 +1861,8 @@ { unIV :: B.ByteString } deriving- ( ByteArrayAccess+ ( ByteArray+ , ByteArrayAccess , Data , Eq , Generic@@ -1895,7 +1879,7 @@ compare (IV b1) (IV b2) = compare b1 b2 instance Pretty IV where- pretty = pretty . ("iv:" ++) . bsToHexUpper . BL.fromStrict . op IV+ pretty = pretty . ("iv:" ++) . bsToHexUpper . op IV instance A.ToJSON IV where toJSON = A.toJSON . show . op IV@@ -1937,7 +1921,18 @@ = SessionKey { unSessionKey :: B.ByteString }- deriving (Data, Eq, Generic, Hashable, Show, Typeable)+ deriving+ ( ByteArray+ , ByteArrayAccess+ , Data+ , Eq+ , Generic+ , Hashable+ , Monoid+ , Semigroup+ , Show+ , Typeable+ ) instance Wrapped SessionKey @@ -1948,7 +1943,18 @@ = Salt { unSalt :: B.ByteString }- deriving (Data, Eq, Generic, Hashable, Show, Typeable)+ deriving+ ( ByteArray+ , ByteArrayAccess+ , Data+ , Eq+ , Generic+ , Hashable+ , Monoid+ , Semigroup+ , Show+ , Typeable+ ) instance Wrapped Salt @@ -1956,7 +1962,7 @@ compare (Salt b1) (Salt b2) = compare b1 b2 instance Pretty Salt where- pretty = pretty . ("salt:" ++) . bsToHexUpper . BL.fromStrict . op Salt+ pretty = pretty . ("salt:" ++) . bsToHexUpper . op Salt instance A.ToJSON Salt where toJSON = A.toJSON . show . op Salt@@ -1965,7 +1971,18 @@ = Salt8 { unSalt8 :: B.ByteString }- deriving (Data, Eq, Generic, Hashable, Show, Typeable)+ deriving+ ( ByteArray+ , ByteArrayAccess+ , Data+ , Eq+ , Generic+ , Hashable+ , Monoid+ , Semigroup+ , Show+ , Typeable+ ) instance Wrapped Salt8 @@ -1974,7 +1991,7 @@ instance Pretty Salt8 where pretty =- pretty . ("salt8:" ++) . bsToHexUpper . BL.fromStrict . op Salt8+ pretty . ("salt8:" ++) . bsToHexUpper . op Salt8 instance A.ToJSON Salt8 where toJSON = A.toJSON . show . op Salt8@@ -1983,7 +2000,18 @@ = Salt16 { unSalt16 :: B.ByteString }- deriving (Data, Eq, Generic, Hashable, Show, Typeable)+ deriving+ ( ByteArray+ , ByteArrayAccess+ , Data+ , Eq+ , Generic+ , Hashable+ , Monoid+ , Semigroup+ , Show+ , Typeable+ ) instance Wrapped Salt16 @@ -1995,7 +2023,6 @@ pretty . ("salt16:" ++) . bsToHexUpper- . BL.fromStrict . op Salt16 instance A.ToJSON Salt16 where@@ -2100,7 +2127,7 @@ pretty (OtherS2K t bs) = pretty "unknown S2K type" <+> pretty t- <+> pretty (bsToHexUpper bs)+ <+> pretty (bsToHexUpper (BL.toStrict bs)) instance A.ToJSON S2K where toJSON (Simple ha) = A.toJSON ha@@ -2201,5 +2228,6 @@ } -- intentionally not encoded as a list length prefix deriving (Eq, Show) -newtype Passphrase = Passphrase {unPassphrase :: BL.ByteString}- deriving (Eq, Ord, Show)+newtype Passphrase = Passphrase {unPassphrase :: B.ByteString}+ deriving+ (ByteArray, ByteArrayAccess, Eq, Monoid, Ord, Semigroup, Show)
Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs view
@@ -17,6 +17,7 @@ module Codec.Encryption.OpenPGP.Types.Internal.PKITypes where import qualified Data.Aeson as A+import Data.ByteArray.Encoding (Base (..), convertToBase) import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL@@ -31,6 +32,9 @@ import Codec.Encryption.OpenPGP.Types.Internal.Base import Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes+import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils+ ( prettyBS+ ) data EdSigningCurve = EdSigningCurve25519@@ -98,10 +102,12 @@ pretty "ECDH" <+> pretty p <+> pretty ha <+> pretty sa pretty (ECDSAPubKey p) = pretty "ECDSA" <+> pretty p pretty (EdDSAPubKey c ep) = pretty c <+> pretty ep- pretty (MLKEMPubKey bs) = pretty "ML-KEM" <+> pretty (bsToHexUpper (BL.fromStrict bs))- pretty (MLDSAPubKey bs) = pretty "ML-DSA" <+> pretty (bsToHexUpper (BL.fromStrict bs))- pretty (SLHDSAPubKey bs) = pretty "SLH-DSA" <+> pretty (bsToHexUpper (BL.fromStrict bs))- pretty (UnknownPKey bs) = pretty "<unknown>" <+> pretty (bsToHexUpper bs)+ pretty (MLKEMPubKey bs) = pretty "ML-KEM" <+> prettyBS (convertToBase Base64 bs)+ pretty (MLDSAPubKey bs) = pretty "ML-DSA" <+> prettyBS (convertToBase Base64 bs)+ pretty (SLHDSAPubKey bs) = pretty "SLH-DSA" <+> prettyBS (convertToBase Base64 bs)+ pretty (UnknownPKey bs) =+ pretty "<unknown>"+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs)) instance A.ToJSON PKey where toJSON (RSAPubKey p) = A.toJSON p@@ -141,21 +147,23 @@ pretty (ECDHPrivateKey p) = pretty "ECDH" <+> pretty p pretty (ECDSAPrivateKey p) = pretty "ECDSA" <+> pretty p pretty (EdDSAPrivateKey c bs) =- pretty c <+> pretty (bsToHexUpper (BL.fromStrict bs))+ pretty c <+> prettyBS (convertToBase Base64 bs) pretty (Ed25519PrivateKey bs) =- pretty "Ed25519" <+> pretty (bsToHexUpper (BL.fromStrict bs))+ pretty "Ed25519" <+> prettyBS (convertToBase Base64 bs) pretty (Ed448PrivateKey bs) =- pretty "Ed448" <+> pretty (bsToHexUpper (BL.fromStrict bs))- pretty (X25519PrivateKey bs) = pretty "X25519" <+> pretty (bsToHexUpper (BL.fromStrict bs))- pretty (X448PrivateKey bs) = pretty "X448" <+> pretty (bsToHexUpper (BL.fromStrict bs))+ pretty "Ed448" <+> prettyBS (convertToBase Base64 bs)+ pretty (X25519PrivateKey bs) = pretty "X25519" <+> prettyBS (convertToBase Base64 bs)+ pretty (X448PrivateKey bs) = pretty "X448" <+> prettyBS (convertToBase Base64 bs) pretty (MLKEMPrivateKey bs) =- pretty "ML-KEM-priv" <+> pretty (bsToHexUpper (BL.fromStrict bs))+ pretty "ML-KEM-priv" <+> prettyBS (convertToBase Base64 bs) pretty (MLDSAPrivateKey bs) =- pretty "ML-DSA-priv" <+> pretty (bsToHexUpper (BL.fromStrict bs))+ pretty "ML-DSA-priv" <+> prettyBS (convertToBase Base64 bs) pretty (SLHDSAPrivateKey bs) = pretty "SLH-DSA-priv"- <+> pretty (bsToHexUpper (BL.fromStrict bs))- pretty (UnknownSKey bs) = pretty "<unknown>" <+> pretty (bsToHexUpper bs)+ <+> prettyBS (convertToBase Base64 bs)+ pretty (UnknownSKey bs) =+ pretty "<unknown>"+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs)) instance A.ToJSON SKey where toJSON (RSAPrivateKey k) = A.toJSON k@@ -309,20 +317,39 @@ _pubkey (PKPayload _ _ _ _ p) = p data SKAddendum- = SUS16bit SymmetricAlgorithm S2K IV ByteString- | SUSSHA1 SymmetricAlgorithm S2K IV ByteString+ = SUSMalleableCFB SymmetricAlgorithm S2K IV ByteString+ | SUSCFB SymmetricAlgorithm S2K IV ByteString | SUSAEAD SymmetricAlgorithm AEADAlgorithm S2K IV ByteString- | SUSym SymmetricAlgorithm IV ByteString- | SUUnencrypted SKey Word16+ | SUSLegacyCFB SymmetricAlgorithm IV ByteString+ | SUSUnprotected SKey Word16 deriving (Data, Eq, Generic, Show, Typeable) +{-# DEPRECATED SUS16bit "Use SUSMalleableCFB" #-}+pattern SUS16bit+ :: SymmetricAlgorithm -> S2K -> IV -> ByteString -> SKAddendum+pattern SUS16bit sa s2k iv bs = SUSMalleableCFB sa s2k iv bs++{-# DEPRECATED SUSSHA1 "Use SUSCFB" #-}+pattern SUSSHA1+ :: SymmetricAlgorithm -> S2K -> IV -> ByteString -> SKAddendum+pattern SUSSHA1 sa s2k iv bs = SUSCFB sa s2k iv bs++{-# DEPRECATED SUSym "Use SUSLegacyCFB" #-}+pattern SUSym+ :: SymmetricAlgorithm -> IV -> ByteString -> SKAddendum+pattern SUSym sa iv bs = SUSLegacyCFB sa iv bs++{-# DEPRECATED SUUnencrypted "Use SUSUnprotected" #-}+pattern SUUnencrypted :: SKey -> Word16 -> SKAddendum+pattern SUUnencrypted sk ck = SUSUnprotected sk ck+ instance Ord SKAddendum where- compare (SUS16bit sa1 s2k1 iv1 bs1) (SUS16bit sa2 s2k2 iv2 bs2) =+ compare (SUSMalleableCFB sa1 s2k1 iv1 bs1) (SUSMalleableCFB sa2 s2k2 iv2 bs2) = compare sa1 sa2 <> compare s2k1 s2k2 <> compare iv1 iv2 <> compare bs1 bs2- compare (SUSSHA1 sa1 s2k1 iv1 bs1) (SUSSHA1 sa2 s2k2 iv2 bs2) =+ compare (SUSCFB sa1 s2k1 iv1 bs1) (SUSCFB sa2 s2k2 iv2 bs2) = compare sa1 sa2 <> compare s2k1 s2k2 <> compare iv1 iv2@@ -333,64 +360,64 @@ <> compare s2k1 s2k2 <> compare iv1 iv2 <> compare bs1 bs2- compare (SUSym sa1 iv1 bs1) (SUSym sa2 iv2 bs2) =+ compare (SUSLegacyCFB sa1 iv1 bs1) (SUSLegacyCFB sa2 iv2 bs2) = compare sa1 sa2 <> compare iv1 iv2 <> compare bs1 bs2- compare (SUUnencrypted sk1 ck1) (SUUnencrypted sk2 ck2) =+ compare (SUSUnprotected sk1 ck1) (SUSUnprotected sk2 ck2) = compare sk1 sk2 <> compare ck1 ck2- compare SUS16bit {} SUSSHA1 {} = LT- compare SUS16bit {} SUSAEAD {} = LT- compare SUS16bit {} SUSym {} = LT- compare SUS16bit {} SUUnencrypted {} = LT- compare SUSSHA1 {} SUS16bit {} = GT- compare SUSSHA1 {} SUSAEAD {} = LT- compare SUSSHA1 {} SUSym {} = LT- compare SUSSHA1 {} SUUnencrypted {} = LT- compare SUSAEAD {} SUS16bit {} = GT- compare SUSAEAD {} SUSSHA1 {} = GT- compare SUSAEAD {} SUSym {} = LT- compare SUSAEAD {} SUUnencrypted {} = LT- compare SUSym {} SUS16bit {} = GT- compare SUSym {} SUSSHA1 {} = GT- compare SUSym {} SUSAEAD {} = GT- compare SUSym {} SUUnencrypted {} = LT- compare SUUnencrypted {} _ = GT+ compare SUSMalleableCFB {} SUSCFB {} = LT+ compare SUSMalleableCFB {} SUSAEAD {} = LT+ compare SUSMalleableCFB {} SUSLegacyCFB {} = LT+ compare SUSMalleableCFB {} SUSUnprotected {} = LT+ compare SUSCFB {} SUSMalleableCFB {} = GT+ compare SUSCFB {} SUSAEAD {} = LT+ compare SUSCFB {} SUSLegacyCFB {} = LT+ compare SUSCFB {} SUSUnprotected {} = LT+ compare SUSAEAD {} SUSMalleableCFB {} = GT+ compare SUSAEAD {} SUSCFB {} = GT+ compare SUSAEAD {} SUSLegacyCFB {} = LT+ compare SUSAEAD {} SUSUnprotected {} = LT+ compare SUSLegacyCFB {} SUSMalleableCFB {} = GT+ compare SUSLegacyCFB {} SUSCFB {} = GT+ compare SUSLegacyCFB {} SUSAEAD {} = GT+ compare SUSLegacyCFB {} SUSUnprotected {} = LT+ compare SUSUnprotected {} _ = GT instance Hashable SKAddendum instance Pretty SKAddendum where- pretty (SUS16bit sa s2k iv bs) =- pretty "SUS16bit"+ pretty (SUSMalleableCFB sa s2k iv bs) =+ pretty "SUSMalleableCFB" <+> pretty sa <+> pretty s2k <+> pretty iv- <+> pretty (bsToHexUpper bs)- pretty (SUSSHA1 sa s2k iv bs) =- pretty "SUSSHA1"+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs))+ pretty (SUSCFB sa s2k iv bs) =+ pretty "SUSCFB" <+> pretty sa <+> pretty s2k <+> pretty iv- <+> pretty (bsToHexUpper bs)+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs)) pretty (SUSAEAD sa aa s2k iv bs) = pretty "SUSAEAD" <+> pretty sa <+> pretty aa <+> pretty s2k <+> pretty iv- <+> pretty (bsToHexUpper bs)- pretty (SUSym sa iv bs) =- pretty "SUSym"+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs))+ pretty (SUSLegacyCFB sa iv bs) =+ pretty "SUSLegacyCFB" <+> pretty sa <+> pretty iv- <+> pretty (bsToHexUpper bs)- pretty (SUUnencrypted s ck) =- pretty "SUUnencrypted" <+> pretty s <+> pretty ck+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs))+ pretty (SUSUnprotected s ck) =+ pretty "SUSUnprotected" <+> pretty s <+> pretty ck instance A.ToJSON SKAddendum where- toJSON (SUS16bit sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs)- toJSON (SUSSHA1 sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs)+ toJSON (SUSMalleableCFB sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs)+ toJSON (SUSCFB sa s2k iv bs) = A.toJSON (sa, s2k, iv, BL.unpack bs) toJSON (SUSAEAD sa aa s2k iv bs) = A.toJSON (sa, aa, s2k, iv, BL.unpack bs)- toJSON (SUSym sa iv bs) = A.toJSON (sa, iv, BL.unpack bs)- toJSON (SUUnencrypted s ck) = A.toJSON (s, ck)+ toJSON (SUSLegacyCFB sa iv bs) = A.toJSON (sa, iv, BL.unpack bs)+ toJSON (SUSUnprotected s ck) = A.toJSON (s, ck) class LegacyKeyVersion (v :: KeyVersion) @@ -399,21 +426,21 @@ instance LegacyKeyVersion 'V4 data SKAddendumV (v :: KeyVersion) where- SKA16bit+ SKAMalleableCFB :: (LegacyKeyVersion v) => SymmetricAlgorithm -> S2K -> IV -> ByteString -> SKAddendumV v- SKASHA1Legacy+ SKACFBLegacy :: (LegacyKeyVersion v) => SymmetricAlgorithm -> S2K -> IV -> ByteString -> SKAddendumV v- SKASHA1V6+ SKACFBV6 :: SymmetricAlgorithm -> S2K -> IV@@ -434,23 +461,23 @@ -> IV -> ByteString -> SKAddendumV v- SKASymLegacy+ SKALegacyCFBLegacy :: (LegacyKeyVersion v) => SymmetricAlgorithm -> IV -> ByteString -> SKAddendumV v- SKASymV6+ SKALegacyCFBV6 :: SymmetricAlgorithm -> IV -> ByteString -> SKAddendumV 'V6- SKAUnencryptedLegacy+ SKAUnprotectedLegacy :: (LegacyKeyVersion v) => SKey -> Word16 -> SKAddendumV v- SKAUnencryptedV6+ SKAUnprotectedV6 :: SKey -> SKAddendumV 'V6 @@ -462,75 +489,76 @@ deriving instance Show SomeSKAddendumV toSKAddendum :: SKAddendumV v -> SKAddendum-toSKAddendum (SKA16bit sa s2k iv bs) = SUS16bit sa s2k iv bs-toSKAddendum (SKASHA1Legacy sa s2k iv bs) = SUSSHA1 sa s2k iv bs-toSKAddendum (SKASHA1V6 sa s2k iv bs) = SUSSHA1 sa s2k iv bs+toSKAddendum (SKAMalleableCFB sa s2k iv bs) = SUSMalleableCFB sa s2k iv bs+toSKAddendum (SKACFBLegacy sa s2k iv bs) = SUSCFB sa s2k iv bs+toSKAddendum (SKACFBV6 sa s2k iv bs) = SUSCFB sa s2k iv bs toSKAddendum (SKAAEADV6 sa aa s2k iv bs) = SUSAEAD sa aa s2k iv bs toSKAddendum (SKAAEADLegacy sa aa s2k iv bs) = SUSAEAD sa aa s2k iv bs-toSKAddendum (SKASymLegacy sa iv bs) = SUSym sa iv bs-toSKAddendum (SKASymV6 sa iv bs) = SUSym sa iv bs-toSKAddendum (SKAUnencryptedLegacy sk checksum) = SUUnencrypted sk checksum-toSKAddendum (SKAUnencryptedV6 sk) = SUUnencrypted sk 0+toSKAddendum (SKALegacyCFBLegacy sa iv bs) = SUSLegacyCFB sa iv bs+toSKAddendum (SKALegacyCFBV6 sa iv bs) = SUSLegacyCFB sa iv bs+toSKAddendum (SKAUnprotectedLegacy sk checksum) = SUSUnprotected sk checksum+toSKAddendum (SKAUnprotectedV6 sk) = SUSUnprotected sk 0 fromSKAddendumForKeyVersion :: KeyVersion -> SKAddendum -> Either String SomeSKAddendumV-fromSKAddendumForKeyVersion DeprecatedV3 (SUS16bit sa s2k iv bs) =+fromSKAddendumForKeyVersion DeprecatedV3 (SUSMalleableCFB sa s2k iv bs) = Right ( SomeSKAddendumV- (SKA16bit sa s2k iv bs :: SKAddendumV 'DeprecatedV3)+ (SKAMalleableCFB sa s2k iv bs :: SKAddendumV 'DeprecatedV3) )-fromSKAddendumForKeyVersion DeprecatedV3 (SUSSHA1 sa s2k iv bs) =+fromSKAddendumForKeyVersion DeprecatedV3 (SUSCFB sa s2k iv bs) = Right ( SomeSKAddendumV- (SKASHA1Legacy sa s2k iv bs :: SKAddendumV 'DeprecatedV3)+ (SKACFBLegacy sa s2k iv bs :: SKAddendumV 'DeprecatedV3) )-fromSKAddendumForKeyVersion DeprecatedV3 (SUSym sa iv bs) =+fromSKAddendumForKeyVersion DeprecatedV3 (SUSLegacyCFB sa iv bs) = Right ( SomeSKAddendumV- (SKASymLegacy sa iv bs :: SKAddendumV 'DeprecatedV3)+ (SKALegacyCFBLegacy sa iv bs :: SKAddendumV 'DeprecatedV3) )-fromSKAddendumForKeyVersion DeprecatedV3 (SUUnencrypted sk checksum) =+fromSKAddendumForKeyVersion DeprecatedV3 (SUSUnprotected sk checksum) = Right ( SomeSKAddendumV- (SKAUnencryptedLegacy sk checksum :: SKAddendumV 'DeprecatedV3)+ (SKAUnprotectedLegacy sk checksum :: SKAddendumV 'DeprecatedV3) ) fromSKAddendumForKeyVersion DeprecatedV3 (SUSAEAD sa aa s2k iv bs) = Right ( SomeSKAddendumV (SKAAEADLegacy sa aa s2k iv bs :: SKAddendumV 'DeprecatedV3) )-fromSKAddendumForKeyVersion V4 (SUS16bit sa s2k iv bs) =+fromSKAddendumForKeyVersion V4 (SUSMalleableCFB sa s2k iv bs) = Right- (SomeSKAddendumV (SKA16bit sa s2k iv bs :: SKAddendumV 'V4))-fromSKAddendumForKeyVersion V4 (SUSSHA1 sa s2k iv bs) =+ (SomeSKAddendumV (SKAMalleableCFB sa s2k iv bs :: SKAddendumV 'V4))+fromSKAddendumForKeyVersion V4 (SUSCFB sa s2k iv bs) = Right- (SomeSKAddendumV (SKASHA1Legacy sa s2k iv bs :: SKAddendumV 'V4))-fromSKAddendumForKeyVersion V4 (SUSym sa iv bs) =+ (SomeSKAddendumV (SKACFBLegacy sa s2k iv bs :: SKAddendumV 'V4))+fromSKAddendumForKeyVersion V4 (SUSLegacyCFB sa iv bs) = Right- (SomeSKAddendumV (SKASymLegacy sa iv bs :: SKAddendumV 'V4))-fromSKAddendumForKeyVersion V4 (SUUnencrypted sk checksum) =+ (SomeSKAddendumV (SKALegacyCFBLegacy sa iv bs :: SKAddendumV 'V4))+fromSKAddendumForKeyVersion V4 (SUSUnprotected sk checksum) = Right ( SomeSKAddendumV- (SKAUnencryptedLegacy sk checksum :: SKAddendumV 'V4)+ (SKAUnprotectedLegacy sk checksum :: SKAddendumV 'V4) ) fromSKAddendumForKeyVersion V4 (SUSAEAD sa aa s2k iv bs) = Right ( SomeSKAddendumV (SKAAEADLegacy sa aa s2k iv bs :: SKAddendumV 'V4) )-fromSKAddendumForKeyVersion V6 (SUS16bit _ _ _ _) =+fromSKAddendumForKeyVersion V6 (SUSMalleableCFB _ _ _ _) = Left "v6 secret keys must not use 16-bit checksum protected secret key addendums"-fromSKAddendumForKeyVersion V6 (SUSSHA1 sa s2k iv bs) =- Right (SomeSKAddendumV (SKASHA1V6 sa s2k iv bs))+fromSKAddendumForKeyVersion V6 (SUSLegacyCFB _ _ _) =+ Left+ "v6 secret keys must not use legacy CFB (known symmetric cipher algo ID in S2K usage octet)"+fromSKAddendumForKeyVersion V6 (SUSCFB sa s2k iv bs) =+ Right (SomeSKAddendumV (SKACFBV6 sa s2k iv bs)) fromSKAddendumForKeyVersion V6 (SUSAEAD sa aa s2k iv bs) = Right (SomeSKAddendumV (SKAAEADV6 sa aa s2k iv bs))-fromSKAddendumForKeyVersion V6 (SUSym sa iv bs) =- Right (SomeSKAddendumV (SKASymV6 sa iv bs))-fromSKAddendumForKeyVersion V6 (SUUnencrypted sk _) =- Right (SomeSKAddendumV (SKAUnencryptedV6 sk))+fromSKAddendumForKeyVersion V6 (SUSUnprotected sk _) =+ Right (SomeSKAddendumV (SKAUnprotectedV6 sk)) fromSKAddendumForPKPayload :: SomePKPayload
Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs view
@@ -17,6 +17,7 @@ import Control.Error.Util (hush) import Control.Lens (makeLenses)+import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Data (Data)@@ -61,9 +62,9 @@ -> NonEmpty MPI -> PKESK 'PKESKV3 PKESK6Packet- :: BL.ByteString+ :: B.ByteString -> PubKeyAlgorithm- -> BL.ByteString+ -> B.ByteString -> PKESK 'PKESKV6 deriving instance Eq (PKESK v)@@ -229,15 +230,15 @@ SKESK4Packet :: SymmetricAlgorithm -> S2K- -> Maybe BL.ByteString+ -> Maybe B.ByteString -> SKESK 'SKESKV4 SKESK6Packet :: SymmetricAlgorithm -> AEADAlgorithm -> S2K- -> BL.ByteString- -> BL.ByteString- -> BL.ByteString+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString -> SKESK 'SKESKV6 deriving instance Eq (SKESK v)@@ -293,7 +294,7 @@ -> HashAlgorithm -> PubKeyAlgorithm -> SignatureSalt- -> ByteString+ -> Fingerprint -> NestedFlag -> OnePassSignature 'OPSV6 @@ -431,7 +432,7 @@ newtype Marker = Marker- { _markerPayload :: ByteString+ { _markerPayload :: B.ByteString } deriving (Data, Eq, Show, Typeable) @@ -575,7 +576,7 @@ newtype ModificationDetectionCode = ModificationDetectionCode- { _modificationDetectionCodePayload :: ByteString+ { _modificationDetectionCodePayload :: B.ByteString } deriving (Data, Eq, Show, Typeable)
Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs view
@@ -21,6 +21,7 @@ import Data.Aeson (object, (.=)) import qualified Data.Aeson as A import qualified Data.Aeson.Key as AK+import Data.ByteArray.Encoding (Base (..), convertToBase) import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL@@ -63,9 +64,9 @@ data PKESKPayloadV6 = PKESKPayloadV6- BL.ByteString+ B.ByteString PubKeyAlgorithm- BL.ByteString+ B.ByteString deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data PKESKPayload@@ -80,7 +81,7 @@ = SKESKPayloadV4 SymmetricAlgorithm S2K- (Maybe BL.ByteString)+ (Maybe B.ByteString) deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data SKESKPayloadV6@@ -88,9 +89,9 @@ SymmetricAlgorithm AEADAlgorithm S2K- BL.ByteString- BL.ByteString- BL.ByteString+ B.ByteString+ B.ByteString+ B.ByteString deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data SKESKPayload@@ -117,7 +118,7 @@ HashAlgorithm PubKeyAlgorithm SignatureSalt- BL.ByteString+ Fingerprint NestedFlag deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) @@ -220,7 +221,7 @@ | SecretSubkeyPkt SomePKPayload SKAddendum | CompressedDataPkt CompressionAlgorithm CompressedDataPayload | SymEncDataPkt ByteString- | MarkerPkt ByteString+ | MarkerPkt B.ByteString | LiteralDataPkt LiteralDataType FileName@@ -231,7 +232,7 @@ | PublicSubkeyPkt SomePKPayload | UserAttributePkt [UserAttrSubPacket] | SymEncIntegrityProtectedDataPkt SEIPDPayload- | ModificationDetectionCodePkt ByteString+ | ModificationDetectionCodePkt B.ByteString | PaddingPkt ByteString | OtherPacketPkt Word8 ByteString | BrokenPacketPkt String Word8 ByteString@@ -367,7 +368,7 @@ <+> pretty ha <+> pretty pka <+> pretty salt- <+> pretty (bsToHexUpper signerFingerprint)+ <+> pretty signerFingerprint <+> pretty nestedflag pretty (SecretKeyPkt pkp ska) = pretty "secret key:" <+> pretty pkp <+> pretty ska@@ -378,14 +379,14 @@ pretty "compressed-data:" <+> pretty ca <+> prettyLBS cdp pretty (SymEncDataPkt bs) = pretty "symmetrically-encrypted-data:"- <+> pretty (bsToHexUpper bs)+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs)) pretty (MarkerPkt bs) = pretty "marker:" <+> pretty (bsToHexUpper bs) pretty (LiteralDataPkt dt fn ts bs) = pretty "literal-data" <+> pretty dt <+> prettyBS (op FileName fn) <+> pretty ts- <+> pretty (bsToHexUpper bs)+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs)) pretty (TrustPkt bs) = pretty "trust:" <+> pretty (BL.unpack bs) pretty (UserIdPkt u) = pretty "user-ID:" <+> pretty u pretty (PublicSubkeyPkt pkp) = pretty "public subkey:" <+> pretty pkp@@ -394,30 +395,31 @@ pretty "symmetrically-encrypted-integrity-protected-data v" <> pretty pv <> pretty ':'- <+> pretty (bsToHexUpper bs)+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs)) pretty (SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) = pretty "symmetrically-encrypted-integrity-protected-data v2:" <+> pretty sa <+> pretty aa <+> pretty chunkSize <+> pretty salt- <+> pretty (bsToHexUpper bs)+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs)) pretty (ModificationDetectionCodePkt bs) = pretty "MDC:" <+> pretty (bsToHexUpper bs) pretty (PaddingPkt bs) =- pretty "Padding:" <+> pretty (bsToHexUpper bs)+ pretty "Padding:"+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs)) pretty (OtherPacketPkt t bs) = pretty "unknown packet type" <+> pretty t <> pretty ':'- <+> pretty (bsToHexUpper bs)+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs)) pretty (BrokenPacketPkt s t bs) = pretty "BROKEN packet (" <> pretty s <> pretty ')' <+> pretty t <> pretty ':'- <+> pretty (bsToHexUpper bs)+ <+> prettyBS (convertToBase Base64 (BL.toStrict bs)) instance A.ToJSON Pkt where toJSON (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eoki pka mpis))) =@@ -441,9 +443,9 @@ .= object [ AK.fromString "version" .= (6 :: PacketVersion) , AK.fromString "recipient_key_identifier"- .= BL.unpack recipientKeyIdentifier+ .= B.unpack recipientKeyIdentifier , AK.fromString "pkalgo" .= pka- , AK.fromString "esk" .= BL.unpack esk+ , AK.fromString "esk" .= B.unpack esk ] ] toJSON (SignaturePkt sp) = object [AK.fromString "signature" .= sp]@@ -454,7 +456,7 @@ [ AK.fromString "version" .= (4 :: PacketVersion) , AK.fromString "symalgo" .= sa , AK.fromString "s2k" .= s2k- , AK.fromString "data" .= maybe mempty BL.unpack mbs+ , AK.fromString "data" .= maybe mempty B.unpack mbs ] ] toJSON@@ -468,9 +470,9 @@ , AK.fromString "symalgo" .= sa , AK.fromString "aead" .= aa , AK.fromString "s2k" .= s2k- , AK.fromString "iv" .= BL.unpack iv- , AK.fromString "esk" .= BL.unpack esk- , AK.fromString "tag" .= BL.unpack tag+ , AK.fromString "iv" .= B.unpack iv+ , AK.fromString "esk" .= B.unpack esk+ , AK.fromString "tag" .= B.unpack tag ] ] toJSON@@ -502,7 +504,8 @@ , AK.fromString "hashalgo" .= ha , AK.fromString "pkalgo" .= pka , AK.fromString "salt" .= salt- , AK.fromString "fingerprint" .= BL.unpack signerFingerprint+ , AK.fromString "fingerprint"+ .= bsToHexUpper (unFingerprint signerFingerprint) , AK.fromString "nested" .= nestedflag ] ]@@ -528,7 +531,7 @@ ] ] toJSON (SymEncDataPkt bs) = object [AK.fromString "symencdata" .= BL.unpack bs]- toJSON (MarkerPkt bs) = object [AK.fromString "marker" .= BL.unpack bs]+ toJSON (MarkerPkt bs) = object [AK.fromString "marker" .= B.unpack bs] toJSON (LiteralDataPkt dt fn ts bs) = object [ AK.fromString "literaldata"@@ -564,7 +567,7 @@ ] ] toJSON (ModificationDetectionCodePkt bs) =- object [AK.fromString "mdc" .= BL.unpack bs]+ object [AK.fromString "mdc" .= B.unpack bs] toJSON (PaddingPkt bs) = object [AK.fromString "padding" .= BL.unpack bs] toJSON (OtherPacketPkt t bs) =
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -133,7 +133,9 @@ , renderSEIPDv2Failure , seipdv2SymmetricKeySize )-import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey)+import Codec.Encryption.OpenPGP.SecretKey+ ( decryptSecretKeyAddendum+ ) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Compression (conduitDecompress) import Data.Conduit.OpenPGP.Keyring.Instances ()@@ -191,7 +193,7 @@ -> AEADAlgorithm -> EncryptedPayloadFlavor 'SEIPDv2EncryptedPayloadVersion -type InputCallback m = String -> m BL.ByteString+type InputCallback m = String -> m B.ByteString data PKESKRecipientKey = PKESKRecipientKey@@ -270,7 +272,7 @@ -} DecryptWithKeyringAndPassphrase SecretKeyring- (SomePKPayload -> IO (Maybe BL.ByteString))+ (SomePKPayload -> IO (Maybe Passphrase)) | {- | Preferred callback form for non-keyring key material. The callback receives a typed key identifier (8-octet key ID, fingerprint, or wildcard) plus the packet public-key algorithm, then returns all@@ -437,7 +439,7 @@ -- | Build a stateful resolver that looks up keys from a 'SecretKeyring'. buildKeyringResolver :: SecretKeyring- -> Maybe (SomePKPayload -> IO (Maybe BL.ByteString))+ -> Maybe (SomePKPayload -> IO (Maybe Passphrase)) -> IO (PKESKResolver IO) buildKeyringResolver kr maybePassphraseCb = do -- Tracks (last PKESK, remaining wildcard candidates once initialized).@@ -519,14 +521,14 @@ recipientFingerprintMatchVariants :: Fingerprint -> [Fingerprint] recipientFingerprintMatchVariants (Fingerprint rid)- | BL.length rid == 20 =- [Fingerprint rid, Fingerprint (BL.cons 0x04 rid)]- | BL.length rid == 21 && BL.head rid == 0x04 =- [Fingerprint rid, Fingerprint (BL.tail rid)]- | BL.length rid == 32 =- [Fingerprint rid, Fingerprint (BL.cons 0x06 rid)]- | BL.length rid == 33 && BL.head rid == 0x06 =- [Fingerprint rid, Fingerprint (BL.tail rid)]+ | B.length rid == 20 =+ [Fingerprint rid, Fingerprint (B.cons 0x04 rid)]+ | B.length rid == 21 && B.head rid == 0x04 =+ [Fingerprint rid, Fingerprint (B.tail rid)]+ | B.length rid == 32 =+ [Fingerprint rid, Fingerprint (B.cons 0x06 rid)]+ | B.length rid == 33 && B.head rid == 0x06 =+ [Fingerprint rid, Fingerprint (B.tail rid)] | otherwise = [Fingerprint rid] keyringCandidates :: [TK 'SecretTK] -> IO [PKESKRecipientKey]@@ -539,14 +541,14 @@ resolveKeyPair :: KeyPkt 'SecretPkt -> IO (Maybe PKESKRecipientKey)- resolveKeyPair (KeyPktSecretPrimary pkp (SUUnencrypted sk _)) =+ resolveKeyPair (KeyPktSecretPrimary pkp (SUSUnprotected sk _)) = pure $ Just PKESKRecipientKey { pkeskRecipientPKPayload = Just pkp , pkeskRecipientSKey = sk }- resolveKeyPair (KeyPktSecretSubkey pkp (SUUnencrypted sk _)) =+ resolveKeyPair (KeyPktSecretSubkey pkp (SUSUnprotected sk _)) = pure $ Just PKESKRecipientKey@@ -566,16 +568,15 @@ case mPassphrase of Nothing -> pure Nothing Just passphrase ->- case decryptPrivateKey (pkp, ska) passphrase of+ case decryptSecretKeyAddendum pkp ska passphrase of Left _ -> pure Nothing- Right (SUUnencrypted sk _) ->+ Right (sk, _) -> pure $ Just PKESKRecipientKey { pkeskRecipientPKPayload = Just pkp , pkeskRecipientSKey = sk }- Right _ -> pure Nothing buildUnwrapCandidatesResolver :: (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])@@ -642,13 +643,13 @@ | isWildcardV3RecipientKeyId rid = KeyIdentifierWildcard | otherwise = KeyIdentifierEightOctet rid extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)))- | BL.null rid = KeyIdentifierWildcard+ | B.null rid = KeyIdentifierWildcard | otherwise = KeyIdentifierFingerprint (Fingerprint rid) extractProbeKeyIdentifier _ = KeyIdentifierWildcard isWildcardV3RecipientKeyId :: EightOctetKeyId -> Bool isWildcardV3RecipientKeyId (EightOctetKeyId rid) =- BL.length rid == 8 && BL.all (== 0) rid+ B.length rid == 8 && B.all (== 0) rid -- | Extract the public-key algorithm from a PKESK probe packet. extractProbePKA :: Pkt -> PubKeyAlgorithm@@ -855,7 +856,7 @@ Nothing -> fail "MDC with no nonce or cleartext" Just Nothing -> fail "MDC referent is too short" Just (Just x) -> return x- when (expectedMdc /= mdc) $+ when (BL.toStrict expectedMdc /= mdc) $ fail $ "MDC indicates tampering: " ++ show mdc@@ -1373,20 +1374,20 @@ ) resolveSKESKSessionKeyTyped- :: BL.ByteString+ :: Passphrase -> ClassifiedSKESKPayload -> Either SKESKSessionKeyResolutionError B.ByteString-resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k Nothing)) =+resolveSKESKSessionKeyTyped (Passphrase passphrase) (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k Nothing)) = first SKESKSessionKeyS2KError (skesk2Key (SKESK4Packet sa s2k Nothing) passphrase)-resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k (Just esk))) =+resolveSKESKSessionKeyTyped (Passphrase passphrase) (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k (Just esk))) = first SKESKSessionKeyS2KError ( snd <$> skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase )-resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aead s2k iv esk tag)) = do+resolveSKESKSessionKeyTyped (Passphrase passphrase) (ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aead s2k iv esk tag)) = do keyLen <- first (SKESKSessionKeyS2KError . S2KUnsupportedAlgorithm)@@ -1403,9 +1404,9 @@ sa aead kek- (BL.toStrict iv)- (BL.toStrict esk)- (BL.toStrict tag)+ iv+ esk+ tag ) data ClassifiedSKESKPayload where@@ -1445,7 +1446,7 @@ skesks -> do passphrase <- liftIO $ cb "Input the passphrase I want" resolveSKESKCandidates- passphrase+ (Passphrase passphrase) skesks (pkeskCandidates candidates) []@@ -1465,18 +1466,18 @@ resolveSKESKCandidates :: (MonadFail m, MonadIO m)- => BL.ByteString+ => Passphrase -> [SKESKPayload] -> [PKESKPayload] -> [SKESKSessionKeyResolutionError] -> m (SymmetricAlgorithm, SessionKey) resolveSKESKCandidates _ [] pkesks skeskErrs = resolvePKESKCandidates pkesks skeskErrs [] []- resolveSKESKCandidates passphrase (skesk : rest) pkesks skeskErrs =- case resolveSKESKCandidate passphrase skesk of+ resolveSKESKCandidates (Passphrase passphrase) (skesk : rest) pkesks skeskErrs =+ case resolveSKESKCandidate (Passphrase passphrase) skesk of Left err -> resolveSKESKCandidates- passphrase+ (Passphrase passphrase) rest pkesks ( SKESKSessionKeyOtherError@@ -1489,17 +1490,17 @@ pure resolved resolveSKESKCandidate- :: BL.ByteString+ :: Passphrase -> SKESKPayload -> Either SKESKSessionKeyResolutionError (SymmetricAlgorithm, SessionKey)- resolveSKESKCandidate passphrase skesk = do+ resolveSKESKCandidate (Passphrase passphrase) skesk = do let skeskSymAlgo = skeskPayloadSymmetricAlgorithm skesk expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor sessionKeyBytes <- resolveSKESKSessionKeyTyped- passphrase+ (Passphrase passphrase) (classifySKESKPayload skesk) case expectedSymAlgo of Just expected@@ -1537,11 +1538,10 @@ then do let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor encodedSessionKey <-- BL.toStrict- <$> liftIO- ( cb- "Input decrypted PKESK session key material (OpenPGP encoded or raw key bytes)"- )+ liftIO+ ( cb+ "Input decrypted PKESK session key material (OpenPGP encoded or raw key bytes)"+ ) case decodePKESKSessionKey expectedSymAlgo encodedSessionKey of Left manualErr -> fail@@ -1824,13 +1824,13 @@ recipientIdCallbackVariantsV3 rid | isWildcardV3RecipientKeyId rid = [rid]- | otherwise = [rid, EightOctetKeyId (BL.replicate 8 0)]+ | otherwise = [rid, EightOctetKeyId (B.replicate 8 0)] recipientIdCallbackVariants rid- | BL.length rid == 20 = [rid, BL.cons 0x04 rid]- | BL.length rid == 21 && BL.head rid == 0x04 = [rid, BL.tail rid]- | BL.length rid == 32 = [rid, BL.cons 0x06 rid]- | BL.length rid == 33 && BL.head rid == 0x06 = [rid, BL.tail rid]+ | B.length rid == 20 = [rid, B.cons 0x04 rid]+ | B.length rid == 21 && B.head rid == 0x04 = [rid, B.tail rid]+ | B.length rid == 32 = [rid, B.cons 0x06 rid]+ | B.length rid == 33 && B.head rid == 0x06 = [rid, B.tail rid] | otherwise = [rid] isWildcardPKESKPayload (PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _)) =@@ -2033,13 +2033,13 @@ , ClassifiedPKESKRecipientRSA _ privateKey ) | pka == RSA ->- Right (PKESKUnwrapV6RSA privateKey (BL.toStrict esk))+ Right (PKESKUnwrapV6RSA privateKey esk) ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) , ClassifiedPKESKRecipientECDH recipientCtx privateKey ) | pka == ECDH || pka == X25519 -> Right- (PKESKUnwrapV6ECDH recipientCtx pka (BL.toStrict esk) privateKey)+ (PKESKUnwrapV6ECDH recipientCtx pka esk privateKey) ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk) , ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw )@@ -2048,7 +2048,7 @@ ( PKESKUnwrapV6XDHRaw recipientCtx pka- (BL.toStrict esk)+ esk privateKeyRaw ) ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)@@ -2059,7 +2059,7 @@ ( PKESKUnwrapV6XDHRaw recipientCtx pka- (BL.toStrict esk)+ esk privateKeyRaw ) ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis)
hOpenPGP.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP-Version: 3.4+Version: 3.5 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@@ -343,4 +343,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v3.4+ tag: v3.5
tests/Tests/Common.hs view
@@ -26,7 +26,7 @@ , readFixturePayload , reorderPrecedingPKESKs , reverseIf- , runGet -- FIXME: this is confusing+ , runGetTest , selectRecipientKeyInfo , setKeyTimestamp , signCertificationAt@@ -75,11 +75,11 @@ , buildCurve25519LegacyKdfParamForTest , buildECDHKDFParamForTest , cgp- , conduitDecrypt -- FIXME: this is confusing- , conduitDecryptChecked- , conduitDecryptCheckedWithDecryptPolicy- , conduitDecryptWithCandidatesCallbackAndPolicy- , conduitDecryptWithDecryptPolicy+ , testDecrypt -- was conduitDecrypt, renamed to avoid shadowing library export+ , testDecryptChecked+ , testDecryptCheckedWithDecryptPolicy+ , testDecryptWithCandidatesCallbackAndPolicy+ , testDecryptWithDecryptPolicy , deriveECDHKekForTest , doPkeyAndSkeyMatch , forceVersionedRecipientIdentifier@@ -194,7 +194,7 @@ , defaultDecryptPolicy ) import Codec.Encryption.OpenPGP.SecretKey- ( decryptPrivateKey+ ( decryptSecretKeyAddendum ) import Codec.Encryption.OpenPGP.Serialize ( dearmorIfAsciiArmored@@ -205,13 +205,13 @@ ( VerificationError (..) , renderSignError , renderVerificationError- , signCertRevocationWithRSA- , signCertificationWithRSA+ , signCertRevocation , signDataWithEd25519 , signDataWithRSA- , signDirectKeyWithRSA- , signKeyRevocationWithRSA- , signSubkeyRevocationWithRSA+ , signDirectKey+ , signSubkeyBinding+ , signSubkeyRevocation+ , signUserId ) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Compression (conduitDecompress)@@ -276,17 +276,17 @@ assertFailure (file ++ " armor file contained no armor blocks") >> fail "expected armor block" -readPKIPassphrase :: IO BL.ByteString-readPKIPassphrase = readFixtureLazy "pki-password.txt"+readPKIPassphrase :: IO Passphrase+readPKIPassphrase = Passphrase <$> readFixtureStrict "pki-password.txt" -- this needs a better name-runGet :: Get a -> BL.ByteString -> Either String a-runGet g bs = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail g bs)+runGetTest :: Get a -> BL.ByteString -> Either String a+runGetTest g bs = bimap (\(_, _, x) -> x) (\(_, _, x) -> x) (runGetOrFail g bs) extractV4SignatureAlgorithmFields :: BL.ByteString -> Either String (PubKeyAlgorithm, B.ByteString) extractV4SignatureAlgorithmFields =- runGet $ do+ runGetTest $ do version <- getWord8 if version /= 4 then@@ -304,10 +304,10 @@ algorithmFields <- getRemainingLazyByteString pure (toFVal pka, BL.toStrict algorithmFields) -conduitDecrypt- :: (String -> IO BL.ByteString)+testDecrypt+ :: (String -> IO B.ByteString) -> DC.ConduitT Pkt Pkt (ResourceT IO) ()-conduitDecrypt cb =+testDecrypt cb = void $ DCD.conduitDecrypt DecryptOptions@@ -318,7 +318,7 @@ conduitDecryptWithPKESKContext :: (Pkt -> IO (Maybe PKESKRecipientKey))- -> (String -> IO BL.ByteString)+ -> (String -> IO B.ByteString) -> DC.ConduitT Pkt Pkt (ResourceT IO) () conduitDecryptWithPKESKContext pkcb cb = void $@@ -331,12 +331,12 @@ , decryptOptionsPassphraseCallback = cb } -conduitDecryptWithDecryptPolicy+testDecryptWithDecryptPolicy :: DecryptPolicy -> (Pkt -> IO (Maybe PKESKRecipientKey))- -> (String -> IO BL.ByteString)+ -> (String -> IO B.ByteString) -> DC.ConduitT Pkt Pkt (ResourceT IO) ()-conduitDecryptWithDecryptPolicy dp pkcb cb =+testDecryptWithDecryptPolicy dp pkcb cb = void $ DCD.conduitDecrypt DecryptOptions@@ -347,10 +347,10 @@ , decryptOptionsPassphraseCallback = cb } -conduitDecryptChecked- :: (String -> IO BL.ByteString)+testDecryptChecked+ :: (String -> IO B.ByteString) -> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome-conduitDecryptChecked cb =+testDecryptChecked cb = DCD.conduitDecrypt DecryptOptions { decryptOptionsKeyResolution = DecryptWithoutPKESK@@ -358,12 +358,12 @@ , decryptOptionsPassphraseCallback = cb } -conduitDecryptCheckedWithDecryptPolicy+testDecryptCheckedWithDecryptPolicy :: DecryptPolicy -> (Pkt -> IO (Maybe PKESKRecipientKey))- -> (String -> IO BL.ByteString)+ -> (String -> IO B.ByteString) -> DC.ConduitT Pkt Pkt (ResourceT IO) DecryptOutcome-conduitDecryptCheckedWithDecryptPolicy dp pkcb cb =+testDecryptCheckedWithDecryptPolicy dp pkcb cb = DCD.conduitDecrypt DecryptOptions { decryptOptionsKeyResolution =@@ -373,12 +373,12 @@ , decryptOptionsPassphraseCallback = cb } -conduitDecryptWithCandidatesCallbackAndPolicy+testDecryptWithCandidatesCallbackAndPolicy :: DecryptPolicy -> (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])- -> (String -> IO BL.ByteString)+ -> (String -> IO B.ByteString) -> DC.ConduitT Pkt Pkt (ResourceT IO) ()-conduitDecryptWithCandidatesCallbackAndPolicy dp candCb cb =+testDecryptWithCandidatesCallbackAndPolicy dp candCb cb = void $ DCD.conduitDecrypt DecryptOptions@@ -405,7 +405,7 @@ ( PKESKPayloadV3Packet ( PKESKPayloadV3 3- (EightOctetKeyId (BL.replicate 8 0))+ (EightOctetKeyId (B.replicate 8 0)) pka (MPI 0 :| []) )@@ -444,7 +444,7 @@ (SecretKeyPkt pkp ska : _) -> case (_pubkey pkp, ska) of ( RSAPubKey (RSA_PublicKey pub)- , SUUnencrypted (RSAPrivateKey (RSA_PrivateKey prv)) _+ , SUSUnprotected (RSAPrivateKey (RSA_PrivateKey prv)) _ ) -> pure (pub, prv) _ ->@@ -535,7 +535,7 @@ isWildcardEightOctetKeyId :: EightOctetKeyId -> Bool isWildcardEightOctetKeyId (EightOctetKeyId rid) =- BL.length rid == 8 && BL.all (== 0) rid+ B.length rid == 8 && B.all (== 0) rid matchesEightOctetRecipientKeyId :: EightOctetKeyId -> PKESKRecipientKey -> Bool@@ -544,8 +544,8 @@ Nothing -> False Just pkp -> let fingerprintBytes = unFingerprint (fingerprint pkp)- in BL.length fingerprintBytes >= 8- && BL.drop (BL.length fingerprintBytes - 8) fingerprintBytes == rid+ in B.length fingerprintBytes >= 8+ && B.drop (B.length fingerprintBytes - 8) fingerprintBytes == rid supportsPKESKAlgorithm :: PubKeyAlgorithm -> PKESKRecipientKey -> Bool@@ -558,16 +558,15 @@ _ -> False matchesRecipientIdentifier- :: BL.ByteString -> PKESKRecipientKey -> Bool+ :: B.ByteString -> PKESKRecipientKey -> Bool matchesRecipientIdentifier rid keyInfo = case pkeskRecipientPKPayload keyInfo of Nothing -> False Just pkp ->- let fingerprintBytes = BL.toStrict (unFingerprint (fingerprint pkp))- identifier = BL.toStrict rid- in identifier == fingerprintBytes- || identifier == B.cons 0x04 fingerprintBytes- || identifier == B.cons 0x06 fingerprintBytes+ let fingerprintBytes = unFingerprint (fingerprint pkp)+ in rid == fingerprintBytes+ || rid == B.cons 0x04 fingerprintBytes+ || rid == B.cons 0x06 fingerprintBytes buildECDHKDFParamForTest :: SomePKPayload@@ -765,15 +764,22 @@ -> [SigSubPacket] -> IO SignaturePayload signCertificationAt signer signingKey uid creationTime hashedExtras = do+ let signerKeyPkt =+ KeyPktSecretPrimary+ signer+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0) (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime- case signCertificationWithRSA- GenericCert- signer- uid- (hashedExtras ++ hashed)- unhashed- signingKey of+ result <-+ signUserId+ SHA512+ GenericCert+ signerKeyPkt+ uid+ (hashedExtras ++ hashed)+ unhashed+ signingKey+ case result of Left err -> assertFailure ("failed to sign certification: " ++ renderSignError err)@@ -788,14 +794,21 @@ -> [SigSubPacket] -> IO SignaturePayload signCertificationRevocationAt signer signingKey uid creationTime hashedExtras = do+ let signerKeyPkt =+ KeyPktSecretPrimary+ signer+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0) (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime- case signCertRevocationWithRSA- signer- uid- (hashedExtras ++ hashed)- unhashed- signingKey of+ result <-+ signCertRevocation+ SHA512+ signerKeyPkt+ uid+ (hashedExtras ++ hashed)+ unhashed+ signingKey+ case result of Left err -> assertFailure ( "failed to sign certification revocation: "@@ -835,7 +848,7 @@ case secretPackets of (SecretKeyPkt pkp ska : _) -> case ska of- SUUnencrypted (RSAPrivateKey (RSA_PrivateKey privateKey)) _ ->+ SUSUnprotected (RSAPrivateKey (RSA_PrivateKey privateKey)) _ -> pure (pkp, privateKey) _ -> assertFailure@@ -1019,7 +1032,7 @@ [ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _)) , SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _) ] -> do- let ridHex = map toUpper (BLC8.unpack (B16L.encode rid))+ let ridHex = map toUpper (BLC8.unpack (B16L.encode (BL.fromStrict rid))) if ridHex `elem` [ "C8263FC6D676044B6E973959C2F2C2CAE30DE908" , "04C8263FC6D676044B6E973959C2F2C2CAE30DE908"@@ -1053,7 +1066,7 @@ ) loadSEIPDv2FixtureWithV4Secret- :: FilePath -> IO ([Pkt], [Pkt], BL.ByteString)+ :: FilePath -> IO ([Pkt], [Pkt], Passphrase) loadSEIPDv2FixtureWithV4Secret fixture = do messageArmor <- loadFirstArmor fixture encryptedSecretArmor <-@@ -1069,12 +1082,12 @@ forceVersionedRecipientIdentifier pkt = case pkt of PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk))- | BL.length rid == 20 ->+ | B.length rid == 20 -> PKESKPkt- (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x04 rid) pka esk))- | BL.length rid == 32 ->+ (PKESKPayloadV6Packet (PKESKPayloadV6 (B.cons 0x04 rid) pka esk))+ | B.length rid == 32 -> PKESKPkt- (PKESKPayloadV6Packet (PKESKPayloadV6 (BL.cons 0x06 rid) pka esk))+ (PKESKPayloadV6Packet (PKESKPayloadV6 (B.cons 0x06 rid) pka esk)) | otherwise -> pkt _ -> pkt @@ -1102,12 +1115,12 @@ selectRecipientKeyInfoByRawRecipientId _ keyInfos = listToMaybe keyInfos matchesRawRecipientFingerprint- :: BL.ByteString -> PKESKRecipientKey -> Bool+ :: B.ByteString -> PKESKRecipientKey -> Bool matchesRawRecipientFingerprint rid keyInfo = case pkeskRecipientPKPayload keyInfo of Nothing -> False Just pkp ->- BL.toStrict rid == BL.toStrict (unFingerprint (fingerprint pkp))+ rid == unFingerprint (fingerprint pkp) testSEIPDv2TwoRecipientsArmor :: Assertion testSEIPDv2TwoRecipientsArmor =@@ -1152,12 +1165,12 @@ packets ] x25519Esks =- [ BL.toStrict esk+ [ esk | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 esk)) <- packets ] x448Esks =- [ BL.toStrict esk+ [ esk | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 esk)) <- packets ]@@ -1191,7 +1204,7 @@ mapM_ (assertX448EskShape file) x448Esks if all ( \(rid, _) ->- let l = BL.length rid+ let l = B.length rid in l == 20 || l == 21 || l == 32 || l == 33 ) pkesks@@ -1247,7 +1260,7 @@ prependUnusableLatestPKESK :: [Pkt] -> [Pkt] prependUnusableLatestPKESK packets =- let bogusRid = BL.pack (0x06 : replicate 32 0x99)+ let bogusRid = B.pack (0x06 : replicate 32 0x99) bogusPKESK = PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk"))@@ -1430,7 +1443,7 @@ _ -> Left "v6-secret.pgp.aa should begin with a secret key packet" skey <- case ska of- SUUnencrypted x _ -> Right x+ SUSUnprotected x _ -> Right x _ -> Left "v6-secret.pgp.aa should contain unencrypted secret key material"@@ -1438,7 +1451,7 @@ loadV4EncryptedSecretKeyFixtureForProperty :: IO- (Either String (SomePKPayload, SKAddendum, SKey, BL.ByteString))+ (Either String (SomePKPayload, SKAddendum, SKey, Passphrase)) loadV4EncryptedSecretKeyFixtureForProperty = do passphrase <- readPKIPassphrase packets <-@@ -1453,13 +1466,10 @@ _ -> Left "aes256-sha512.seckey should begin with a secret key packet" skey <-- case decryptPrivateKey (pkp, ska) passphrase of- Right (SUUnencrypted x _) -> Right x- Right other ->- Left- ("unexpected decrypted key shape for v4 fixture: " ++ show other)+ case decryptSecretKeyAddendum pkp ska passphrase of+ Right (skey, _) -> Right skey Left err ->- Left ("failed to decrypt v4 fixture secret key: " ++ err)+ Left ("failed to decrypt v4 fixture secret key: " ++ show err) Right (pkp, ska, skey, passphrase) reverseIf :: Bool -> [a] -> [a]@@ -1488,11 +1498,11 @@ {-# NOINLINE secretKeyInfoCacheRef #-} secretKeyInfoCacheRef- :: IORef [(([Pkt], BL.ByteString), [PKESKRecipientKey])]+ :: IORef [(([Pkt], Passphrase), [PKESKRecipientKey])] secretKeyInfoCacheRef = unsafePerformIO (newIORef []) collectSecretKeyInfos- :: [Pkt] -> BL.ByteString -> IO [PKESKRecipientKey]+ :: [Pkt] -> Passphrase -> IO [PKESKRecipientKey] collectSecretKeyInfos pkts passphrase = do cache <- readIORef secretKeyInfoCacheRef case lookup (pkts, passphrase) cache of@@ -1522,7 +1532,7 @@ decryptToRecipientKey contextLabel pkp ska = case ska of- SUUnencrypted skey _ ->+ SUSUnprotected skey _ -> Right ( Just ( PKESKRecipientKey@@ -1532,8 +1542,8 @@ ) ) _ ->- case decryptPrivateKey (pkp, ska) passphrase of- Right (SUUnencrypted skey _) ->+ case decryptSecretKeyAddendum pkp ska passphrase of+ Right (skey, _) -> Right ( Just ( PKESKRecipientKey@@ -1542,21 +1552,13 @@ } ) )- Right decryptedSKA ->- Left- ( contextLabel- ++ " "- ++ show (fingerprint pkp)- ++ ": decryptPrivateKey returned unexpected protection: "- ++ show decryptedSKA- ) Left err -> Left ( contextLabel ++ " " ++ show (fingerprint pkp)- ++ ": decryptPrivateKey failed: "- ++ err+ ++ ": decryptSecretKeyAddendum failed: "+ ++ show err ) signSubkeyRevocationWithRSAAt@@ -1566,14 +1568,25 @@ -> ThirtyTwoBitTimeStamp -> IO SignaturePayload signSubkeyRevocationWithRSAAt signer subkey signingKey creationTime = do+ let signerKeyPkt =+ KeyPktSecretPrimary+ signer+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0)+ subkeyKeyPkt =+ KeyPktSecretPrimary+ subkey+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0) (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime- case signSubkeyRevocationWithRSA- signer- subkey- hashed- unhashed- signingKey of+ result <-+ signSubkeyRevocation+ SHA512+ signerKeyPkt+ subkeyKeyPkt+ hashed+ unhashed+ signingKey+ case result of Left err -> assertFailure ("failed to sign subkey revocation: " ++ renderSignError err)@@ -1601,14 +1614,21 @@ -> [SigSubPacket] -> IO SignaturePayload signDirectKeyWithRSAExtrasAt signer signingKey creationTime hashedExtras = do+ let signerKeyPkt =+ KeyPktSecretPrimary+ signer+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0) (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime- case signDirectKeyWithRSA- DirectKeySignature- signer- (hashedExtras ++ hashed)- unhashed- signingKey of+ result <-+ signDirectKey+ SHA512+ DirectKeySignature+ signerKeyPkt+ (hashedExtras ++ hashed)+ unhashed+ signingKey+ case result of Left err -> assertFailure ( "failed to sign direct key self-signature: "@@ -1625,21 +1645,25 @@ -> [SigSubPacket] -> IO SignaturePayload signSubkeyBindingWithRSAExtrasAt signer subkey signingKey creationTime hashedExtras = do+ let signerKeyPkt =+ KeyPktSecretPrimary+ signer+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0)+ subkeyKeyPkt =+ KeyPktSecretPrimary+ subkey+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0) (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime- let bindingPayload =- payloadForSig- SubkeyBindingSig- emptyPSC- { lastPrimaryKey = PublicKeyPkt signer- , lastSubkey = PublicSubkeyPkt subkey- }- case signDataWithRSA- SubkeyBindingSig- signingKey- (hashedExtras ++ hashed)- unhashed- bindingPayload of+ result <-+ signSubkeyBinding+ SHA512+ signerKeyPkt+ subkeyKeyPkt+ (hashedExtras ++ hashed)+ unhashed+ signingKey+ case result of Left err -> assertFailure ("failed to sign subkey binding: " ++ renderSignError err)@@ -1718,6 +1742,7 @@ , lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText) } case signDataWithEd25519+ SHA512 GenericCert signingKey (hashedExtras ++ hashed)@@ -1746,6 +1771,7 @@ , lastUIDorUAt = UserIdPkt (let UserId uidText = uid in uidText) } case signDataWithEd25519+ SHA512 CertRevocationSig signingKey (hashedExtras ++ hashed)@@ -1781,18 +1807,26 @@ -> [SigSubPacket] -> IO SignaturePayload signKeyRevocationWithReasonAndExtrasAt signer signingKey creationTime reasonCode hashedExtras = do+ let signerKeyPkt =+ KeyPktSecretPrimary+ signer+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0) (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime- case signKeyRevocationWithRSA- signer- ( SigSubPacket- False- (ReasonForRevocation reasonCode (RevocationReason ""))- : hashedExtras- ++ hashed- )- unhashed- signingKey of+ result <-+ signDirectKey+ SHA512+ KeyRevocationSig+ signerKeyPkt+ ( SigSubPacket+ False+ (ReasonForRevocation reasonCode (RevocationReason ""))+ : hashedExtras+ ++ hashed+ )+ unhashed+ signingKey+ case result of Left err -> assertFailure ("failed to sign key revocation: " ++ renderSignError err)@@ -1808,7 +1842,13 @@ signBinaryMessageWithRSAAt signer signingKey creationTime payload = do (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime- case signDataWithRSA BinarySig signingKey hashed unhashed payload of+ case signDataWithRSA+ SHA512+ BinarySig+ signingKey+ hashed+ unhashed+ payload of Left err -> assertFailure ("failed to sign RSA message payload: " ++ renderSignError err)@@ -1824,7 +1864,13 @@ signBinaryMessageWithEd25519At signer signingKey creationTime payload = do (hashed, unhashed) <- messageIssuerSubpacketsAt signer creationTime- case signDataWithEd25519 BinarySig signingKey hashed unhashed payload of+ case signDataWithEd25519+ SHA512+ BinarySig+ signingKey+ hashed+ unhashed+ payload of Left err -> assertFailure ("failed to sign Ed25519 message payload: " ++ renderSignError err)
tests/Tests/Encryption.hs view
@@ -120,7 +120,10 @@ , recipientEncryptionTargetsReportFromTKAtTimestamp , recipientVersionStrategyForProfileTyped )-import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)+import Codec.Encryption.OpenPGP.Fingerprint+ ( fingerprint+ , keyIdFromFingerprint+ ) import Codec.Encryption.OpenPGP.Internal ( checksum16Bytes , point2MBS@@ -134,12 +137,9 @@ , mkClearPayload ) import Codec.Encryption.OpenPGP.Policy- ( OpenPGPPolicy (..)- , OpenPGPRFC (..)- , defaultDecryptPolicy+ ( defaultDecryptPolicy , defaultPolicy , lenientDecryptPolicy- , policyForRFC ) import Codec.Encryption.OpenPGP.S2K ( EncodedSessionKeyError (..)@@ -159,8 +159,9 @@ ( renderSEIPDv2Failure ) import Codec.Encryption.OpenPGP.SecretKey- ( decryptPrivateKey- , encryptPrivateKeyWithPolicyAndSaltAndIV+ ( SecretKeyEncryptOptions (..)+ , decryptSecretKeyAddendum+ , encryptSecretKey ) import Codec.Encryption.OpenPGP.Serialize (parsePkts) import Codec.Encryption.OpenPGP.Types@@ -186,11 +187,6 @@ , buildECDHKDFParamForTest , cgp , collectSecretKeyInfos- , conduitDecrypt- , conduitDecryptChecked- , conduitDecryptCheckedWithDecryptPolicy- , conduitDecryptWithCandidatesCallbackAndPolicy- , conduitDecryptWithDecryptPolicy , conduitDecryptWithPKESKContext , deriveECDHKekForTest , doPkeyAndSkeyMatch@@ -204,12 +200,11 @@ , loadUnencryptedRsaSigner , mkPKESKSessionMaterialOrFail , prependUnusableLatestPKESK- , readFixtureLazy , readFixturePackets , readFixtureStrict , readPKIPassphrase , reorderPrecedingPKESKs- , runGet+ , runGetTest , selectRecipientKeyInfo , selectRecipientKeyInfoByRawRecipientId , setKeyTimestamp@@ -217,6 +212,11 @@ , signDirectKeyWithRSAExtrasAt , signSubkeyBindingWithRSAExtrasAt , signSubkeyRevocationWithRSAAt+ , testDecrypt+ , testDecryptChecked+ , testDecryptCheckedWithDecryptPolicy+ , testDecryptWithCandidatesCallbackAndPolicy+ , testDecryptWithDecryptPolicy , testEncodeOpenPGPSessionMaterial , testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized , testSEIPDv2ForV4KeyArmor@@ -594,32 +594,32 @@ "lenient policy reports DecryptTrailingData for trailing packet after SEIPD v2" testTrailingDataReportedLenientSEIPDv2 , testCase- "conduitDecryptChecked reports DecryptClean for well-formed SEIPD v2"+ "testDecryptChecked reports DecryptClean for well-formed SEIPD v2" testDecryptCleanSEIPDv2 , testCase- "conduitDecrypt matches conduitDecryptChecked (default)"+ "testDecrypt matches testDecryptChecked (default)" testOptionsMatchesCheckedDefaultSEIPDv2 , testCase- "conduitDecrypt matches legacy conduitDecrypt output (default)"+ "testDecrypt matches legacy testDecrypt output (default)" testOptionsMatchesLegacyDefaultOutputSEIPDv2 , testCase- "conduitDecrypt matches checked lenient trailing behavior"+ "testDecrypt matches checked lenient trailing behavior" testOptionsMatchesCheckedLenientTrailingSEIPDv2 ] ) , testGroup "Encrypted secret keys" [ testCase- "SUSSHA1 CAST5 IteratedSalted SHA1 RSA"+ "SUSCFB CAST5 IteratedSalted SHA1 RSA" (testSecretKeyDecryption "simple.seckey" "pki-password.txt") , testCase- "SUS16bit CAST5 IteratedSalted SHA1 RSA"+ "SUSMalleableCFB CAST5 IteratedSalted SHA1 RSA" (testSecretKeyDecryption "16bitcksum.seckey" "pki-password.txt") , testCase- "SUSSHA1 AES256 IteratedSalted SHA512 RSA"+ "SUSCFB AES256 IteratedSalted SHA512 RSA" (testSecretKeyDecryption "aes256-sha512.seckey" "pki-password.txt") , testCase- "SUSSHA1 AES128 IteratedSalted SHA256 ECDSA"+ "SUSCFB AES128 IteratedSalted SHA256 ECDSA" ( testSecretKeyDecryption "nist_p-256_secretkey.gpg" "pki-password.txt"@@ -628,14 +628,11 @@ , testGroup "Encrypting secret keys" [ testCase- "legacy secret key encryption rejects implicit SHA-1 protection"- ( testLegacySecretKeyEncryptionRejected- "unencrypted.seckey"- "pki-password.txt"- )+ "v4 secret key encryption under default policy"+ testV4SecretKeyEncryptionUnderDefaultPolicy , testCase- "SUSym secret key roundtrips"- testSUSymSecretKeyRoundTrip+ "SUSLegacyCFB secret key roundtrips"+ testSUSLegacyCFBSecretKeyRoundTrip , testCase "v6 secret key encryption roundtrips with SUSAEAD" testV6SecretKeyEncryptionRoundTrip@@ -646,76 +643,76 @@ , testGroup "decrypt conduit stuff" [ testCase- "conduitDecrypt supports PKESKv6 with raw session-key callback"+ "testDecrypt supports PKESKv6 with raw session-key callback" testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey , testCase- "conduitDecrypt rejects invalid PKESKv6 raw session-key length"+ "testDecrypt rejects invalid PKESKv6 raw session-key length" testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength , testCase- "conduitDecrypt unwraps PKESK RSA session keys in-library"+ "testDecrypt unwraps PKESK RSA session keys in-library" testConduitDecryptSEIPDv2WithPKESKRSAUnwrap , testCase- "conduitDecrypt probes wildcard callback fallback for PKESKv3 RSA key-id packets"+ "testDecrypt probes wildcard callback fallback for PKESKv3 RSA key-id packets" testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback , testCase- "conduitDecrypt unwraps PKESKv3 RSA session keys via SHA1-CFB protected key loaded from file"+ "testDecrypt unwraps PKESKv3 RSA session keys via SHA1-CFB protected key loaded from file" testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey , testCase "parsed RSA secret key decrypts PKCS#1 v1.5 payload" testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized , testCase- "conduitDecrypt unwraps PKESK ECDH session keys in-library"+ "testDecrypt unwraps PKESK ECDH session keys in-library" testConduitDecryptSEIPDv2WithPKESKECDHUnwrap , testCase- "conduitDecrypt rejects ECDH ephemeral points with wrong curve length"+ "testDecrypt rejects ECDH ephemeral points with wrong curve length" testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength , testCase- "conduitDecrypt unwraps PKESKv3 X25519 session keys in-library"+ "testDecrypt unwraps PKESKv3 X25519 session keys in-library" testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap , testCase- "conduitDecrypt retries wildcard PKESKv3 keys across callback order"+ "testDecrypt retries wildcard PKESKv3 keys across callback order" testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder , testCase- "conduitDecrypt retries wildcard PKESKv3 keys across long callback order"+ "testDecrypt retries wildcard PKESKv3 keys across long callback order" testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder , testCase- "conduitDecrypt retries wildcard PKESKv3 keys across long callback order for SEIPDv1"+ "testDecrypt retries wildcard PKESKv3 keys across long callback order for SEIPDv1" testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder , testCase "unwrap callback decrypts wildcard PKESKv3 via candidates list" testMkCandidateResolverDecryptsWildcardPKESKv3 , testCase- "conduitDecrypt wildcard resolver receives typed previous-failure diagnostics"+ "testDecrypt wildcard resolver receives typed previous-failure diagnostics" testConduitDecryptWildcardResolverProvidesTypedPreviousFailures , testCase- "conduitDecryptWithReport surfaces wildcard resolver diagnostics"+ "testDecryptWithReport surfaces wildcard resolver diagnostics" testConduitDecryptWithReportCapturesWildcardResolverDiagnostics , testCase- "conduitDecrypt rejects PKESKv3 X25519 ephemeral values with wrong length"+ "testDecrypt rejects PKESKv3 X25519 ephemeral values with wrong length" testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength , testCase- "conduitDecrypt falls back from Argon2 SKESK to PKESKv3 X25519"+ "testDecrypt falls back from Argon2 SKESK to PKESKv3 X25519" testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519 , testCase- "conduitDecrypt retries earlier Argon2 SKESKs when latest is unusable"+ "testDecrypt retries earlier Argon2 SKESKs when latest is unusable" testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK , testCase- "conduitDecrypt rejects ECDH KDF/KEK params outside RFC9580 Table 30"+ "testDecrypt rejects ECDH KDF/KEK params outside RFC9580 Table 30" testConduitDecryptSEIPDv2RejectsECDHNonTable30Params , testCase- "conduitDecrypt allows v4 Curve25519Legacy RFC6637 accepted parameters"+ "testDecrypt allows v4 Curve25519Legacy RFC6637 accepted parameters" testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams , testCase- "conduitDecrypt allows v4 Curve25519Legacy with truncated wrapped MPI"+ "testDecrypt allows v4 Curve25519Legacy with truncated wrapped MPI" testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI , testCase- "conduitDecrypt keeps v6 Curve25519Legacy ECDH strict"+ "testDecrypt keeps v6 Curve25519Legacy ECDH strict" testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params , testCase- "conduitDecrypt unwraps PKESK X448 session keys in-library"+ "testDecrypt unwraps PKESK X448 session keys in-library" testConduitDecryptSEIPDv2WithPKESKX448Unwrap , testCase- "conduitDecrypt rejects PKESKv6 X448 ephemeral values with wrong length"+ "testDecrypt rejects PKESKv6 X448 ephemeral values with wrong length" testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength , testCase "encrypt-side session material encoding uses OpenPGP format"@@ -841,22 +838,22 @@ "encrypt-side canonicalize PKESK recipient id helper" testCanonicalizePKESKRecipientIdHelper , testCase- "conduitDecrypt decrypts seipdv2 fixture with matching v6 secret key"+ "testDecrypt decrypts seipdv2 fixture with matching v6 secret key" testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey , testCase "seipdv2-for-v4-key fixture parses as PKESKv6+SEIPDv2" testSEIPDv2ForV4KeyArmor , testCase- "conduitDecrypt decrypts seipdv2-for-v4-key fixture with matching v4 secret key"+ "testDecrypt decrypts seipdv2-for-v4-key fixture with matching v4 secret key" testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey , testCase- "conduitDecrypt tries earlier PKESKs when latest is unusable"+ "testDecrypt tries earlier PKESKs when latest is unusable" testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK , testCase- "conduitDecrypt matches valid recipient-id forms without caller retries"+ "testDecrypt matches valid recipient-id forms without caller retries" testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations , testCase- "conduitDecrypt fails PKESK exhaustion without manual session-key prompt"+ "testDecrypt fails PKESK exhaustion without manual session-key prompt" testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial , testCase "seipdv2-two-recipients fixture parses as PKESKv6*2+SEIPDv2"@@ -865,16 +862,16 @@ "seipdv2-three-recipients fixture parses as PKESKv6*3+SEIPDv2" testSEIPDv2ThreeRecipientsArmor , testCase- "conduitDecrypt decrypts seipdv2-two-recipients fixture with matching v4 secret key"+ "testDecrypt decrypts seipdv2-two-recipients fixture with matching v4 secret key" testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey , testCase- "conduitDecrypt decrypts reordered+bogus seipdv2-two-recipients PKESKs"+ "testDecrypt decrypts reordered+bogus seipdv2-two-recipients PKESKs" testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs , testCase- "conduitDecrypt decrypts seipdv2-three-recipients fixture with matching v4 secret key"+ "testDecrypt decrypts seipdv2-three-recipients fixture with matching v4 secret key" testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey , testCase- "conduitDecrypt decrypts reordered+bogus seipdv2-three-recipients PKESKs"+ "testDecrypt decrypts reordered+bogus seipdv2-three-recipients PKESKs" testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs ] , testGroup@@ -916,7 +913,7 @@ bs <- BL.readFile $ "tests/data/" ++ fpr let firstpass = fmap (concatMap (either (const []) id . decompressPkt) . unBlock)- . runGet get+ . runGetTest get $ bs case firstpass of Left _ -> assertFailure $ "First pass failed on " ++ fpr@@ -926,7 +923,7 @@ let roundtrip = runPut $ put . Block $ [compressPkts ZIP packs] let secondpass = fmap (concatMap (either (const []) id . decompressPkt) . unBlock)- . runGet get+ . runGetTest get $ roundtrip if secondpass == Right [] then@@ -982,7 +979,7 @@ testSymmetricEncryption :: FilePath -> FilePath -> BL.ByteString -> Assertion testSymmetricEncryption encfile passfile cleartext = do- passphrase <- readFixtureLazy passfile+ passphrase <- readFixtureStrict passfile pt <- readFixturePackets encfile assertEqual "wrong number of packets" 2 (length pt) skesk <-@@ -1015,7 +1012,7 @@ catch ( DC.runConduitRes $ CL.sourceList pt- DC..| conduitDecrypt (fakeCallback passphrase)+ DC..| testDecrypt (fakeCallback passphrase) DC..| CL.consume ) ( \e -> do@@ -1036,7 +1033,7 @@ Right x -> pure (_literalDataPayload x) assertEqual ("cleartext for " ++ encfile) cleartext payload where- fakeCallback :: BL.ByteString -> String -> IO BL.ByteString+ fakeCallback :: B.ByteString -> String -> IO B.ByteString fakeCallback = const . return testSEIPDv1ResyncNonceMdcRoundTrip :: Assertion@@ -1097,7 +1094,7 @@ testLegacySymmetricEncryption :: Bool -> FilePath -> FilePath -> BL.ByteString -> Assertion testLegacySymmetricEncryption expectSEIPDv1 encfile passfile cleartext = do- passphrase <- readFixtureLazy passfile+ passphrase <- readFixtureStrict passfile pt <- readFixturePackets encfile assertEqual "wrong number of packets" 2 (length pt) skesk <-@@ -1135,7 +1132,7 @@ catch ( DC.runConduitRes $ CL.sourceList pt- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) (fakeCallback passphrase)@@ -1159,7 +1156,7 @@ Right x -> pure (_literalDataPayload x) assertEqual ("cleartext for " ++ encfile) cleartext payload where- fakeCallback :: BL.ByteString -> String -> IO BL.ByteString+ fakeCallback :: B.ByteString -> String -> IO B.ByteString fakeCallback = const . return {- | Assert that decrypting with the strict 'defaultDecryptPolicy' throws an@@ -1168,13 +1165,13 @@ testStrictPolicyRejectsEncryption :: FilePath -> FilePath -> String -> Assertion testStrictPolicyRejectsEncryption encfile passfile expectedFragment = do- passphrase <- readFixtureLazy passfile+ passphrase <- readFixtureStrict passfile pt <- readFixturePackets encfile result <- try ( DC.runConduitRes $ CL.sourceList pt- DC..| conduitDecrypt (fakeCallback passphrase)+ DC..| testDecrypt (fakeCallback passphrase) DC..| CL.consume ) :: IO (Either SomeException [Pkt])@@ -1195,14 +1192,14 @@ ) (expectedFragment `isInfixOf` show err) where- fakeCallback :: BL.ByteString -> String -> IO BL.ByteString+ fakeCallback :: B.ByteString -> String -> IO B.ByteString fakeCallback = const . return encryptedSEIPDv2Packets :: IO [Pkt] encryptedSEIPDv2Packets = do let passphrase = Passphrase- (BL.pack (map (fromIntegral . fromEnum) ("test" :: String)))+ (B.pack (map (fromIntegral . fromEnum) ("test" :: String))) payload = mkClearPayload (BL.pack (map (fromIntegral . fromEnum) ("hello" :: String)))@@ -1223,7 +1220,7 @@ DC..| conduitGet get DC..| CL.consume -defaultOptionsForPassphrase :: BL.ByteString -> DecryptOptions+defaultOptionsForPassphrase :: B.ByteString -> DecryptOptions defaultOptionsForPassphrase passphrase = DecryptOptions { decryptOptionsKeyResolution = DecryptWithoutPKESK@@ -1234,13 +1231,13 @@ testDecryptCleanSEIPDv2 :: Assertion testDecryptCleanSEIPDv2 = do pt <- encryptedSEIPDv2Packets- let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))+ let passphrase = B.pack (map (fromIntegral . fromEnum) ("test" :: String)) cb = const (pure passphrase) (outcome, _) <- catch ( DC.runConduitRes $ CL.sourceList pt- DC..| fuseBoth (conduitDecryptChecked cb) CL.consume+ DC..| fuseBoth (testDecryptChecked cb) CL.consume ) ( \e -> assertFailure@@ -1255,13 +1252,13 @@ testOptionsMatchesCheckedDefaultSEIPDv2 :: Assertion testOptionsMatchesCheckedDefaultSEIPDv2 = do pt <- encryptedSEIPDv2Packets- let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))+ let passphrase = B.pack (map (fromIntegral . fromEnum) ("test" :: String)) cb = const (pure passphrase) opts = defaultOptionsForPassphrase passphrase checkedResult <- DC.runConduitRes $ CL.sourceList pt- DC..| fuseBoth (conduitDecryptChecked cb) CL.consume+ DC..| fuseBoth (testDecryptChecked cb) CL.consume optionsResult <- DC.runConduitRes $ CL.sourceList pt@@ -1274,12 +1271,12 @@ testOptionsMatchesLegacyDefaultOutputSEIPDv2 :: Assertion testOptionsMatchesLegacyDefaultOutputSEIPDv2 = do pt <- encryptedSEIPDv2Packets- let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))+ let passphrase = B.pack (map (fromIntegral . fromEnum) ("test" :: String)) cb = const (pure passphrase) opts = defaultOptionsForPassphrase passphrase legacyOutput <- DC.runConduitRes $- CL.sourceList pt DC..| conduitDecrypt cb DC..| CL.consume+ CL.sourceList pt DC..| testDecrypt cb DC..| CL.consume (optionsOutcome, optionsOutput) <- DC.runConduitRes $ CL.sourceList pt@@ -1297,13 +1294,13 @@ testTrailingDataRejectedStrictSEIPDv2 = do pt <- encryptedSEIPDv2Packets let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""]- passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))+ passphrase = B.pack (map (fromIntegral . fromEnum) ("test" :: String)) cb = const (pure passphrase) result <- try ( DC.runConduitRes $ CL.sourceList ptWithTrailing- DC..| fuseBoth (conduitDecryptChecked cb) CL.consume+ DC..| fuseBoth (testDecryptChecked cb) CL.consume ) :: IO (Either SomeException (DecryptOutcome, [Pkt])) case result of@@ -1324,14 +1321,14 @@ testTrailingDataReportedLenientSEIPDv2 = do pt <- encryptedSEIPDv2Packets let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""]- passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))+ passphrase = B.pack (map (fromIntegral . fromEnum) ("test" :: String)) cb = const (pure passphrase) (outcome, _) <- catch ( DC.runConduitRes $ CL.sourceList ptWithTrailing DC..| fuseBoth- ( conduitDecryptCheckedWithDecryptPolicy+ ( testDecryptCheckedWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) cb@@ -1352,7 +1349,7 @@ testOptionsMatchesCheckedLenientTrailingSEIPDv2 = do pt <- encryptedSEIPDv2Packets let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""]- passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))+ passphrase = B.pack (map (fromIntegral . fromEnum) ("test" :: String)) cb = const (pure passphrase) opts = DecryptOptions@@ -1364,7 +1361,7 @@ DC.runConduitRes $ CL.sourceList ptWithTrailing DC..| fuseBoth- ( conduitDecryptCheckedWithDecryptPolicy+ ( testDecryptCheckedWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) cb@@ -1393,13 +1390,13 @@ (ThirtyTwoBitTimeStamp 0) "not-encrypted" ]- passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))+ passphrase = B.pack (map (fromIntegral . fromEnum) ("test" :: String)) cb = const (pure passphrase) result <- try ( DC.runConduitRes $ CL.sourceList malformed- DC..| fuseBoth (conduitDecryptChecked cb) CL.consume+ DC..| fuseBoth (testDecryptChecked cb) CL.consume ) :: IO (Either SomeException (DecryptOutcome, [Pkt])) case result of@@ -1425,13 +1422,13 @@ SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) : rest _ -> pt- passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))+ passphrase = B.pack (map (fromIntegral . fromEnum) ("test" :: String)) cb = const (pure passphrase) result <- try ( DC.runConduitRes $ CL.sourceList malformed- DC..| fuseBoth (conduitDecryptChecked cb) CL.consume+ DC..| fuseBoth (testDecryptChecked cb) CL.consume ) :: IO (Either SomeException (DecryptOutcome, [Pkt])) case result of@@ -1461,13 +1458,13 @@ (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) : rest _ -> pt- passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))+ passphrase = B.pack (map (fromIntegral . fromEnum) ("test" :: String)) cb = const (pure passphrase) (outcome, _) <- catch ( DC.runConduitRes $ CL.sourceList withMixedPrelude- DC..| fuseBoth (conduitDecryptChecked cb) CL.consume+ DC..| fuseBoth (testDecryptChecked cb) CL.consume ) ( \e -> assertFailure@@ -1481,7 +1478,7 @@ testSecretKeyDecryption :: FilePath -> FilePath -> Assertion testSecretKeyDecryption keyfile passfile = do- passphrase <- readFixtureLazy passfile+ passphrase <- readFixtureStrict passfile kr <- DC.runConduitRes $ CB.sourceFile (fixturePath keyfile)@@ -1500,58 +1497,80 @@ ("failed to coerce key packet to SecretKey: " ++ err) >> fail err Right x -> pure x- decrypted <-- case decryptPrivateKey (pkp, ska) passphrase of+ decryptedSKey <-+ case decryptSecretKeyAddendum pkp ska (Passphrase passphrase) of Left err ->- assertFailure ("secret key decryption failed: " ++ err)+ assertFailure ("secret key decryption failed: " ++ show err) >> fail "secret key decryption failed"- Right x -> pure x- case decrypted of- SUUnencrypted skey _ -> doPkeyAndSkeyMatch (_pubkey pkp) skey- other ->- assertFailure- ( "secret key decryption should produce an unencrypted secret key, got: "- ++ show other- )+ Right (decryptedSKey, _) -> pure decryptedSKey+ doPkeyAndSkeyMatch (_pubkey pkp) decryptedSKey -testLegacySecretKeyEncryptionRejected- :: FilePath -> FilePath -> Assertion-testLegacySecretKeyEncryptionRejected keyfile passfile = do- passphrase <- readFixtureLazy passfile- kr <-- DC.runConduitRes $- CB.sourceFile (fixturePath keyfile)- DC..| conduitGet get- DC..| CL.consume- SecretKey pkp ska <-- case kr of- [] ->- assertFailure- ("no packets found in secret key fixture " ++ keyfile)- >> fail "empty secret key fixture"- (firstPkt : _) ->- case (fromPktEither firstPkt :: Either String SecretKey) of- Left err ->- assertFailure- ("failed to coerce key packet to SecretKey: " ++ err)- >> fail err- Right x -> pure x- case encryptPrivateKeyWithPolicyAndSaltAndIV- defaultPolicy- pkp- (Salt "\226~\197\a\202#\"G")- (IV "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t")- ska- passphrase of- Left err | "explicit legacy override required" `isInfixOf` err -> pure ()+testV4SecretKeyEncryptionUnderDefaultPolicy :: Assertion+testV4SecretKeyEncryptionUnderDefaultPolicy = do+ (pkp, privateKey) <- loadUnencryptedRsaSigner+ let skey = RSAPrivateKey (RSA_PrivateKey privateKey)+ passphrase =+ Passphrase+ ( B.pack+ ( map+ (fromIntegral . fromEnum)+ ("default-policy-v4-passphrase" :: String)+ )+ )+ salt = Salt (B.pack [0x00 .. 0x07])+ iv = IV (B.pack [0x10 .. 0x1e])+ encryptResult <-+ encryptSecretKey+ pkp+ skey+ passphrase+ ( SecretKeyEncryptOptions+ { skeoPolicy = defaultPolicy+ , skeoGenerateSaltAndIV = False+ , skeoSalt = Just salt+ , skeoIV = Just iv+ }+ )+ encrypted <- case encryptResult of Left err -> assertFailure- ( "legacy secret key encryption should be rejected with a policy error, got: "- ++ err+ ( "v4 secret key encryption under default policy failed: "+ ++ show err )- Right _ ->+ >> fail "v4 secret key encryption under default policy failed"+ Right x -> pure x+ case encrypted of+ SUSAEAD _sa _aa _s2k _ encryptedPayload -> do+ assertBool+ "v4 secret key encryption under default policy should emit encrypted payload"+ (not (BL.null encryptedPayload))+ SUSCFB _ _ _ encryptedPayload -> do+ assertBool+ "v4 secret key encryption under default policy should emit encrypted payload"+ (not (BL.null encryptedPayload))+ _ -> assertFailure- "legacy secret key encryption should reject implicit SHA-1 protection"+ "v4 secret key encryption under default policy should emit SUSAEAD or SUSCFB"+ let serialized = runPut (put (toPkt (SecretKey pkp encrypted)))+ reparsed = parsePkts serialized+ (parsedPKP, parsedSKA) <-+ case reparsed of+ (SecretKeyPkt pkpayload skaddendum : _) -> pure (pkpayload, skaddendum)+ _ ->+ assertFailure+ "re-serialized v4 secret key should parse back as a secret key packet"+ >> fail "expected serialized secret key packet"+ decryptedSKey <-+ case decryptSecretKeyAddendum parsedPKP parsedSKA passphrase of+ Left err ->+ assertFailure+ ("v4 secret key roundtrip decryption failed: " ++ show err)+ >> fail "v4 secret key roundtrip decryption failed"+ Right (decryptedSKey, _) -> pure decryptedSKey+ assertEqual+ "v4 secret key roundtrip should preserve secret key material"+ skey+ decryptedSKey testV6SecretKeyEncryptionRoundTrip :: Assertion testV6SecretKeyEncryptionRoundTrip = do@@ -1577,23 +1596,28 @@ >> fail "expected secret key packet" originalSKey <- case ska of- SUUnencrypted skey _ -> pure skey+ SUSUnprotected skey _ -> pure skey _ -> assertFailure "v6-secret.pgp.aa should contain unencrypted secret key material" >> fail "expected unencrypted secret key"- changed <-- case encryptPrivateKeyWithPolicyAndSaltAndIV- defaultPolicy+ encryptResult <-+ encryptSecretKey pkp- (Salt "1234567890ABCDEF")- (IV "1234567890ABCDE")- ska- passphrase of- Left err ->- assertFailure ("v6 secret key encryption failed: " ++ err)- >> fail "v6 secret key encryption failed"- Right x -> pure x+ originalSKey+ passphrase+ ( SecretKeyEncryptOptions+ { skeoPolicy = defaultPolicy+ , skeoGenerateSaltAndIV = False+ , skeoSalt = Just (Salt "1234567890ABCDEF")+ , skeoIV = Just (IV "1234567890ABCDE")+ }+ )+ changed <- case encryptResult of+ Left err ->+ assertFailure ("v6 secret key encryption failed: " ++ show err)+ >> fail "v6 secret key encryption failed"+ Right x -> pure x case changed of SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do assertEqual@@ -1623,67 +1647,67 @@ assertFailure "re-serialized v6 secret key should parse back as a secret key packet" >> fail "expected serialized secret key packet"- decrypted <-- case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of+ decryptedSKey <-+ case decryptSecretKeyAddendum parsedPKP parsedSKA passphrase of Left err -> assertFailure- ("v6 secret key roundtrip decryption failed: " ++ err)+ ("v6 secret key roundtrip decryption failed: " ++ show err) >> fail "v6 secret key roundtrip decryption failed"- Right x -> pure x- case decrypted of- SUUnencrypted skey _ ->- assertEqual- "v6 secret key roundtrip should preserve secret key material"- originalSKey- skey- _ ->- assertFailure- "v6 secret key roundtrip should decrypt to unencrypted secret material"+ Right (decryptedSKey, _) -> pure decryptedSKey+ assertEqual+ "v6 secret key roundtrip should preserve secret key material"+ originalSKey+ decryptedSKey testV4SecretKeyAEADOCBRoundTripCompat :: Assertion testV4SecretKeyAEADOCBRoundTripCompat = do (pkp, privateKey) <- loadUnencryptedRsaSigner let skey = RSAPrivateKey (RSA_PrivateKey privateKey)- passphrase = "legacy-aead-passphrase"- compatPolicy =- (policyForRFC RFC4880)- { policySecretKeyProtection =- policySecretKeyProtection defaultPolicy- }- salt = Salt (B.pack [0x00 .. 0x0f])+ passphrase =+ Passphrase+ ( B.pack+ ( map+ (fromIntegral . fromEnum)+ ("legacy-aead-passphrase" :: String)+ )+ )+ salt = Salt (B.pack [0x00 .. 0x07]) iv = IV (B.pack [0x10 .. 0x1e])- encrypted <-- case encryptPrivateKeyWithPolicyAndSaltAndIV- compatPolicy+ encryptResult <-+ encryptSecretKey pkp- salt- iv- (SUUnencrypted skey 0)- passphrase of- Left err ->- assertFailure ("v4 AEAD secret key encryption failed: " ++ err)- >> fail "v4 AEAD secret key encryption failed"- Right x -> pure x+ skey+ passphrase+ ( SecretKeyEncryptOptions+ { skeoPolicy = defaultPolicy+ , skeoGenerateSaltAndIV = False+ , skeoSalt = Just salt+ , skeoIV = Just iv+ }+ )+ encrypted <- case encryptResult of+ Left err ->+ assertFailure+ ("v4 AEAD secret key encryption failed: " ++ show err)+ >> fail "v4 AEAD secret key encryption failed"+ Right x -> pure x case encrypted of- SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do- assertEqual- "v4 AEAD secret key encryption should use expected Argon2 t"- 1- t- assertEqual- "v4 AEAD secret key encryption should use expected Argon2 p"- 4- p- assertEqual- "v4 AEAD secret key encryption should use expected Argon2 encoded-memory"- 15- em- assertBool- "v4 AEAD secret key encryption should emit encrypted payload"- (not (BL.null encryptedPayload))+ SUSAEAD+ AES256+ OCB+ (IteratedSalted SHA512 _ iter)+ _+ encryptedPayload -> do+ assertEqual+ "v4 AEAD secret key encryption should use expected IteratedSalted SHA512 iteration count"+ 1024+ iter+ assertBool+ "v4 AEAD secret key encryption should emit encrypted payload"+ (not (BL.null encryptedPayload)) _ -> assertFailure- "v4 secret key encryption should emit SUSAEAD/AES256/OCB with Argon2 S2K"+ "v4 secret key encryption should emit SUSAEAD/AES256/OCB with IteratedSalted SHA512 S2K" let serialized = runPut (put (toPkt (SecretKey pkp encrypted))) reparsed = parsePkts serialized (parsedPKP, parsedSKA) <-@@ -1693,25 +1717,20 @@ assertFailure "re-serialized v4 AEAD secret key should parse back as a secret key packet" >> fail "expected serialized secret key packet"- decrypted <-- case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of+ parsedSKey <-+ case decryptSecretKeyAddendum parsedPKP parsedSKA passphrase of Left err -> assertFailure- ("v4 AEAD secret key roundtrip decryption failed: " ++ err)+ ("v4 AEAD secret key roundtrip decryption failed: " ++ show err) >> fail "v4 AEAD secret key roundtrip decryption failed"- Right x -> pure x- case decrypted of- SUUnencrypted skey' _ ->- assertEqual- "v4 AEAD secret key roundtrip should preserve secret key material"- skey- skey'- _ ->- assertFailure- "v4 AEAD secret key roundtrip should decrypt to unencrypted secret material"+ Right (parsedSKey, _) -> pure parsedSKey+ assertEqual+ "v4 AEAD secret key roundtrip should preserve secret key material"+ skey+ parsedSKey -testSUSymSecretKeyRoundTrip :: Assertion-testSUSymSecretKeyRoundTrip = do+testSUSLegacyCFBSecretKeyRoundTrip :: Assertion+testSUSLegacyCFBSecretKeyRoundTrip = do passphrase <- readPKIPassphrase packets <- DC.runConduitRes $@@ -1720,7 +1739,7 @@ DC..| CL.consume (pkp, skey) <- case packets of- (SecretKeyPkt pkpayload (SUUnencrypted sk _) : _) -> pure (pkpayload, sk)+ (SecretKeyPkt pkpayload (SUSUnprotected sk _) : _) -> pure (pkpayload, sk) _ -> assertFailure "unencrypted.seckey did not begin with an unencrypted secret key packet"@@ -1732,11 +1751,13 @@ iv = IV (B.pack [0 .. 15]) sa = AES128 keyMaterial <-- case string2Key (Simple DeprecatedMD5) 16 passphrase of+ case string2Key (Simple DeprecatedMD5) 16 (unPassphrase passphrase) of Left err -> assertFailure- ("failed to derive SUSym key material: " ++ renderS2KError err)- >> fail "failed to derive SUSym key material"+ ( "failed to derive SUSLegacyCFB key material: "+ ++ renderS2KError err+ )+ >> fail "failed to derive SUSLegacyCFB key material" Right km -> pure km encrypted <- case encryptNoNonce@@ -1747,10 +1768,10 @@ keyMaterial of Left err -> assertFailure- ("failed to encrypt legacy SUSym secret key: " ++ show err)- >> fail "failed to encrypt legacy SUSym secret key"+ ("failed to encrypt legacy SUSLegacyCFB secret key: " ++ show err)+ >> fail "failed to encrypt legacy SUSLegacyCFB secret key" Right bs -> pure bs- let legacySka = SUSym sa iv (BL.fromStrict encrypted)+ let legacySka = SUSLegacyCFB sa iv (BL.fromStrict encrypted) serialized = runPut (put (toPkt (SecretKey pkp legacySka))) reparsed = parsePkts serialized (parsedPKP, parsedSKA) <-@@ -1758,23 +1779,19 @@ (SecretKeyPkt pkpayload skaddendum : _) -> pure (pkpayload, skaddendum) _ -> assertFailure- "serialized SUSym secret key should parse back as a secret key packet"+ "serialized SUSLegacyCFB secret key should parse back as a secret key packet" >> fail "expected serialized secret key packet"- decrypted <-- case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of+ parsedSKey <-+ case decryptSecretKeyAddendum parsedPKP parsedSKA passphrase of Left err ->- assertFailure ("SUSym secret key decryption failed: " ++ err)- >> fail "SUSym secret key decryption failed"- Right x -> pure x- case decrypted of- SUUnencrypted parsedSKey _ ->- assertEqual- "SUSym secret key roundtrip should preserve secret key material"- skey- parsedSKey- _ ->- assertFailure- "SUSym secret key roundtrip should decrypt to unencrypted secret material"+ assertFailure+ ("SUSLegacyCFB secret key decryption failed: " ++ show err)+ >> fail "SUSLegacyCFB secret key decryption failed"+ Right (parsedSKey, _) -> pure parsedSKey+ assertEqual+ "SUSLegacyCFB secret key roundtrip should preserve secret key material"+ skey+ parsedSKey legacyRsaSecretKeyBytes :: SKey -> B.ByteString legacyRsaSecretKeyBytes (RSAPrivateKey (RSA_PrivateKey (RSA.PrivateKey _ d p q _ _ _))) =@@ -1834,7 +1851,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -1855,7 +1872,7 @@ Right p -> pure p case pkeskPayload of PKESKPayloadV6Packet (PKESKPayloadV6 _ RSA eskBytesLazy) -> do- let eskBytes = BL.toStrict eskBytesLazy+ let eskBytes = eskBytesLazy assertBool "PKESKv6 RSA ESK should include MPI framing" (B.length eskBytes >= 2)@@ -1919,7 +1936,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyCallback _ = pure (Just (RSAPrivateKey (RSA_PrivateKey privateKey))) keyContextCallback pkt = do msk <- keyCallback pkt@@ -1967,7 +1984,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -1987,9 +2004,15 @@ (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner let recipient = setKeyVersion V6 baseRecipient sessionKey = SessionKey (B.replicate 32 0x11)- let expectedKeyId =- EightOctetKeyId- (BL.take 8 (unFingerprint (fingerprint recipient)))+ expectedKeyId <-+ case keyIdFromFingerprint (fingerprint recipient) of+ Left err ->+ assertFailure+ ( "Expected v6 key-id from fingerprint derivation to succeed: "+ ++ err+ )+ >> fail "expected v6 key-id from fingerprint"+ Right keyId -> pure keyId sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey result <- buildPKESKv3PayloadForRecipient@@ -2038,7 +2061,7 @@ payload ] recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv)- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -2084,7 +2107,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -2158,7 +2181,7 @@ ( PKESKPayloadV3Packet ( PKESKPayloadV3 3- (EightOctetKeyId (BL.replicate 8 0))+ (EightOctetKeyId (B.replicate 8 0)) ECDH (ephMPI NE.:| [wrappedMPI]) )@@ -2255,7 +2278,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -2314,7 +2337,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -2398,7 +2421,7 @@ ) Right (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 eskBytesLazy)) -> do- let eskBytes = BL.toStrict eskBytesLazy+ let eskBytes = eskBytesLazy assertX25519EskShape "v6 X25519 raw-key conformance" eskBytes let wrappedLen = fromIntegral (B.index eskBytes 32) :: Int assertEqual@@ -2446,7 +2469,7 @@ assertFailure ("buildPKESKPayloadForRecipient failed for v6 X448: " ++ show err) Right (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 eskBytesLazy)) -> do- let eskBytes = BL.toStrict eskBytesLazy+ let eskBytes = eskBytesLazy assertX448EskShape "v6 X448 raw-key conformance" eskBytes let wrappedLen = fromIntegral (B.index eskBytes 56) :: Int assertEqual@@ -3594,7 +3617,7 @@ [] [ SigSubPacket False- (Issuer (EightOctetKeyId (BL.pack [0x01 .. 0x08])))+ (Issuer (EightOctetKeyId (B.pack [0x01 .. 0x08]))) ] 0 (MPI 1 :| [])@@ -3627,7 +3650,7 @@ } ) )- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty result <- encryptForRecipients request packets <- case result of@@ -3734,7 +3757,7 @@ } ) )- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty result <- encryptForRecipients request packets <- case result of@@ -3774,15 +3797,15 @@ testCanonicalizePKESKRecipientIdHelper :: Assertion testCanonicalizePKESKRecipientIdHelper = do- let rid = BL.pack (0x04 : replicate 20 0x11)+ let rid = B.pack (0x04 : replicate 20 0x11) payload = PKESKPayloadV6Packet (PKESKPayloadV6 rid RSA "esk") case canonicalizePKESKRecipientId payload of Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _))- | BL.length normalized == 20 -> pure ()+ | B.length normalized == 20 -> pure () | otherwise -> assertFailure ( "Expected canonicalized recipient id length 20, got "- ++ show (BL.length normalized)+ ++ show (B.length normalized) ) Left err -> assertFailure@@ -3794,7 +3817,7 @@ ) case canonicalizePKESKRecipientId ( PKESKPayloadV6Packet- (PKESKPayloadV6 (BL.replicate 19 0x22) RSA "esk")+ (PKESKPayloadV6 (B.replicate 19 0x22) RSA "esk") ) of Left (InvalidRecipientIdentifier _) -> pure () other ->@@ -3804,14 +3827,14 @@ ) case canonicalizePKESKRecipientId ( PKESKPayloadV6Packet- (PKESKPayloadV6 (BL.pack (0x06 : replicate 32 0x33)) RSA "esk")+ (PKESKPayloadV6 (B.pack (0x06 : replicate 32 0x33)) RSA "esk") ) of Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _))- | BL.length normalized == 32 -> pure ()+ | B.length normalized == 32 -> pure () | otherwise -> assertFailure ( "Expected canonicalized v6 recipient id length 32, got "- ++ show (BL.length normalized)+ ++ show (B.length normalized) ) other -> assertFailure@@ -3820,7 +3843,7 @@ ) case canonicalizePKESKRecipientId ( PKESKPayloadV6Packet- (PKESKPayloadV6 (BL.pack (0x04 : replicate 32 0x44)) RSA "esk")+ (PKESKPayloadV6 (B.pack (0x04 : replicate 32 0x44)) RSA "esk") ) of Left (InvalidRecipientIdentifier _) -> pure () other ->@@ -3937,7 +3960,7 @@ let messagePackets = parsePkts messageBody encryptedSecretPackets = parsePkts encryptedSecretBody plainSecretPackets = parsePkts plainSecretBody- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty allKeyInfos <- collectSecretKeyInfos (encryptedSecretPackets ++ plainSecretPackets)@@ -3982,7 +4005,7 @@ (messagePackets, encryptedSecretPackets, passphrase) <- loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" let- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos)@@ -4014,13 +4037,13 @@ (messagePackets, encryptedSecretPackets, passphrase) <- loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" let- bogusRid = BL.pack (0x06 : replicate 32 0x99)+ bogusRid = B.pack (0x06 : replicate 32 0x99) bogusPKESK = PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk")) (eskPrefix, encryptedSuffix) = span isPrecedingESK messagePackets packetsWithBogusLatestPKESK = eskPrefix ++ [bogusPKESK] ++ encryptedSuffix- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos)@@ -4052,7 +4075,7 @@ (messagePacketsRaw, encryptedSecretPackets, passphrase) <- loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" let messagePackets = map forceVersionedRecipientIdentifier messagePacketsRaw- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase let keyContextCallback pkt = pure (selectRecipientKeyInfoByRawRecipientId pkt keyInfos)@@ -4157,7 +4180,7 @@ (messagePacketsRaw, encryptedSecretPackets, passphrase) <- loadSEIPDv2FixtureWithV4Secret fixture let messagePackets = transformPackets messagePacketsRaw- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos)@@ -4208,7 +4231,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct)) ]- callback _ = pure (BL.fromStrict sessionKey)+ callback _ = pure sessionKey ciphertext <- case encryptSEIPDv2Payload AES256@@ -4225,7 +4248,7 @@ decrypted <- DC.runConduitRes $ CL.sourceList (packets ciphertext)- DC..| conduitDecrypt callback+ DC..| testDecrypt callback DC..| CL.consume case decrypted of [LiteralDataPkt _ _ _ gotPayload] ->@@ -4263,7 +4286,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct)) ]- callback _ = pure (BL.fromStrict badSessionKey)+ callback _ = pure badSessionKey ciphertext <- case encryptSEIPDv2Payload AES256@@ -4282,7 +4305,7 @@ ( Right <$> ( DC.runConduitRes $ CL.sourceList (packets ciphertext)- DC..| conduitDecrypt callback+ DC..| testDecrypt callback DC..| CL.consume ) )@@ -4326,7 +4349,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = do let msk = Just (RSAPrivateKey (RSA_PrivateKey privateKey)) pure $@@ -4378,7 +4401,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -4414,12 +4437,12 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback pkt = case pkt of PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _))- | BL.length rid == 8 && BL.all (== 0) rid ->+ | B.length rid == 8 && B.all (== 0) rid -> pure ( Just ( PKESKRecipientKey@@ -4470,7 +4493,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -4528,7 +4551,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) encryptedResult <- ( P15.encrypt publicKey sessionKey@@ -4648,7 +4671,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -4678,7 +4701,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -4759,7 +4782,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -4791,7 +4814,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -4874,7 +4897,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -4904,7 +4927,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -4991,7 +5014,7 @@ ( PKESKPayloadV3Packet ( PKESKPayloadV3 3- (EightOctetKeyId (BL.replicate 8 0))+ (EightOctetKeyId (B.replicate 8 0)) X25519 (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) )@@ -5006,7 +5029,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty wrongKeyInfo = PKESKRecipientKey { pkeskRecipientPKPayload = Just wrongRecipientPKP@@ -5038,7 +5061,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithCandidatesCallbackAndPolicy+ DC..| testDecryptWithCandidatesCallbackAndPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -5092,7 +5115,7 @@ ( PKESKPayloadV3Packet ( PKESKPayloadV3 3- (EightOctetKeyId (BL.replicate 8 0))+ (EightOctetKeyId (B.replicate 8 0)) X25519 (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) )@@ -5107,7 +5130,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty mkSecretBytes offset = B.pack [fromIntegral ((offset + i) `mod` 256) | i <- [0 .. 31 :: Int]]@@ -5166,7 +5189,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithCandidatesCallbackAndPolicy+ DC..| testDecryptWithCandidatesCallbackAndPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -5220,7 +5243,7 @@ ( PKESKPayloadV3Packet ( PKESKPayloadV3 3- (EightOctetKeyId (BL.replicate 8 0))+ (EightOctetKeyId (B.replicate 8 0)) X25519 (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) )@@ -5238,7 +5261,7 @@ cleartext = BL.toStrict (runPut (put literalBlock)) iv = IV (B.pack [0x33 .. 0x42]) cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty mkSecretBytes offset = B.pack [fromIntegral ((offset + i) `mod` 256) | i <- [0 .. 31 :: Int]]@@ -5298,7 +5321,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD1 1 (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithCandidatesCallbackAndPolicy+ DC..| testDecryptWithCandidatesCallbackAndPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -5381,7 +5404,7 @@ ( PKESKPayloadV3Packet ( PKESKPayloadV3 3- (EightOctetKeyId (BL.replicate 8 0))+ (EightOctetKeyId (B.replicate 8 0)) X25519 (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) )@@ -5396,7 +5419,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty wrongKeyInfo = PKESKRecipientKey { pkeskRecipientPKPayload = Just wrongPKP@@ -5517,7 +5540,7 @@ ( PKESKPayloadV3Packet ( PKESKPayloadV3 3- (EightOctetKeyId (BL.replicate 8 0))+ (EightOctetKeyId (B.replicate 8 0)) X25519 (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) )@@ -5532,7 +5555,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty wrongKeyInfo = PKESKRecipientKey { pkeskRecipientPKPayload = Just wrongPKP@@ -5654,13 +5677,13 @@ ( PKESKPayloadV3Packet ( PKESKPayloadV3 3- (EightOctetKeyId (BL.replicate 8 0))+ (EightOctetKeyId (B.replicate 8 0)) X25519 (MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)]) ) ) salt = Salt (B.pack [0x00 .. 0x1f])- payload = "conduitDecryptWithReport wildcard diagnostics"+ payload = "testDecryptWithReport wildcard diagnostics" literalBlock = Block [ LiteralDataPkt@@ -5669,7 +5692,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty wrongKeyInfo = PKESKRecipientKey { pkeskRecipientPKPayload = Just wrongPKP@@ -5829,7 +5852,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -5861,7 +5884,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -5991,7 +6014,7 @@ ( SKESKPayloadV4 AES256 skeskS2K- (Just (BL.fromStrict skeskEncryptedEsk))+ (Just skeskEncryptedEsk) ) ) ciphertext <-@@ -6015,7 +6038,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -6023,7 +6046,7 @@ case decrypted of [LiteralDataPkt _ _ _ gotPayload] -> assertEqual- "conduitDecrypt should fall back from failing Argon2 SKESK to PKESKv3 X25519"+ "testDecrypt should fall back from failing Argon2 SKESK to PKESKv3 X25519" payload gotPayload other ->@@ -6037,7 +6060,7 @@ passphrase = "password" sessionKeyBytes = B.replicate 32 0x7b sessionKey = SessionKey sessionKeyBytes- badLatestEsk = BL.fromStrict (B.pack [0x00])+ badLatestEsk = B.pack [0x00] salt = Salt (B.pack [0x00 .. 0x1f]) payload = "earlier argon2 skesk fallback decrypt path" literalBlock =@@ -6076,7 +6099,7 @@ let earlierValidSKESK = SKESKPkt ( SKESKPayloadV4Packet- (SKESKPayloadV4 AES256 skeskS2K (Just (BL.fromStrict validEsk)))+ (SKESKPayloadV4 AES256 skeskS2K (Just validEsk)) ) latestUnusableSKESK = SKESKPkt@@ -6104,7 +6127,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy (\_ -> pure Nothing) passphraseCallback@@ -6112,7 +6135,7 @@ case decrypted of [LiteralDataPkt _ _ _ gotPayload] -> assertEqual- "conduitDecrypt should retry earlier Argon2 SKESK when latest SKESK is unusable"+ "testDecrypt should retry earlier Argon2 SKESK when latest SKESK is unusable" payload gotPayload other ->@@ -6183,7 +6206,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -6215,7 +6238,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -6319,7 +6342,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -6349,7 +6372,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -6465,7 +6488,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -6495,7 +6518,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -6593,7 +6616,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -6625,7 +6648,7 @@ , SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext)) ]- DC..| conduitDecryptWithDecryptPolicy+ DC..| testDecryptWithDecryptPolicy lenientDecryptPolicy keyContextCallback passphraseCallback@@ -6699,7 +6722,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -6712,7 +6735,7 @@ pkesk = PKESKPkt ( PKESKPayloadV6Packet- (PKESKPayloadV6 recipientRid X448 (BL.fromStrict esk))+ (PKESKPayloadV6 recipientRid X448 esk) ) ciphertext <- case encryptSEIPDv2Payload@@ -6805,7 +6828,7 @@ (ThirtyTwoBitTimeStamp 0) payload ]- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback _ = pure ( Just@@ -6818,7 +6841,7 @@ pkesk = PKESKPkt ( PKESKPayloadV6Packet- (PKESKPayloadV6 recipientRid X448 (BL.fromStrict esk))+ (PKESKPayloadV6 recipientRid X448 esk) ) ciphertext <- case encryptSEIPDv2Payload@@ -6897,7 +6920,7 @@ malformed = BL.fromStrict (B.take 2 encoded <> B.singleton 5 <> B.drop 3 encoded)- case runGet (get :: Get Pkt) malformed of+ case runGetTest (get :: Get Pkt) malformed of Right (BrokenPacketPkt errReason 3 _) -> assertBool ("expected unsupported SKESK version error, got: " ++ errReason)@@ -6921,11 +6944,11 @@ ( SKESKPayloadV4 AES128 (Simple SHA256)- (Just (BL.pack [0x01, 0x02, 0x03]))+ (Just (B.pack [0x01, 0x02, 0x03])) ) ) encoded = runPut (put pkt)- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right (BrokenPacketPkt errReason 3 _) -> assertBool ("expected Simple S2K rejection, got: " ++ errReason)@@ -6980,7 +7003,7 @@ ) >> fail "encrypting SKESK v4 ESK failed" Right x -> pure x- let skesk = SKESK4Packet sa s2k (Just (BL.fromStrict encryptedEsk))+ let skesk = SKESK4Packet sa s2k (Just encryptedEsk) case skesk2SessionKey skesk passphrase of Right (decodedAlgo, decodedSessionKey) -> do assertEqual@@ -7033,7 +7056,7 @@ ("encrypting malformed SKESK v4 ESK failed: " ++ show err) >> fail "encrypting malformed SKESK v4 ESK failed" Right x -> pure x- let skesk = SKESK4Packet sa s2k (Just (BL.fromStrict encryptedEsk))+ let skesk = SKESK4Packet sa s2k (Just encryptedEsk) case skesk2SessionKey skesk passphrase of Left ( S2KEncryptedSessionKeyDecodeError@@ -7055,7 +7078,7 @@ { passphraseEncryptVersionPolicy = PassphraseSKESKForceV4Interop , passphraseEncryptSymmetricAlgorithm = AES128 , passphraseEncryptS2K = Simple SHA256- , passphraseEncryptPassphrase = "password"+ , passphraseEncryptPassphrase = Passphrase "password" , passphraseEncryptPayload = "hello" , passphraseEncryptSEIPDv1IVOverride = Just (IV (B.replicate 16 0x22))@@ -7089,7 +7112,7 @@ { passphraseEncryptVersionPolicy = PassphraseSKESKPreferV6 , passphraseEncryptSymmetricAlgorithm = AES128 , passphraseEncryptS2K = Simple SHA256- , passphraseEncryptPassphrase = "password"+ , passphraseEncryptPassphrase = Passphrase "password" , passphraseEncryptPayload = "hello" , passphraseEncryptSEIPDv1IVOverride = Nothing , passphraseEncryptSEIPDv2AEADOverride = Just OCB@@ -7119,7 +7142,7 @@ testArgon2S2KVector :: Assertion testArgon2S2KVector = do let s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15- pass = BLC8.pack "password"+ pass = ("password" :: B.ByteString) derivedKeyResult = string2Key s2k 16 pass derivedKey <- case derivedKeyResult of
tests/Tests/KeyGeneration.hs view
@@ -9,14 +9,16 @@ module Tests.KeyGeneration (keyGenerationTests) where +import Control.Lens ((^.)) import Control.Monad.Trans.Except (runExceptT)-import Crypto.Random.Types (getRandomBytes)-import Data.Binary.Get (Get, runGetOrFail)+import Data.Binary.Get (runGetOrFail) import Data.Binary.Put (runPut)-import qualified Data.ByteString.Lazy as BL+import Data.Maybe (mapMaybe)+import qualified Data.Set as Set import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit ( Assertion+ , assertBool , assertEqual , assertFailure , testCase@@ -24,12 +26,35 @@ 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@@ -58,6 +83,21 @@ "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@@ -80,20 +120,22 @@ testRSAV4RoundTrip :: Assertion testRSAV4RoundTrip = do result <-- runExceptT $- generateSecretKey (KeyGenRSA @V4 (ThirtyTwoBitTimeStamp 0) 1024)+ runTKGen (V4, ThirtyTwoBitTimeStamp 0) $ do+ (pkp, skey) <- newKey RSA+ pure (pkp, skey) case result of- Left err -> assertFailure ("generateSecretKey failed: " ++ err)- Right (pkp, skey) -> roundTripAssertion "RSA V4" pkp skey+ Left err -> assertFailure ("runTKGen failed: " ++ show err)+ Right ((pkp, skey), _tk) -> roundTripAssertion "RSA V4" pkp skey testRSAV6RoundTrip :: Assertion testRSAV6RoundTrip = do result <-- runExceptT $- generateSecretKey (KeyGenRSA @V6 (ThirtyTwoBitTimeStamp 0) 1024)+ runTKGen (V6, ThirtyTwoBitTimeStamp 0) $ do+ (pkp, skey) <- newKey RSA+ pure (pkp, skey) case result of- Left err -> assertFailure ("generateSecretKey failed: " ++ err)- Right (pkp, skey) -> roundTripAssertion "RSA V6" pkp skey+ Left err -> assertFailure ("runTKGen failed: " ++ show err)+ Right ((pkp, skey), _tk) -> roundTripAssertion "RSA V6" pkp skey testRSAMultipleOf8 :: Assertion testRSAMultipleOf8 = do@@ -109,35 +151,287 @@ testEd25519V6RoundTrip :: Assertion testEd25519V6RoundTrip = do result <-- runExceptT $- generateSecretKey (KeyGenEd25519 (ThirtyTwoBitTimeStamp 0))+ runTKGen (V6, ThirtyTwoBitTimeStamp 0) $ do+ (pkp, skey) <- newKey Ed25519+ pure (pkp, skey) case result of- Left err -> assertFailure ("generateSecretKey failed: " ++ err)- Right (pkp, skey) -> roundTripAssertion "Ed25519 V6" pkp skey+ Left err -> assertFailure ("runTKGen failed: " ++ show err)+ Right ((pkp, skey), _tk) -> roundTripAssertion "Ed25519 V6" pkp skey testEd448V6RoundTrip :: Assertion testEd448V6RoundTrip = do result <-- runExceptT $- generateSecretKey (KeyGenEd448 (ThirtyTwoBitTimeStamp 0))+ runTKGen (V6, ThirtyTwoBitTimeStamp 0) $ do+ (pkp, skey) <- newKey Ed448+ pure (pkp, skey) case result of- Left err -> assertFailure ("generateSecretKey failed: " ++ err)- Right (pkp, skey) -> roundTripAssertion "Ed448 V6" pkp skey+ Left err -> assertFailure ("runTKGen failed: " ++ show err)+ Right ((pkp, skey), _tk) -> roundTripAssertion "Ed448 V6" pkp skey testX25519V6RoundTrip :: Assertion testX25519V6RoundTrip = do result <-- runExceptT $- generateSecretKey (KeyGenX25519 (ThirtyTwoBitTimeStamp 0))+ runTKGen (V6, ThirtyTwoBitTimeStamp 0) $ do+ (pkp, skey) <- newKey X25519+ pure (pkp, skey) case result of- Left err -> assertFailure ("generateSecretKey failed: " ++ err)- Right (pkp, skey) -> roundTripAssertion "X25519 V6" pkp skey+ Left err -> assertFailure ("runTKGen failed: " ++ show err)+ Right ((pkp, skey), _tk) -> roundTripAssertion "X25519 V6" pkp skey testX448V6RoundTrip :: Assertion testX448V6RoundTrip = do result <-- runExceptT $- generateSecretKey (KeyGenX448 (ThirtyTwoBitTimeStamp 0))+ runTKGen (V6, ThirtyTwoBitTimeStamp 0) $ do+ (pkp, skey) <- newKey X448+ pure (pkp, skey) case result of- Left err -> assertFailure ("generateSecretKey failed: " ++ err)- Right (pkp, skey) -> roundTripAssertion "X448 V6" pkp skey+ 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
tests/Tests/Keys.hs view
@@ -71,8 +71,8 @@ ) import Codec.Encryption.OpenPGP.SecretKey ( SecretKeyEncryptOptions (..)- , decryptPrivateKey , decryptSecretKey+ , decryptSecretKeyAddendum , mkUnencryptedSKAddendum , reencryptSecretKey )@@ -123,7 +123,7 @@ , mkTestKeyring , readFixturePayload , readPKIPassphrase- , runGet+ , runGetTest , setKeyVersion , signBinaryMessageWithRSAAt , signCertificationAt@@ -402,7 +402,7 @@ :: FilePath -> String -> Assertion testPKAandSizeAndKeyIDandFingerprint fpr kf = do bs <- readFixturePayload fpr- case runGet (get :: Get Pkt) bs of+ case runGetTest (get :: Get Pkt) bs of Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke." Right pkt -> case publicKeyPacketOf pkt of@@ -585,7 +585,7 @@ BinarySig RSA SHA256- (SignatureSalt (BL.replicate 16 0))+ (SignatureSalt (B.replicate 16 0)) [] [] 0@@ -646,6 +646,7 @@ } sigPayload <- case signDataWithRSA+ SHA512 SubkeyBindingSig primarySigningKey hashedWithUnsupportedCritical@@ -875,7 +876,7 @@ ) -- Test Ed25519 v6 builder API- let v6Salt = SignatureSalt (BL.replicate 32 0x42)+ let v6Salt = SignatureSalt (B.replicate 32 0x42) let builderEd25519V6 = sigBuilderInitV6 @'PKA.Ed25519 BinarySig SHA512 v6Salt let builderEd25519V6WithHashed = addHashedSubs (listToHashedSubs []) builderEd25519V6 let builderEd25519V6Final =@@ -893,7 +894,7 @@ assertEqual "Ed25519 v6 builder API should preserve 32-byte salt" 32- (BL.length (unSignatureSalt salt))+ (B.length (unSignatureSalt salt)) Right other -> assertFailure ( "Ed25519 v6 builder API should generate BinarySig Ed25519 SHA512 SigV6, got "@@ -901,7 +902,7 @@ ) -- Runtime v6 builder initialization should support SHA3 witness-backed hashes.- let v6Sha3Salt = SignatureSalt (BL.replicate 16 0x33)+ let v6Sha3Salt = SignatureSalt (B.replicate 16 0x33) runtimeEd25519V6Sha3 = case sigBuilderInitV6Runtime @'PKA.Ed25519 RFC9580@@ -927,7 +928,7 @@ assertEqual "runtime RFC9580 SHA3-256 v6 builder should preserve 16-byte salt" 16- (BL.length (unSignatureSalt salt))+ (B.length (unSignatureSalt salt)) Right other -> assertFailure ( "runtime RFC9580 SHA3-256 v6 builder should produce Ed25519 SigV6 SHA3_256, got "@@ -991,7 +992,7 @@ ) (_, edSigningKey) <- loadDeterministicEd25519Signer- let v6Salt = SignatureSalt (BL.replicate 32 0x17)+ let v6Salt = SignatureSalt (B.replicate 32 0x17) v6Builder = sigBuilderInitV6 @'PKA.Ed25519 BinarySig SHA512 v6Salt v6WithHashed = addHashedSubs@@ -1634,6 +1635,7 @@ testChangePrivateKeyPassphraseLegacy :: Assertion testChangePrivateKeyPassphraseLegacy = do passphrase <- readPKIPassphrase+ let pp = passphrase packets <- DC.runConduitRes $ CB.sourceFile "tests/data/aes256-sha512.seckey"@@ -1646,23 +1648,17 @@ assertFailure "aes256-sha512.seckey did not begin with a secret key packet" >> fail "expected secret key packet"- originalDecrypted <-- case decryptPrivateKey (pkp, ska) passphrase of- Left err ->- assertFailure ("decrypting original legacy key failed: " ++ err)- >> fail "decrypting original legacy key failed"- Right x -> pure x originalSKey <-- case originalDecrypted of- SUUnencrypted skey _ -> pure skey- _ ->+ case decryptSecretKeyAddendum pkp ska passphrase of+ Left err -> assertFailure- "original legacy key should decrypt to unencrypted secret material"- >> fail "expected unencrypted secret key"+ ("decrypting original legacy key failed: " ++ show err)+ >> fail "decrypting original legacy key failed"+ Right (originalSKey, _) -> pure originalSKey encryptedResult <- reencryptSecretKey (SecretKey pkp ska)- (Passphrase passphrase)+ pp (Passphrase "changed-pki-password") SecretKeyEncryptOptions { skeoPolicy = defaultPolicy@@ -1681,13 +1677,13 @@ Right sk -> pure (_secretKeySKAddendum sk) originalIterCount <- case ska of- SUSSHA1 AES256 (IteratedSalted SHA512 _ iter) _ _ -> pure iter+ SUSCFB AES256 (IteratedSalted SHA512 _ iter) _ _ -> pure iter _ -> assertFailure- "legacy key fixture should use SUSSHA1/AES256/IteratedSalted SHA512"+ "legacy key fixture should use SUSCFB/AES256/IteratedSalted SHA512" >> fail "expected legacy key fixture" case changed of- SUSSHA1 AES256 (IteratedSalted SHA512 _ iter) _ encryptedPayload -> do+ SUSCFB AES256 (IteratedSalted SHA512 _ iter) _ encryptedPayload -> do assertEqual "legacy passphrase change should preserve the S2K iteration count" originalIterCount@@ -1697,23 +1693,21 @@ (not (BL.null encryptedPayload)) _ -> assertFailure- "legacy passphrase change should preserve the SUSSHA1/AES256 envelope"- decrypted <-- case decryptPrivateKey (pkp, changed) "changed-pki-password" of+ "legacy passphrase change should preserve the SUSCFB/AES256 envelope"+ skey <-+ case decryptSecretKeyAddendum+ pkp+ changed+ (Passphrase "changed-pki-password") of Left err -> assertFailure- ("re-decrypting changed legacy key failed: " ++ err)+ ("re-decrypting changed legacy key failed: " ++ show err) >> fail "re-decrypting changed legacy key failed"- Right x -> pure x- case decrypted of- SUUnencrypted skey _ ->- assertEqual- "legacy passphrase change should preserve secret key material"- originalSKey- skey- _ ->- assertFailure- "legacy passphrase change should decrypt back to unencrypted secret material"+ Right (skey, _) -> pure skey+ assertEqual+ "legacy passphrase change should preserve secret key material"+ originalSKey+ skey testChangePrivateKeyPassphraseV6 :: Assertion testChangePrivateKeyPassphraseV6 = do@@ -1735,23 +1729,16 @@ "v6-encrypted-secret.pgp.aa did not begin with a secret key packet" >> fail "expected secret key packet" let newPassphrase = "changed-pki-password"- originalDecrypted <-- case decryptPrivateKey (pkp, ska) oldPassphrase of+ originalSKey <-+ case decryptSecretKeyAddendum pkp ska oldPassphrase of Left err ->- assertFailure ("decrypting original v6 key failed: " ++ err)+ assertFailure ("decrypting original v6 key failed: " ++ show err) >> fail "decrypting original v6 key failed"- Right x -> pure x- originalSKey <-- case originalDecrypted of- SUUnencrypted skey _ -> pure skey- _ ->- assertFailure- "original v6 key should decrypt to unencrypted secret material"- >> fail "expected unencrypted secret key"+ Right (originalSKey, _) -> pure originalSKey changedResult <- reencryptSecretKey (SecretKey pkp ska)- (Passphrase oldPassphrase)+ oldPassphrase (Passphrase newPassphrase) SecretKeyEncryptOptions { skeoPolicy = defaultPolicy@@ -1785,23 +1772,17 @@ _ -> assertFailure "changed v6 key addendum should be encrypted with SUSAEAD"- let decryptedResult = decryptPrivateKey (pkp, changed) newPassphrase- decrypted <-- case decryptedResult of+ decryptedSKey <-+ case decryptSecretKeyAddendum pkp changed (Passphrase newPassphrase) of Left err -> assertFailure- ("decryption with changed v6 passphrase failed: " ++ err)+ ("decryption with changed v6 passphrase failed: " ++ show err) >> fail "decryption with changed v6 passphrase failed"- Right x -> pure x- case decrypted of- SUUnencrypted skey _ ->- assertEqual- "changing a v6 key passphrase should preserve secret key material"- originalSKey- skey- _ ->- assertFailure- "changed v6 key should decrypt with the new passphrase"+ Right (decryptedSKey, _) -> pure decryptedSKey+ assertEqual+ "changing a v6 key passphrase should preserve secret key material"+ originalSKey+ decryptedSKey testPolicySignatureContextValidation :: Assertion testPolicySignatureContextValidation = do@@ -1813,7 +1794,7 @@ KeyRevocationSig EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x11))+ (SignatureSalt (B.replicate 32 0x11)) [] [] 0@@ -1823,7 +1804,7 @@ DirectKeySignature EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x12))+ (SignatureSalt (B.replicate 32 0x12)) [] [] 0@@ -1833,7 +1814,7 @@ SubkeyBindingSig EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x13))+ (SignatureSalt (B.replicate 32 0x13)) [] [] 0@@ -1846,7 +1827,7 @@ SubkeyBindingSig EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x14))+ (SignatureSalt (B.replicate 32 0x14)) [] [] 0@@ -1856,7 +1837,7 @@ SubkeyRevocationSig EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x15))+ (SignatureSalt (B.replicate 32 0x15)) [] [] 0@@ -1866,7 +1847,7 @@ DirectKeySignature EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x16))+ (SignatureSalt (B.replicate 32 0x16)) [] [] 0@@ -1882,7 +1863,7 @@ GenericCert EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x17))+ (SignatureSalt (B.replicate 32 0x17)) [] [] 0@@ -1892,7 +1873,7 @@ PersonaCert EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x18))+ (SignatureSalt (B.replicate 32 0x18)) [] [] 0@@ -1902,7 +1883,7 @@ CasualCert EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x19))+ (SignatureSalt (B.replicate 32 0x19)) [] [] 0@@ -1912,7 +1893,7 @@ PositiveCert EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x1a))+ (SignatureSalt (B.replicate 32 0x1a)) [] [] 0@@ -1922,7 +1903,7 @@ CertRevocationSig EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x1b))+ (SignatureSalt (B.replicate 32 0x1b)) [] [] 0@@ -1932,7 +1913,7 @@ SubkeyBindingSig EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x1c))+ (SignatureSalt (B.replicate 32 0x1c)) [] [] 0@@ -2025,7 +2006,7 @@ KeyRevocationSig RSA SHA256- (SignatureSalt (BL.replicate 16 0))+ (SignatureSalt (B.replicate 16 0)) [SigSubPacket False (Issuer issuerKeyId)] [] 0@@ -2064,7 +2045,7 @@ KeyRevocationSig RSA SHA256- (SignatureSalt (BL.replicate 16 0))+ (SignatureSalt (B.replicate 16 0)) [] [SigSubPacket False (Issuer issuerKeyId)] 0@@ -2097,7 +2078,7 @@ KeyRevocationSig RSA SHA256- (SignatureSalt (BL.replicate 16 0))+ (SignatureSalt (B.replicate 16 0)) [ SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 (fingerprint signer))@@ -2189,7 +2170,10 @@ ) ) )- (SUUnencrypted (EdDSAPrivateKey EdSigningCurve25519 secretBytes) 0)+ ( SUSUnprotected+ (EdDSAPrivateKey EdSigningCurve25519 secretBytes)+ 0+ ) case runGetOrFail (get :: Get Pkt) (runPut (put pkt)) of Left (_, _, err) -> assertFailure@@ -2198,7 +2182,10 @@ case parsedPkt of SecretKeyPkt _- (SUUnencrypted (EdDSAPrivateKey EdSigningCurve25519 parsedBytes) _) ->+ ( SUSUnprotected+ (EdDSAPrivateKey EdSigningCurve25519 parsedBytes)+ _+ ) -> assertEqual "v4 Ed25519 secret-key round-trip should preserve MPI-encoded bytes" secretBytes@@ -2244,12 +2231,12 @@ DC..| conduitGet get DC..| CL.consume case packets of- (SecretKeyPkt pkp (SUUnencrypted sk _) : _) ->+ (SecretKeyPkt pkp (SUSUnprotected sk _) : _) -> case mkUnencryptedSKAddendum pkp sk of Left err -> assertFailure ("mkUnencryptedSKAddendum should succeed for fixture key: " ++ err)- Right (SUUnencrypted _ actualChecksum) -> do+ Right (SUSUnprotected _ actualChecksum) -> do skPayload <- case putSKeyForPKPayload pkp sk of Left err ->@@ -2286,7 +2273,7 @@ Left err -> assertFailure ("mkUnencryptedSKAddendum should support v6 key payloads: " ++ err)- Right (SUUnencrypted _ checksum) ->+ Right (SUSUnprotected _ checksum) -> assertEqual "v6 unencrypted addendum checksum should be zero" 0@@ -2334,17 +2321,15 @@ "aes256-sha512.seckey did not begin with a secret key packet" >> fail "expected secret key packet" skey <-- case decryptSecretKey (SecretKey pkp ska) (Passphrase passphrase) of+ case decryptSecretKey (SecretKey pkp ska) passphrase of Left err -> assertFailure ("high-level decrypt of legacy key failed: " ++ show err) >> fail "high-level decrypt failed" Right x -> pure x originalSKey <-- case decryptPrivateKey- (pkp, ska)- (unPassphrase (Passphrase passphrase)) of- Right (SUUnencrypted skey' _) -> pure skey'+ case decryptSecretKeyAddendum pkp ska passphrase of+ Right (skey', _) -> pure skey' _ -> fail "expected unencrypted secret key" assertEqual "high-level decrypt should preserve secret key material"@@ -2371,17 +2356,15 @@ "v6-encrypted-secret.pgp.aa did not begin with a secret key packet" >> fail "expected secret key packet" skey <-- case decryptSecretKey (SecretKey pkp ska) (Passphrase oldPassphrase) of+ case decryptSecretKey (SecretKey pkp ska) oldPassphrase of Left err -> assertFailure ("high-level decrypt of v6 key failed: " ++ show err) >> fail "high-level decrypt failed" Right x -> pure x originalSKey <-- case decryptPrivateKey- (pkp, ska)- (unPassphrase (Passphrase oldPassphrase)) of- Right (SUUnencrypted skey' _) -> pure skey'+ case decryptSecretKeyAddendum pkp ska oldPassphrase of+ Right (skey', _) -> pure skey' _ -> fail "expected unencrypted secret key" assertEqual "high-level decrypt should preserve v6 secret key material"@@ -2415,7 +2398,7 @@ result <- reencryptSecretKey (SecretKey pkp ska)- (Passphrase passphrase)+ passphrase (Passphrase "changed-pki-password") opts changed <-@@ -2435,16 +2418,14 @@ >> fail "decryption with changed legacy passphrase failed" Right x -> pure x originalSKey <-- case decryptPrivateKey- (pkp, ska)- (unPassphrase (Passphrase passphrase)) of- Right (SUUnencrypted skey' _) -> pure skey'+ case decryptSecretKeyAddendum pkp ska passphrase of+ Right (skey', _) -> pure skey' _ -> fail "expected unencrypted secret key" assertEqual "high-level legacy passphrase change should preserve secret key material" originalSKey decrypted- case decryptSecretKey changed (Passphrase passphrase) of+ case decryptSecretKey changed passphrase of Right _ -> assertFailure "decryption with old legacy passphrase should fail after passphrase change"@@ -2472,7 +2453,7 @@ result <- reencryptSecretKey (SecretKey pkp ska)- (Passphrase oldPassphrase)+ oldPassphrase (Passphrase "changed-pki-password") SecretKeyEncryptOptions { skeoPolicy = defaultPolicy@@ -2497,16 +2478,14 @@ >> fail "decryption with changed v6 passphrase failed" Right x -> pure x originalSKey <-- case decryptPrivateKey- (pkp, ska)- (unPassphrase (Passphrase oldPassphrase)) of- Right (SUUnencrypted skey' _) -> pure skey'+ case decryptSecretKeyAddendum pkp ska oldPassphrase of+ Right (skey', _) -> pure skey' _ -> fail "expected unencrypted secret key" assertEqual "high-level v6 passphrase change should preserve secret key material" originalSKey decrypted- case decryptSecretKey changed (Passphrase oldPassphrase) of+ case decryptSecretKey changed oldPassphrase of Right _ -> assertFailure "decryption with old v6 passphrase should fail after passphrase change"@@ -2536,11 +2515,12 @@ , skeoSalt = Just salt , skeoIV = Just iv }+ let pp = passphrase result1 <- reencryptSecretKey (SecretKey pkp ska)- (Passphrase passphrase)- (Passphrase passphrase)+ pp+ pp opts changed1 <- case result1 of@@ -2554,8 +2534,8 @@ result2 <- reencryptSecretKey (SecretKey pkp ska)- (Passphrase passphrase)- (Passphrase passphrase)+ pp+ pp opts changed2 <- case result2 of
tests/Tests/MessageAndArmor.hs view
@@ -96,16 +96,17 @@ , VerificationError (..) , renderSignError , renderVerificationError- , signCertRevocationWithRSA- , signCertificationWithRSA+ , signCertRevocation , signDataWithEd25519 , signDataWithEd25519V6 , signDataWithEd448 , signDataWithEd448V6 , signDataWithRSA , signDataWithRSABuilder- , signKeyRevocationWithRSA- , signSubkeyRevocationWithRSA+ , signDataWithRSAV6+ , signDirectKey+ , signSubkeyRevocation+ , signUserId , verifyAgainstKeyring , verifyAgainstKeys , verifySigWith@@ -122,7 +123,10 @@ import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA import Data.Conduit.OpenPGP.Message- ( verifyMessage+ ( VerificationOptions (..)+ , VerificationPolicy (..)+ , defaultVerificationOptions+ , verifyMessage , verifyMessagePackets ) import Data.Conduit.OpenPGP.Verify (VerificationMode (..))@@ -259,6 +263,24 @@ "detached v4 Ed25519 verifyAgainstKeys tolerates fake issuer hints" testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys , testCase+ "RSA detached round-trip across supported hash algorithms"+ testRsaMultiHashRoundTrip+ , testCase+ "Ed25519 detached round-trip across supported hash algorithms"+ testEd25519MultiHashRoundTrip+ , testCase+ "Ed448 detached round-trip across supported hash algorithms"+ testEd448MultiHashRoundTrip+ , testCase+ "RSA v6 detached round-trip across supported hash algorithms"+ testRsaV6MultiHashRoundTrip+ , testCase+ "Ed25519 v6 detached round-trip across supported hash algorithms"+ testEd25519V6MultiHashRoundTrip+ , testCase+ "Ed448 v6 detached round-trip across supported hash algorithms"+ testEd448V6MultiHashRoundTrip+ , testCase "v4 EdDSALegacy signatures verify with Ed25519 key algorithm identifier" testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm , testCase@@ -480,7 +502,7 @@ assertEncryptedS2K :: String -> SKAddendum -> Assertion assertEncryptedS2K testLabel ska = case ska of- SUSSHA1 AES256 (IteratedSalted SHA256 _ iter) _ encryptedPayload -> do+ SUSCFB AES256 (IteratedSalted SHA256 _ iter) _ encryptedPayload -> do assertEqual (testLabel ++ " should use expected S2K iteration count") (IterationCount 65011712)@@ -490,7 +512,7 @@ assertFailure (testLabel ++ " should have non-empty encrypted key material") else pure ()- SUUnencrypted _ _ ->+ SUSUnprotected _ _ -> assertFailure ( testLabel ++ " should be encrypted, got unencrypted secret material"@@ -498,7 +520,7 @@ _ -> assertFailure ( testLabel- ++ " should be encrypted with SUSSHA1/AES256/IteratedSalted SHA256"+ ++ " should be encrypted with SUSCFB/AES256/IteratedSalted SHA256" ) testV4EncryptedRevocationArmor :: Assertion@@ -644,7 +666,7 @@ assertEqual (fixture ++ " SigV6 salt size should match hash algorithm") expected- (fromIntegral (BL.length (unSignatureSalt salt)))+ (fromIntegral (B.length (unSignatureSalt salt))) other -> assertFailure ( fixture@@ -800,11 +822,11 @@ ] -> do assertBool "default SKESK v6 IV should be present"- (not (BL.null iv))+ (not (B.null iv)) assertBool "default SKESK v6 wrapped session key should be present"- (not (BL.null esk))- assertEqual "default SKESK v6 tag length" 16 (BL.length tag)+ (not (B.null esk))+ assertEqual "default SKESK v6 tag length" 16 (B.length tag) other -> assertFailure ( "default encryption should emit SKESK v6 + SEIPD v2 packets, got "@@ -851,11 +873,11 @@ ] -> do assertBool "explicit SKESK v6 IV should be present"- (not (BL.null packetIv))+ (not (B.null packetIv)) assertBool "explicit SKESK v6 wrapped session key should be present"- (not (BL.null esk))- assertEqual "explicit SKESK v6 tag length" 16 (BL.length tag)+ (not (B.null esk))+ assertEqual "explicit SKESK v6 tag length" 16 (B.length tag) other -> assertFailure ( "explicit AES encryption should default to SKESK v6 + SEIPD v2 packets, got "@@ -875,7 +897,7 @@ testExplicitEncryptExposesEffectiveSessionMaterial :: Assertion testExplicitEncryptExposesEffectiveSessionMaterial = do let passphraseBytes = "roundtrip2-session-material"- passphrase = Passphrase passphraseBytes+ passphrase = Passphrase (BL.toStrict passphraseBytes) payload = mkClearPayload "hello from session material town" sa = AES128 s2k = Argon2 (Salt16 (B.pack [0x40 .. 0x4f])) 1 4 15@@ -903,7 +925,7 @@ ("failed to derive expected key size: " ++ show err) >> fail "keySize failed" Right keyLen ->- case string2Key s2k keyLen passphraseBytes of+ case string2Key s2k keyLen (unPassphrase passphrase) of Left err -> assertFailure ("failed to derive expected session key: " ++ renderS2KError err)@@ -961,7 +983,7 @@ let passphraseBytes = "roundtrip-" <> BL.fromStrict (B.pack (map (fromIntegral . fromEnum) label))- passphrase = Passphrase passphraseBytes+ passphrase = Passphrase (BL.toStrict passphraseBytes) payload = mkClearPayload ( "hello from "@@ -984,7 +1006,7 @@ 6 salt s2k- passphraseBytes+ passphrase block of Left err -> assertFailure@@ -1014,14 +1036,14 @@ assertEqual ("AES-128 " ++ label ++ " SKESK v6 IV length") (fromIntegral expectedIvLen)- (BL.length iv)+ (B.length iv) assertBool ("AES-128 " ++ label ++ " wrapped session key should be present")- (not (BL.null esk))+ (not (B.null esk)) assertEqual ("AES-128 " ++ label ++ " SKESK tag length") 16- (BL.length tag)+ (B.length tag) other -> assertFailure ( "AES-128 "@@ -1044,6 +1066,7 @@ testExplicitAES128EAXEncryptDecrypt :: Assertion testExplicitAES128EAXEncryptDecrypt = do let passphraseBytes = "roundtrip-EAX"+ passphrase = Passphrase (BL.toStrict passphraseBytes) s2k = Argon2 (Salt16 (B.pack [0x10 .. 0x1f])) 1 4 15 salt = Salt (B.pack [0x20 .. 0x3f]) block =@@ -1055,7 +1078,7 @@ 6 salt s2k- passphraseBytes+ passphrase block of Left (SEIPDv2UnsupportedAEADAlgorithm EAX) -> pure ()@@ -1146,8 +1169,7 @@ testRFC4880EncryptMessageSEIPDv1ParsesCleanly :: Assertion testRFC4880EncryptMessageSEIPDv1ParsesCleanly = do- let passphraseBytes = "legacy-clean-parse" :: BL.ByteString- passphrase = Passphrase passphraseBytes+ let passphrase = Passphrase "legacy-clean-parse" payload = mkClearPayload "hello from clean legacy town" s2k = IteratedSalted SHA256 (Salt8 "saltxyz!") (IterationCount 65536)@@ -1195,7 +1217,7 @@ >> fail "keySize failed" Right n -> pure n sessionKey <-- case string2Key s2k keyLen passphraseBytes of+ case string2Key s2k keyLen (unPassphrase passphrase) of Left err -> assertFailure ("string2Key failed: " ++ renderS2KError err) >> fail "string2Key failed"@@ -1390,7 +1412,7 @@ assertEqual "SigV6 RSA salt must be 32 bytes for SHA512" 32- (BL.length (unSignatureSalt salt))+ (B.length (unSignatureSalt salt)) pure sig other -> assertFailure@@ -1505,7 +1527,7 @@ assertEqual "SigV6 Ed25519 salt must be 32 bytes for SHA512" 32- (BL.length (unSignatureSalt salt))+ (B.length (unSignatureSalt salt)) pure sig other -> assertFailure@@ -1645,7 +1667,7 @@ assertEqual "SigV6 Ed448 salt must be 32 bytes for SHA512" 32- (BL.length (unSignatureSalt salt))+ (B.length (unSignatureSalt salt)) pure sig other -> assertFailure@@ -1662,6 +1684,7 @@ (_, ed25519SigningKey) <- loadDeterministicEd25519Signer ed25519Sig <- case signDataWithEd25519+ SHA512 BinarySig ed25519SigningKey []@@ -1691,6 +1714,7 @@ (_, ed448SigningKey) <- loadDeterministicEd448Signer ed448Sig <- case signDataWithEd448+ SHA512 BinarySig ed448SigningKey []@@ -1735,7 +1759,7 @@ } ] sigPayload <-- case signDataWithEd25519 BinarySig signingKey [] [] payload of+ case signDataWithEd25519 SHA512 BinarySig signingKey [] [] payload of Left err -> assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err)@@ -1776,7 +1800,13 @@ fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef" unhashed = [SigSubPacket False (Issuer fakeIssuer)] sigPayload <-- case signDataWithEd25519 BinarySig signingKey [] unhashed payload of+ case signDataWithEd25519+ SHA512+ BinarySig+ signingKey+ []+ unhashed+ payload of Left err -> assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err)@@ -1816,7 +1846,7 @@ } ] sigPayload <-- case signDataWithEd25519 BinarySig signingKey [] [] payload of+ case signDataWithEd25519 SHA512 BinarySig signingKey [] [] payload of Left err -> assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err)@@ -1858,7 +1888,13 @@ fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef" unhashed = [SigSubPacket False (Issuer fakeIssuer)] sigPayload <-- case signDataWithEd25519 BinarySig signingKey [] unhashed payload of+ case signDataWithEd25519+ SHA512+ BinarySig+ signingKey+ []+ unhashed+ payload of Left err -> assertFailure ("Ed25519 detached signing failed: " ++ renderSignError err)@@ -1877,6 +1913,315 @@ ) Right _ -> pure () +rsaSupportedSignatureHashes :: [HashAlgorithm]+rsaSupportedSignatureHashes = [SHA256, SHA384, SHA512, SHA224]++edSupportedSignatureHashes :: [HashAlgorithm]+edSupportedSignatureHashes = [SHA512] -- this is a misnomer because Ed25519/Ed448 fix their own hash algorithms and this is ignored++testRsaMultiHashRoundTrip :: Assertion+testRsaMultiHashRoundTrip = do+ (signer, signingKey) <- loadUnencryptedRsaSigner+ let payload = "RSA multi-hash detached payload"+ state =+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ }+ keyring =+ mkTestKeyring+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary signer+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ forM_ rsaSupportedSignatureHashes $ \ha -> do+ sigPayload <-+ case signDataWithRSA ha BinarySig signingKey [] [] payload of+ Left err ->+ assertFailure+ ( "RSA detached signing failed for "+ ++ show ha+ ++ ": "+ ++ renderSignError err+ )+ >> fail "expected RSA signature payload"+ Right sig -> pure sig+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeyring keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "RSA detached verification failed for "+ ++ show ha+ ++ ": "+ ++ renderVerificationError err+ )+ Right _ -> pure ()++testEd25519MultiHashRoundTrip :: Assertion+testEd25519MultiHashRoundTrip = do+ (signer, signingKey) <- loadDeterministicEd25519Signer+ let payload = "Ed25519 multi-hash detached payload"+ state =+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ }+ keyring =+ mkTestKeyring+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary signer+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ forM_ edSupportedSignatureHashes $ \ha -> do+ sigPayload <-+ case signDataWithEd25519 ha BinarySig signingKey [] [] payload of+ Left err ->+ assertFailure+ ( "Ed25519 detached signing failed for "+ ++ show ha+ ++ ": "+ ++ renderSignError err+ )+ >> fail "expected Ed25519 signature payload"+ Right sig -> pure sig+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeyring keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "Ed25519 detached verification failed for "+ ++ show ha+ ++ ": "+ ++ renderVerificationError err+ )+ Right _ -> pure ()++testEd448MultiHashRoundTrip :: Assertion+testEd448MultiHashRoundTrip = do+ (signer, signingKey) <- loadDeterministicEd448Signer+ let payload = "Ed448 multi-hash detached payload"+ state =+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ }+ keyring =+ mkTestKeyring+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary signer+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ forM_ edSupportedSignatureHashes $ \ha -> do+ sigPayload <-+ case signDataWithEd448 ha BinarySig signingKey [] [] payload of+ Left err ->+ assertFailure+ ( "Ed448 detached signing failed for "+ ++ show ha+ ++ ": "+ ++ renderSignError err+ )+ >> fail "expected Ed448 signature payload"+ Right sig -> pure sig+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeyring keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "Ed448 detached verification failed for "+ ++ show ha+ ++ ": "+ ++ renderVerificationError err+ )+ Right _ -> pure ()++testRsaV6MultiHashRoundTrip :: Assertion+testRsaV6MultiHashRoundTrip = do+ (signer, signingKey) <- loadUnencryptedRsaSignerV6+ let payload = "RSA v6 multi-hash detached payload"+ state =+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ }+ keyring =+ mkTestKeyring+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary signer+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ forM_ rsaSupportedSignatureHashes $ \ha -> do+ salt <-+ case signatureV6SaltSizeForHashAlgorithm ha of+ Nothing ->+ assertFailure+ ( "v6 RSA multi-hash round-trip does not define salt size for: "+ ++ show ha+ )+ >> fail "expected defined salt size"+ Just sz -> pure (SignatureSalt (B.replicate (fromIntegral sz) 0xAB))+ sigPayload <-+ case signDataWithRSAV6 ha BinarySig salt signingKey [] [] payload of+ Left err ->+ assertFailure+ ( "RSA v6 detached signing failed for "+ ++ show ha+ ++ ": "+ ++ renderSignError err+ )+ >> fail "expected RSA v6 signature payload"+ Right sig -> pure sig+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeyring keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "RSA v6 detached verification failed for "+ ++ show ha+ ++ ": "+ ++ renderVerificationError err+ )+ Right _ -> pure ()++testEd25519V6MultiHashRoundTrip :: Assertion+testEd25519V6MultiHashRoundTrip = do+ (signer, signingKey) <- loadDeterministicEd25519SignerV6+ let payload = "Ed25519 v6 multi-hash detached payload"+ state =+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ }+ keyring =+ mkTestKeyring+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary signer+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ forM_ edSupportedSignatureHashes $ \ha -> do+ salt <-+ case signatureV6SaltSizeForHashAlgorithm ha of+ Nothing ->+ assertFailure+ ( "v6 Ed25519 multi-hash round-trip does not define salt size for: "+ ++ show ha+ )+ >> fail "expected defined salt size"+ Just sz -> pure (SignatureSalt (B.replicate (fromIntegral sz) 0xAB))+ sigPayload <-+ case signDataWithEd25519V6 ha BinarySig salt signingKey [] [] payload of+ Left err ->+ assertFailure+ ( "Ed25519 v6 detached signing failed for "+ ++ show ha+ ++ ": "+ ++ renderSignError err+ )+ >> fail "expected Ed25519 v6 signature payload"+ Right sig -> pure sig+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeyring keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "Ed25519 v6 detached verification failed for "+ ++ show ha+ ++ ": "+ ++ renderVerificationError err+ )+ Right _ -> pure ()++testEd448V6MultiHashRoundTrip :: Assertion+testEd448V6MultiHashRoundTrip = do+ (signer, signingKey) <- loadDeterministicEd448SignerV6+ let payload = "Ed448 v6 multi-hash detached payload"+ state =+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData (FileName B.empty) 0 payload+ }+ keyring =+ mkTestKeyring+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary signer+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ forM_ edSupportedSignatureHashes $ \ha -> do+ salt <-+ case signatureV6SaltSizeForHashAlgorithm ha of+ Nothing ->+ assertFailure+ ( "v6 Ed448 multi-hash round-trip does not define salt size for: "+ ++ show ha+ )+ >> fail "expected defined salt size"+ Just sz -> pure (SignatureSalt (B.replicate (fromIntegral sz) 0xAB))+ sigPayload <-+ case signDataWithEd448V6 ha BinarySig salt signingKey [] [] payload of+ Left err ->+ assertFailure+ ( "Ed448 v6 detached signing failed for "+ ++ show ha+ ++ ": "+ ++ renderSignError err+ )+ >> fail "expected Ed448 v6 signature payload"+ Right sig -> pure sig+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeyring keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "Ed448 v6 detached verification failed for "+ ++ show ha+ ++ ": "+ ++ renderVerificationError err+ )+ Right _ -> pure ()+ testCanonicalTextSigPayloadNormalization :: Assertion testCanonicalTextSigPayloadNormalization = do let state =@@ -2061,6 +2406,7 @@ unhashed = [SigSubPacket False (Issuer issuerKeyId)] primitiveMixed <- case signDataWithRSA+ SHA512 CanonicalTextSig signingKey hashed@@ -2075,6 +2421,7 @@ Right sig -> pure sig primitiveNormalized <- case signDataWithRSA+ SHA512 CanonicalTextSig signingKey hashed@@ -2137,29 +2484,67 @@ Right _ -> assertFailure (testLabel ++ " should generate a V4 signature payload")- assertSigType- "certification signature"- GenericCert- ( signCertificationWithRSA+ certSig <-+ signUserId+ SHA512 GenericCert- signer+ ( KeyPktSecretPrimary+ signer+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0)+ ) userId [] [] signingKey- )+ assertSigType "certification signature" GenericCert certSig+ keyRevSig <-+ signDirectKey+ SHA512+ KeyRevocationSig+ ( KeyPktSecretPrimary+ signer+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0)+ )+ []+ []+ signingKey assertSigType "key revocation signature" KeyRevocationSig- (signKeyRevocationWithRSA signer [] [] signingKey)+ keyRevSig+ subkeyRevSig <-+ signSubkeyRevocation+ SHA512+ ( KeyPktSecretPrimary+ signer+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0)+ )+ ( KeyPktSecretPrimary+ signer+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0)+ )+ []+ []+ signingKey assertSigType "subkey revocation signature" SubkeyRevocationSig- (signSubkeyRevocationWithRSA signer signer [] [] signingKey)+ subkeyRevSig+ certRevSig <-+ signCertRevocation+ SHA512+ ( KeyPktSecretPrimary+ signer+ (SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0)+ )+ userId+ []+ []+ signingKey assertSigType "certification revocation signature" CertRevocationSig- (signCertRevocationWithRSA signer userId [] [] signingKey)+ certRevSig let left16Payload = "left16 primitive payload" left16Keyring = mkTestKeyring@@ -2173,7 +2558,7 @@ } ] left16Sig <-- case signDataWithRSA BinarySig signingKey [] [] left16Payload of+ case signDataWithRSA SHA512 BinarySig signingKey [] [] left16Payload of Left err -> assertFailure ( "RSA primitive signing for left16 failed: "@@ -2205,19 +2590,6 @@ Right _ -> assertFailure "verification unexpectedly succeeded with tampered left16"- if isRight- ( signCertificationWithRSA- KeyRevocationSig- signer- userId- []- []- signingKey- )- then- assertFailure- "certification primitive should reject non-certification signature types"- else pure () (edSigner, edSigningKey) <- loadDeterministicEd25519Signer edIssuerKeyId <- case eightOctetKeyID edSigner of@@ -2233,6 +2605,7 @@ ] edUnhashed = [SigSubPacket False (Issuer edIssuerKeyId)] case signDataWithEd25519+ SHA512 BinarySig edSigningKey edHashed@@ -2247,8 +2620,9 @@ ( "Ed25519 primitive should generate an Ed25519 SigV4 payload, got " ++ show other )- let v6Salt = SignatureSalt (BL.replicate 32 0x42)+ let v6Salt = SignatureSalt (B.replicate 32 0x42) case signDataWithEd25519V6+ SHA512 BinarySig v6Salt edSigningKey@@ -2262,7 +2636,7 @@ assertEqual "Ed25519 SigV6 primitive should preserve 32-byte salt" 32- (BL.length (unSignatureSalt salt))+ (B.length (unSignatureSalt salt)) Right other -> assertFailure ( "Ed25519 SigV6 primitive should generate an Ed25519 SigV6 payload, got "@@ -2283,6 +2657,7 @@ ] ed448Unhashed = [SigSubPacket False (Issuer ed448IssuerKeyId)] case signDataWithEd448+ SHA512 BinarySig ed448SigningKey ed448Hashed@@ -2298,6 +2673,7 @@ ++ show other ) case signDataWithEd448V6+ SHA512 BinarySig v6Salt ed448SigningKey@@ -2311,7 +2687,7 @@ assertEqual "Ed448 SigV6 primitive should preserve 32-byte salt" 32- (BL.length (unSignatureSalt salt))+ (B.length (unSignatureSalt salt)) Right other -> assertFailure ( "Ed448 SigV6 primitive should generate an Ed448 SigV6 payload, got "@@ -2343,7 +2719,7 @@ BinarySig PKA.Ed25519 SHA512- (SignatureSalt (BL.replicate 32 0x01))+ (SignatureSalt (B.replicate 32 0x01)) [] [] 0@@ -3088,7 +3464,7 @@ Right x -> pure x edSecretKey <- extractEd25519SecretKey skey let payload = "v6 fixture detached signature payload"- salt = SignatureSalt (BL.fromStrict (B.replicate 32 0xAB))+ salt = SignatureSalt (B.replicate 32 0xAB) hashed = [SigSubPacket False (SigCreationTime 0)] unhashed = [ SigSubPacket@@ -3097,6 +3473,7 @@ ] sigPayload <- case signDataWithEd25519V6+ SHA512 BinarySig salt edSecretKey@@ -3148,7 +3525,7 @@ Right x -> pure x edSecretKey <- extractEd25519SecretKey skey let payload = "v6 fixture binary message signing payload"- salt = SignatureSalt (BL.fromStrict (B.replicate 32 0xCD))+ salt = SignatureSalt (B.replicate 32 0xCD) hashed = [SigSubPacket False (SigCreationTime 0)] unhashed = [ SigSubPacket@@ -3157,6 +3534,7 @@ ] sigPayload <- case signDataWithEd25519V6+ SHA512 BinarySig salt edSecretKey@@ -3207,7 +3585,7 @@ >> fail "expected v6 secret fixture" Right x -> pure x edSecretKey <- extractEd25519SecretKey skey- let salt = SignatureSalt (BL.fromStrict (B.replicate 32 0xEF))+ let salt = SignatureSalt (B.replicate 32 0xEF) hashed = [SigSubPacket False (SigCreationTime 0)] unhashed = [ SigSubPacket@@ -3217,6 +3595,7 @@ keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp)) sigPayload <- case signDataWithEd25519V6+ SHA512 DirectKeySignature salt edSecretKey@@ -3267,7 +3646,7 @@ >> fail "expected v6 secret fixture" Right x -> pure x edSecretKey <- extractEd25519SecretKey skey- let salt = SignatureSalt (BL.fromStrict (B.replicate 32 0x12))+ let salt = SignatureSalt (B.replicate 32 0x12) hashed = [ SigSubPacket False (SigCreationTime 0) , SigSubPacket@@ -3285,6 +3664,7 @@ keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp)) sigPayload <- case signDataWithEd25519V6+ SHA512 KeyRevocationSig salt edSecretKey@@ -3337,7 +3717,7 @@ edSecretKey <- extractEd25519SecretKey skey let uid = UserId "v6 Fixture User" uidText = let UserId t = uid in t- salt = SignatureSalt (BL.fromStrict (B.replicate 32 0x34))+ salt = SignatureSalt (B.replicate 32 0x34) hashed = [ SigSubPacket False (SigCreationTime 0) , SigSubPacket False (PrimaryUserId True)@@ -3355,6 +3735,7 @@ payload = payloadForSig GenericCert state sigPayload <- case signDataWithEd25519V6+ SHA512 GenericCert salt edSecretKey
tests/Tests/Properties.hs view
@@ -11,6 +11,7 @@ import Control.Lens (preview) import Data.Binary (get, put) import Data.Binary.Put (runPut)+import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Conduit as DC import qualified Data.Conduit.List as CL@@ -27,12 +28,13 @@ ) import Codec.Encryption.OpenPGP.Policy ( OpenPGPPolicy (..)- , OpenPGPRFC (RFC4880)+ , OpenPGPRFC (..)+ , SecretKeyProtectionPolicy (..) , defaultPolicy , policyForRFC ) import Codec.Encryption.OpenPGP.SecretKey- ( decryptPrivateKey+ ( decryptSecretKeyAddendum , encryptSecretKeyWithPolicy ) import Codec.Encryption.OpenPGP.Serialize@@ -50,7 +52,7 @@ , readFixtureLazy , reorderPrecedingPKESKs , reverseIf- , runGet+ , runGetTest , selectRecipientKeyInfo ) @@ -63,17 +65,17 @@ "(checked by QuickCheck)" [ QC.testProperty "PKESKv3 packet serialization-deserialization" $ \pkesk -> Right (pkesk :: PKESK 'PKESKV3)- == runGet get (runPut (put pkesk))+ == runGetTest get (runPut (put pkesk)) , QC.testProperty "PKESKv6 packet serialization-deserialization" $ \pkesk -> Right (pkesk :: PKESK 'PKESKV6)- == runGet get (runPut (put pkesk))+ == runGetTest get (runPut (put pkesk)) , QC.testProperty "Signature packet serialization-deserialization" $ \sig -> ( isNothing (preview _SigVOther (_signaturePayload (sig :: Signature))) )- QC.==> Right (sig :: Signature) == runGet get (runPut (put sig))+ QC.==> Right (sig :: Signature) == runGetTest get (runPut (put sig)) , QC.testProperty "UserId packet serialization-deserialization" $ \uid ->- Right (uid :: UserId) == runGet get (runPut (put uid))+ Right (uid :: UserId) == runGetTest get (runPut (put uid)) , QC.testProperty "decryptPrivateKey (encryptPrivateKey sk pw) pw equivalence" $ \passphraseNE ->@@ -83,7 +85,9 @@ Left err -> pure (QC.counterexample err False) Right (pkp, _ska, expectedSKey) -> do let passphraseChars = (QC.getNonEmpty passphraseNE :: String)- passphrase = BL.pack (map (fromIntegral . fromEnum) passphraseChars)+ passphrase =+ BL.toStrict+ (BL.pack (map (fromIntegral . fromEnum) passphraseChars)) encryptedResult <- encryptSecretKeyWithPolicy defaultPolicy@@ -97,16 +101,18 @@ ("encryptPrivateKey failed: " ++ show err) False Right encryptedSKA ->- case decryptPrivateKey (pkp, encryptedSKA) passphrase of+ case decryptSecretKeyAddendum pkp encryptedSKA (Passphrase passphrase) of Left err ->- QC.counterexample ("decryptPrivateKey failed: " ++ err) False- Right (SUUnencrypted skey _) -> QC.counterexample+ ("decryptSecretKeyAddendum failed: " ++ show err)+ False+ Right (skey, SUSUnprotected _ _) ->+ QC.counterexample "secret key material changed across encrypt/decrypt roundtrip" (skey == expectedSKey) Right other -> QC.counterexample- ( "expected SUUnencrypted after decrypting encrypted key, got: "+ ( "expected SUSUnprotected after decrypting encrypted key, got: " ++ show other ) False@@ -124,14 +130,26 @@ legacyOverridePolicy = (policyForRFC RFC4880) { policySecretKeyProtection =- policySecretKeyProtection defaultPolicy+ Just+ SecretKeyProtectionPolicy+ { secretKeyDefaultSymmetricAlgorithm = AES256+ , secretKeyDefaultAEADAlgorithm = OCB+ , secretKeyDefaultS2KForSalt =+ \salt ->+ IteratedSalted+ SHA512+ (Salt8 (B.take 8 (unSalt salt)))+ (IterationCount 65536)+ , secretKeyS2KSaltOctets = 8+ , secretKeyAEADNonceOctets = 16+ } } encryptedResult <- encryptSecretKeyWithPolicy legacyOverridePolicy pkp expectedSKey- (Passphrase passphrase)+ passphrase pure $ case encryptedResult of Left err ->@@ -141,16 +159,18 @@ ) False Right encryptedSKA ->- case decryptPrivateKey (pkp, encryptedSKA) passphrase of+ case decryptSecretKeyAddendum pkp encryptedSKA passphrase of Left err ->- QC.counterexample ("decryptPrivateKey failed: " ++ err) False- Right (SUUnencrypted skey _) -> QC.counterexample+ ("decryptSecretKeyAddendum failed: " ++ show err)+ False+ Right (skey, SUSUnprotected _ _) ->+ QC.counterexample "v4 secret key material changed across encrypt/decrypt roundtrip" (skey == expectedSKey) Right other -> QC.counterexample- ( "expected SUUnencrypted after decrypting v4 encrypted key, got: "+ ( "expected SUSUnprotected after decrypting v4 encrypted key, got: " ++ show other ) False@@ -190,9 +210,9 @@ where targetLen = if useV6 then 32 else 20 versionOctet = if useV6 then 0x06 else 0x04- ridBody = BL.pack (take targetLen (seedBytes ++ repeat 0x00))+ ridBody = B.pack (take targetLen (seedBytes ++ repeat 0x00)) rid- | prefixed = BL.cons versionOctet ridBody+ | prefixed = B.cons versionOctet ridBody | otherwise = ridBody payload = PKESKPayloadV6Packet (PKESKPayloadV6 rid RSA "esk") @@ -321,7 +341,7 @@ keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase let messagePackets = transformPackets messagePacketsRaw- passphraseCallback _ = pure BL.empty+ passphraseCallback _ = pure B.empty keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos) decrypted <- DC.runConduitRes $
tests/Tests/Serialization.hs view
@@ -46,6 +46,7 @@ import Codec.Encryption.OpenPGP.Fingerprint ( eightOctetKeyID , fingerprint+ , keyIdFromFingerprint ) import Codec.Encryption.OpenPGP.Internal ( PktStreamContext (..)@@ -78,7 +79,7 @@ , loadArmor , loadV6UnencryptedSecretKeyFixtureForProperty , readFixturePayload- , runGet+ , runGetTest ) extractEd25519SecretKeyFromSKey :: SKey -> IO Ed25519.SecretKey@@ -445,14 +446,14 @@ testSerialization :: FilePath -> Assertion testSerialization fpr = do bs <- readFixturePayload fpr- let firstpass = runGet get bs+ let firstpass = runGetTest get bs case fmap unBlock firstpass of Left _ -> assertFailure $ "First pass failed on " ++ fpr Right [] -> assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing." Right packs -> do let roundtrip = runPut $ put (Block packs)- let secondpass = runGet (get :: Get (Block Pkt)) roundtrip+ let secondpass = runGetTest (get :: Get (Block Pkt)) roundtrip if fmap unBlock secondpass == Right [] then assertFailure $@@ -476,7 +477,7 @@ encoded = runPut (put (Block (map (\p -> p ^. pktWireRep . pktValue) packets)))- case runGet (get :: Get (Block Pkt)) encoded of+ case runGetTest (get :: Get (Block Pkt)) encoded of Left err -> assertFailure $ "TKUnknown " ++ fpr ++ " packet re-parse failed: " ++ err@@ -512,7 +513,7 @@ assertEqual "Argon2 S2K SKESK packet roundtrip" (Right pkt)- (runGet (get :: Get Pkt) encoded)+ (runGetTest (get :: Get Pkt) encoded) testIssuerFingerprintRejectsUnknownVersion :: Assertion testIssuerFingerprintRejectsUnknownVersion = do@@ -522,7 +523,7 @@ putWord8 33 putWord8 5 putByteString (B.replicate 32 0)- case runGet (get :: Get SigSubPacket) encoded of+ case runGetTest (get :: Get SigSubPacket) encoded of Left _ -> pure () Right _ -> assertFailure@@ -554,7 +555,7 @@ putWord32be 0 putWord8 (fromIntegral (fromFVal PKA.Ed25519)) putByteString raw- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right ( PublicKeyPkt ( PKPayload@@ -586,7 +587,7 @@ putWord32be 0 putWord8 (fromIntegral (fromFVal PKA.X25519)) putByteString raw- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right ( PublicSubkeyPkt ( PKPayload@@ -622,7 +623,7 @@ BinarySig EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0))+ (SignatureSalt (B.replicate 32 0)) [ SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 (fingerprint signer))@@ -675,7 +676,7 @@ assertEqual "SEIPD v2 packet roundtrip" (Right pkt)- (runGet (get :: Get Pkt) encoded)+ (runGetTest (get :: Get Pkt) encoded) testSEIPDv2RejectInvalidChunkSize :: Assertion testSEIPDv2RejectInvalidChunkSize = do@@ -689,7 +690,7 @@ putWord8 17 putByteString (B.replicate 32 0) putWord8 0- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> return () other -> assertFailure@@ -699,7 +700,7 @@ testPKESKv6ParsesAsV6WithoutLegacyFallback :: Assertion testPKESKv6ParsesAsV6WithoutLegacyFallback = do- let recipientKeyIdentifier = BL.pack (0x04 : replicate 20 0)+ let recipientKeyIdentifier = B.pack (0x04 : replicate 20 0) esk = "\x00\x00" encoded = runPut $ do@@ -707,10 +708,10 @@ putWord8 26 putWord8 6 putWord8 21- putByteString (BL.toStrict recipientKeyIdentifier)+ putByteString recipientKeyIdentifier putWord8 1- putByteString (BL.toStrict esk)- case runGet (get :: Get Pkt) encoded of+ putByteString esk+ case runGetTest (get :: Get Pkt) encoded of Right ( PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka parsedEsk))@@ -727,16 +728,16 @@ testPKESKv6RejectsInvalidRecipientIdentifierVersion :: Assertion testPKESKv6RejectsInvalidRecipientIdentifierVersion = do- let recipientKeyIdentifier = BL.pack (0x05 : replicate 20 0)+ let recipientKeyIdentifier = B.pack (0x05 : replicate 20 0) encoded = runPut $ do putWord8 0xc1 putWord8 24 putWord8 6 putWord8 21- putByteString (BL.toStrict recipientKeyIdentifier)+ putByteString recipientKeyIdentifier putWord8 1- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> pure () other -> assertFailure@@ -747,16 +748,16 @@ testPKESKv6RejectsRecipientIdentifierLengthVersionMismatch :: Assertion testPKESKv6RejectsRecipientIdentifierLengthVersionMismatch = do- let recipientKeyIdentifier = BL.pack (0x04 : replicate 32 0)+ let recipientKeyIdentifier = B.pack (0x04 : replicate 32 0) encoded = runPut $ do putWord8 0xc1 putWord8 36 putWord8 6 putWord8 33- putByteString (BL.toStrict recipientKeyIdentifier)+ putByteString recipientKeyIdentifier putWord8 1- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> pure () other -> assertFailure@@ -775,7 +776,7 @@ putWord8 1 put (MPI 1) put (MPI 2)- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> pure () other -> assertFailure@@ -793,7 +794,7 @@ putByteString (B.replicate 8 0) putWord8 18 put (MPI 1)- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> pure () other -> assertFailure@@ -811,7 +812,7 @@ putByteString (B.replicate 8 0) putWord8 (fromIntegral (fromFVal X25519)) put (MPI 1)- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> pure () other -> assertFailure@@ -829,8 +830,8 @@ DC..| CL.consume pkt <- case secretPackets of- (SecretKeyPkt pkp (SUUnencrypted sk checksum) : _) ->- pure (SecretKeyPkt pkp (SUUnencrypted sk (checksum `xor` 1)))+ (SecretKeyPkt pkp (SUSUnprotected sk checksum) : _) ->+ pure (SecretKeyPkt pkp (SUSUnprotected sk (checksum `xor` 1))) (SecretKeyPkt _ _ : _) -> assertFailure "unencrypted.seckey did not begin with an unencrypted secret key packet"@@ -840,7 +841,7 @@ "unencrypted.seckey did not begin with a secret key packet" >> fail "expected secret key packet" let encoded = runPut (put pkt)- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> pure () other -> assertFailure@@ -854,14 +855,14 @@ let pkt = SecretKeyPkt (PKPayload V4 0 0 RSA (UnknownPKey BL.empty))- ( SUSSHA1+ ( SUSCFB (OtherSA 0xfe) (IteratedSalted SHA256 (Salt8 "12345678") (IterationCount 65536)) (IV (B.replicate 8 0)) BL.empty ) encoded = runPut (put pkt)- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> pure () other -> assertFailure@@ -888,7 +889,7 @@ putByteString ephemeral putWord8 (fromIntegral (B.length wrappedWithAlgo)) putByteString wrappedWithAlgo- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right ( PKESKPkt ( PKESKPayloadV3Packet@@ -925,7 +926,7 @@ putWord8 32 putByteString (B.replicate 32 0) putWord16be 0- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> return () other -> assertFailure@@ -947,7 +948,7 @@ putByteString (B.replicate 31 0) putByteString (B.replicate 32 0) putWord8 0- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> return () other -> assertFailure@@ -967,7 +968,7 @@ putWord8 1 putByteString (B.replicate 8 0) putWord8 2- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> pure () other -> assertFailure@@ -989,7 +990,7 @@ putByteString (B.replicate 32 0) putByteString (B.replicate 32 0) putWord8 2- case runGet (get :: Get Pkt) encoded of+ case runGetTest (get :: Get Pkt) encoded of Right BrokenPacketPkt {} -> pure () other -> assertFailure@@ -1040,7 +1041,7 @@ ) pure (setStrictByteAt (B.length encoded - 4) 0x00 encoded)- case runGet (get :: Get Pkt) (BL.fromStrict mutated) of+ case runGetTest (get :: Get Pkt) (BL.fromStrict mutated) of Right BrokenPacketPkt {} -> pure () other -> assertFailure@@ -1059,7 +1060,7 @@ ) pure (setStrictByteAt (B.length encoded - 4) 0xff encoded)- case runGet (get :: Get Pkt) (BL.fromStrict mutated) of+ case runGetTest (get :: Get Pkt) (BL.fromStrict mutated) of Right BrokenPacketPkt {} -> pure () other -> assertFailure@@ -1083,7 +1084,7 @@ "empty key-flags subpacket should encode an explicit zero flags octet" [2, 27, 0] (BL.unpack encoded)- case runGet (get :: Get SigSubPacket) encoded of+ case runGetTest (get :: Get SigSubPacket) encoded of Right (SigSubPacket False (KeyFlags flags)) -> assertEqual "empty key-flags subpacket should decode back to an empty flag set"@@ -1155,7 +1156,7 @@ assertEqual "SigV6 salt size in v6-secret.pgp.aa should match hash algorithm" expected- (fromIntegral (BL.length (unSignatureSalt salt)))+ (fromIntegral (B.length (unSignatureSalt salt))) ) signatures assertBool@@ -1202,7 +1203,15 @@ ("Expected v6 eight-octet key-id derivation to succeed: " ++ err) >> fail "expected v6 eight-octet key-id" Right keyId -> pure keyId- let expectedKeyId = EightOctetKeyId (BL.take 8 (unFingerprint (fingerprint pkp)))+ expectedKeyId <-+ case keyIdFromFingerprint (fingerprint pkp) of+ Left err ->+ assertFailure+ ( "Expected v6 key-id from fingerprint derivation to succeed: "+ ++ err+ )+ >> fail "expected v6 key-id from fingerprint"+ Right keyId -> pure keyId assertEqual "v6 eight-octet key-id should be the high-order 64 bits of the fingerprint" expectedKeyId@@ -1242,7 +1251,7 @@ ++ show ha ) >> fail "expected defined salt size"- Just sz -> pure (SignatureSalt (BL.replicate (fromIntegral sz) 0xAB))+ Just sz -> pure (SignatureSalt (B.replicate (fromIntegral sz) 0xAB)) let hashed = [SigSubPacket False (SigCreationTime 0)] unhashed = [ SigSubPacket@@ -1251,6 +1260,7 @@ ] sigPayload <- case signDataWithEd25519V6+ ha BinarySig salt edSecretKey@@ -1280,4 +1290,6 @@ ++ renderVerificationError err ) Right _ -> pure ()- mapM_ testHash [SHA512]+ mapM_+ testHash+ [SHA224, SHA256, SHA384, SHA512, SHA3_256, SHA3_512]
tests/Tests/Utilities.hs view
@@ -78,7 +78,7 @@ , loadV6UnencryptedSecretKeyFixtureForProperty , readFixtureLazy , readFixturePackets- , runGet+ , runGetTest , setKeyTimestamp , signCertificationAt , signSubkeyBindingWithRSAExtrasAt@@ -204,7 +204,7 @@ testEightOctetKeyIdReadShowRoundtrip = do let eoki = EightOctetKeyId- (BL.pack [0x01, 0x23, 0x45, 0x67, 0x89, 0xab, 0xcd, 0xef])+ (B.pack [0x01, 0x23, 0x45, 0x67, 0x89, 0xab, 0xcd, 0xef]) assertEqual "show prints canonical uppercase hex" "0123456789ABCDEF"@@ -393,7 +393,7 @@ afterTime = timestampToUTCTime (addTimestampSeconds baseTime 24) uidText = "auth-subkeys@example.org" uid = UserId uidText- secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0+ secretAddendum = SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer expiringAuthSubkey = setKeyTimestamp (addTimestampSeconds baseTime 2) signer signingOnlySubkey = setKeyTimestamp (addTimestampSeconds baseTime 3) signer@@ -526,7 +526,7 @@ UserId uidAText = uidA uidB = UserId "uid-b@example.org" UserId uidBText = uidB- secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0+ secretAddendum = SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer uidACert <-@@ -634,7 +634,7 @@ afterTime = timestampToUTCTime (addTimestampSeconds baseTime 24) uidText = "auth-subkeys@example.org" uid = UserId uidText- secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0+ secretAddendum = SUSUnprotected (RSAPrivateKey (RSA_PrivateKey signingKey)) 0 authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer expiringAuthSubkey = setKeyTimestamp (addTimestampSeconds baseTime 2) signer signingOnlySubkey = setKeyTimestamp (addTimestampSeconds baseTime 3) signer@@ -884,7 +884,7 @@ assertEqual "packet raw bytes round-trip back to the same packet" (Right (pkt ^. pktWireRep . pktValue))- (runGet (get :: Get Pkt) (pkt ^. pktWireRep . pktRaw))+ (runGetTest (get :: Get Pkt) (pkt ^. pktWireRep . pktRaw)) assertEqual "packet source reference is preserved" src@@ -1614,7 +1614,7 @@ GenericCert EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x01))+ (SignatureSalt (B.replicate 32 0x01)) [] [] 0@@ -1650,7 +1650,7 @@ KeyRevocationSig EdDSALegacy SHA512- (SignatureSalt (BL.replicate 32 0x02))+ (SignatureSalt (B.replicate 32 0x02)) [] [] 0