diff --git a/Codec/Encryption/OpenPGP/Arbitrary.hs b/Codec/Encryption/OpenPGP/Arbitrary.hs --- a/Codec/Encryption/OpenPGP/Arbitrary.hs +++ b/Codec/Encryption/OpenPGP/Arbitrary.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Encrypt.hs b/Codec/Encryption/OpenPGP/Encrypt.hs --- a/Codec/Encryption/OpenPGP/Encrypt.hs +++ b/Codec/Encryption/OpenPGP/Encrypt.hs @@ -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] diff --git a/Codec/Encryption/OpenPGP/Fingerprint.hs b/Codec/Encryption/OpenPGP/Fingerprint.hs --- a/Codec/Encryption/OpenPGP/Fingerprint.hs +++ b/Codec/Encryption/OpenPGP/Fingerprint.hs @@ -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) diff --git a/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs b/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs --- a/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs +++ b/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/KeyGeneration.hs b/Codec/Encryption/OpenPGP/KeyGeneration.hs --- a/Codec/Encryption/OpenPGP/KeyGeneration.hs +++ b/Codec/Encryption/OpenPGP/KeyGeneration.hs @@ -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 +-- ----------------------------------------------------------------------------- diff --git a/Codec/Encryption/OpenPGP/KeySelection.hs b/Codec/Encryption/OpenPGP/KeySelection.hs --- a/Codec/Encryption/OpenPGP/KeySelection.hs +++ b/Codec/Encryption/OpenPGP/KeySelection.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Message.hs b/Codec/Encryption/OpenPGP/Message.hs --- a/Codec/Encryption/OpenPGP/Message.hs +++ b/Codec/Encryption/OpenPGP/Message.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/S2K.hs b/Codec/Encryption/OpenPGP/S2K.hs --- a/Codec/Encryption/OpenPGP/S2K.hs +++ b/Codec/Encryption/OpenPGP/S2K.hs @@ -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')) diff --git a/Codec/Encryption/OpenPGP/SecretKey.hs b/Codec/Encryption/OpenPGP/SecretKey.hs --- a/Codec/Encryption/OpenPGP/SecretKey.hs +++ b/Codec/Encryption/OpenPGP/SecretKey.hs @@ -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 <- diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/SerializeForSigs.hs b/Codec/Encryption/OpenPGP/SerializeForSigs.hs --- a/Codec/Encryption/OpenPGP/SerializeForSigs.hs +++ b/Codec/Encryption/OpenPGP/SerializeForSigs.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Signatures.hs b/Codec/Encryption/OpenPGP/Signatures.hs --- a/Codec/Encryption/OpenPGP/Signatures.hs +++ b/Codec/Encryption/OpenPGP/Signatures.hs @@ -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) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs @@ -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) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs b/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs @@ -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 "" <+> 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 "" + <+> 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 "" <+> pretty (bsToHexUpper bs) + <+> prettyBS (convertToBase Base64 bs) + pretty (UnknownSKey bs) = + pretty "" + <+> 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 diff --git a/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs b/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs @@ -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) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs @@ -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) = diff --git a/Data/Conduit/OpenPGP/Decrypt.hs b/Data/Conduit/OpenPGP/Decrypt.hs --- a/Data/Conduit/OpenPGP/Decrypt.hs +++ b/Data/Conduit/OpenPGP/Decrypt.hs @@ -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) diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -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 diff --git a/tests/Tests/Common.hs b/tests/Tests/Common.hs --- a/tests/Tests/Common.hs +++ b/tests/Tests/Common.hs @@ -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) diff --git a/tests/Tests/Encryption.hs b/tests/Tests/Encryption.hs --- a/tests/Tests/Encryption.hs +++ b/tests/Tests/Encryption.hs @@ -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 diff --git a/tests/Tests/KeyGeneration.hs b/tests/Tests/KeyGeneration.hs --- a/tests/Tests/KeyGeneration.hs +++ b/tests/Tests/KeyGeneration.hs @@ -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 " + 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 diff --git a/tests/Tests/Keys.hs b/tests/Tests/Keys.hs --- a/tests/Tests/Keys.hs +++ b/tests/Tests/Keys.hs @@ -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 diff --git a/tests/Tests/MessageAndArmor.hs b/tests/Tests/MessageAndArmor.hs --- a/tests/Tests/MessageAndArmor.hs +++ b/tests/Tests/MessageAndArmor.hs @@ -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 diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs --- a/tests/Tests/Properties.hs +++ b/tests/Tests/Properties.hs @@ -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 $ diff --git a/tests/Tests/Serialization.hs b/tests/Tests/Serialization.hs --- a/tests/Tests/Serialization.hs +++ b/tests/Tests/Serialization.hs @@ -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] diff --git a/tests/Tests/Utilities.hs b/tests/Tests/Utilities.hs --- a/tests/Tests/Utilities.hs +++ b/tests/Tests/Utilities.hs @@ -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