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 @@ -382,7 +382,7 @@ return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid)) getNotationData :: SigSubPacketParser -getNotationData _pt crit l = do +getNotationData _pt crit _l = do flags <- getLazyByteString 4 nl <- getWord16be vl <- getWord16be @@ -562,7 +562,7 @@ IssuerFingerprint kv fp -> putIssuerFingerprint crit kv fp IntendedRecipient kv irf -> putIntendedRecipient crit kv irf PreferredAEADCiphersuites ps -> putPreferredAEADCiphersuites crit ps - UserDefinedSigSub ptype payload -> putOtherSigSub crit ptype payload + UserDefinedSigSub subtype payload -> putOtherSigSub crit subtype payload OtherSigSub ptype payload -> putOtherSigSub crit ptype payload putSigCreationTime :: Bool -> ThirtyTwoBitTimeStamp -> Put @@ -869,31 +869,6 @@ `BL.append` BL.pack [t, p, encodedM] fromS2K (OtherS2K _ bs) = bs -getPacketLength :: Get Integer -getPacketLength = do - firstOctet <- getWord8 - lenOrPartial <- lengthOctetToLength firstOctet - case lenOrPartial of - Left _ -> - fail "Partial body length is invalid in this context" - Right len -> return len - where - lengthOctetToLength :: Word8 -> Get (Either Integer Integer) - lengthOctetToLength f - | f < 192 = return . Right . fromIntegral $ f - | f < 224 = do - secondOctet <- getWord8 - return . Right . fromIntegral $ - shiftL (fromIntegral (f - 192) :: Int) 8 - + (fromIntegral secondOctet :: Int) - + 192 - | f < 255 = - return . Left . fromIntegral $ - (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f) - | otherwise = do - len <- getWord32be - return . Right . fromIntegral $ len - putPacketLength :: Integer -> Put putPacketLength l | l < 192 = putWord8 (fromIntegral l) @@ -1252,7 +1227,7 @@ 2 -> SignaturePkt <$> get 3 -> getSKESK 4 -> getOPS - 5 -> getSecretKey len + 5 -> getSecretKeyPkt len 6 -> PublicKeyPkt <$> getPKPayload 7 -> getSecretSubkey len 8 -> getCompressedData len @@ -1390,7 +1365,7 @@ -> HashAlgorithm -> PubKeyAlgorithm -> Get Pkt - getOPSV6 pv sigtype ha pka = do + getOPSV6 _pv sigtype ha pka = do saltSize <- getWord8 expectedSaltSize <- maybe @@ -1427,8 +1402,8 @@ ) ) - getSecretKey :: ByteOffset -> Get Pkt - getSecretKey len = do + getSecretKeyPkt :: ByteOffset -> Get Pkt + getSecretKeyPkt len = do bs <- getLazyByteString len case runGetOrFail getSecretKeyParser bs of Left (_, _, err) -> fail ("secret key " ++ err) @@ -2195,31 +2170,39 @@ putPubkey (MLDSAPubKey bs) = putLazyByteString (BL.fromStrict bs) putPubkey (SLHDSAPubKey bs) = putLazyByteString (BL.fromStrict bs) putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) = - let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) - in putCurveOID curveoidbs - >> mapM_ put (pubkeyToMPIs p) + case curveToCurveoidBS (curveFromCurve curve) of + Right curveoidbs -> + putCurveOID curveoidbs + >> mapM_ put (pubkeyToMPIs p) + Left err -> error err putPubkey p@( ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) kha ksa ) = - let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve) - in putCurveOID curveoidbs + case curveToCurveoidBS (curveFromCurve curve) of + Right curveoidbs -> + putCurveOID curveoidbs + >> mapM_ put (pubkeyToMPIs p) + >> putECDHKDFParams kha ksa + Left err -> error err +putPubkey p@(ECDHPubKey (EdDSAPubKey curve (PrefixedNativeEPoint _)) kha ksa) = + case curveToCurveoidBS (ed2ec curve) of + Right curveoidbs -> + putCurveOID curveoidbs >> mapM_ put (pubkeyToMPIs p) >> putECDHKDFParams kha ksa -putPubkey p@(ECDHPubKey (EdDSAPubKey curve (PrefixedNativeEPoint _)) kha ksa) = - let Right curveoidbs = curveToCurveoidBS (ed2ec curve) - in putCurveOID curveoidbs - >> mapM_ put (pubkeyToMPIs p) - >> putECDHKDFParams kha ksa + Left err -> error err where ed2ec P.EdSigningCurve25519 = Curve25519 ed2ec P.EdSigningCurve448 = Curve448 putPubkey p@(EdDSAPubKey curve (PrefixedNativeEPoint _)) = - let Right curveoidbs = edSigningCurveToCurveoidBS curve - in putCurveOID curveoidbs - >> mapM_ put (pubkeyToMPIs p) + case edSigningCurveToCurveoidBS curve of + Right curveoidbs -> + putCurveOID curveoidbs + >> mapM_ put (pubkeyToMPIs p) + Left err -> error err putPubkey (ECDHPubKey (EdDSAPubKey curve (NativeEPoint _)) _ _) = error ( "legacy ECDH serialization requires a prefixed-native " diff --git a/bench/mark.hs b/bench/mark.hs --- a/bench/mark.hs +++ b/bench/mark.hs @@ -13,7 +13,7 @@ import Data.Conduit.Serialization.Binary (conduitGet) import Data.Either (rights) import qualified Data.IxSet.Typed as IxSet -import Data.Maybe (catMaybes) +import Data.Maybe (catMaybes, mapMaybe) import Codec.Encryption.OpenPGP.Policy ( defaultVerificationPolicy @@ -29,15 +29,15 @@ , verifyAgainstKeys , verifySigWith , verifyTKWith - , verifyUnknownTKWith ) import Codec.Encryption.OpenPGP.Types - ( someTKToPublicViewTK + ( someTKToPublicTK + , someTKToPublicViewTK , wireRepRef ) import Data.Conduit.OpenPGP.Keyring - ( conduitToSomeTKsEither - , conduitToTKsEither + ( conduitDropErrorsAndNothings + , conduitToSomeTKsEither ) main :: IO () @@ -81,11 +81,12 @@ where loadKeys fp = fmap - (catMaybes . rights) + (mapMaybe someTKToPublicTK) ( DC.runConduitRes $ CB.sourceFile fp DC..| conduitGet get - DC..| conduitToTKsEither + DC..| conduitToSomeTKsEither + DC..| conduitDropErrorsAndNothings DC..| CL.consume ) loadKeyring fp = @@ -101,7 +102,7 @@ fmap ( \ks -> mapM - ( verifyUnknownTKWith + ( verifyTKWith (verifySigWith defaultVerificationPolicy (verifyAgainstKeys ks)) Nothing ) 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.2 +Version: 3.2.0.1 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 @@ -334,4 +334,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git - tag: v3.2 + tag: v3.2.0.1 diff --git a/tests/Tests/Encryption.hs b/tests/Tests/Encryption.hs --- a/tests/Tests/Encryption.hs +++ b/tests/Tests/Encryption.hs @@ -3,7 +3,9 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Tests.Encryption (encryptionAndCompressionTests) where @@ -42,7 +44,6 @@ import Data.List (find, isInfixOf) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -import Data.Maybe (listToMaybe) import qualified Data.Set as Set import Data.Word (Word16) import Test.Tasty (TestTree, testGroup) @@ -65,7 +66,7 @@ , decompressPkt ) import Codec.Encryption.OpenPGP.Encrypt - ( EncryptCompatibilityProfile (..) + ( EncryptCompatibilityProfileW (..) , PKESKEncryptError ( InvalidRecipientIdentifier , InvalidRecipientKeyMaterial @@ -92,9 +93,11 @@ , RecipientEncryptionTargetRejected (..) , RecipientEncryptionTargetsReport (..) , RecipientPKESKVersionStrategy (..) + , RecipientPKESKVersionStrategyW (..) , RecipientPayloadShape (..) , RecipientTargetRejectionReason (..) , RecipientTargetSelectionPolicy (..) + , SomeRecipientPKESKVersionStrategyW (..) , buildPKESKPayloadForRecipient , buildPKESKv3PayloadForRecipient , canonicalizePKESKRecipientId @@ -108,15 +111,13 @@ , pkeskV3SessionMaterial , recipientCapabilitiesFromSubpacketPayloads , recipientEncryptionTarget - , recipientEncryptionTargetFromTK - , recipientEncryptionTargetFromTKAtTimestamp , recipientEncryptionTargetFromTKAtTimestampWithPolicy + , recipientEncryptionTargetFromTKWithPolicy , recipientEncryptionTargetWithCapabilities - , recipientEncryptionTargetWithStrategy - , recipientEncryptionTargetsFromTK + , recipientEncryptionTargetWithStrategyTyped , recipientEncryptionTargetsFromTKAtTimestamp , recipientEncryptionTargetsReportFromTKAtTimestamp - , recipientVersionStrategyForProfile + , recipientVersionStrategyForProfileTyped ) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.Internal (point2MBS) @@ -1185,107 +1186,6 @@ fakeCallback :: BL.ByteString -> String -> IO BL.ByteString fakeCallback = const . return --- | Decrypt a file and check the 'DecryptOutcome'. -testDecryptOutcome - :: FilePath -> FilePath -> DecryptOutcome -> Assertion -testDecryptOutcome encfile passfile expectedOutcome = do - passphrase <- readFixtureLazy passfile - pt <- readFixturePackets encfile - (outcome, _pkts) <- - catch - ( DC.runConduitRes $ - CL.sourceList pt - DC..| fuseBoth - (conduitDecryptChecked (fakeCallback passphrase)) - CL.consume - ) - ( \e -> do - let err = show (e :: SomeException) - assertFailure ("decryption threw unexpected exception: " ++ err) - fail "unreachable" - ) - assertEqual - ("DecryptOutcome for " ++ encfile) - expectedOutcome - outcome - where - fakeCallback :: BL.ByteString -> String -> IO BL.ByteString - fakeCallback = const . return - -{- | Build a synthetic packet list with an appended trailing packet, decrypt -with lenient policy, and verify 'DecryptTrailingData' is reported. --} -testTrailingDataReportedLenient - :: FilePath -> FilePath -> Assertion -testTrailingDataReportedLenient encfile passfile = do - passphrase <- readFixtureLazy passfile - pt <- readFixturePackets encfile - let trailingPkt = OtherPacketPkt 0xFE "" - ptWithTrailing = pt ++ [trailingPkt] - (outcome, _pkts) <- - catch - ( DC.runConduitRes $ - CL.sourceList ptWithTrailing - DC..| fuseBoth - ( conduitDecryptCheckedWithDecryptPolicy - lenientDecryptPolicy - (\_ -> pure Nothing) - (fakeCallback passphrase) - ) - CL.consume - ) - ( \e -> do - let err = show (e :: SomeException) - assertFailure - ("lenient decrypt threw unexpected exception: " ++ err) - fail "unreachable" - ) - assertEqual - ("DecryptTrailingData for " ++ encfile) - DecryptTrailingData - outcome - where - fakeCallback :: BL.ByteString -> String -> IO BL.ByteString - fakeCallback = const . return - -{- | Same as above but with strict policy: should throw "after message -integrity boundary". --} -testTrailingDataRejectedStrict - :: FilePath -> FilePath -> Assertion -testTrailingDataRejectedStrict encfile passfile = do - passphrase <- readFixtureLazy passfile - pt <- readFixturePackets encfile - let trailingPkt = OtherPacketPkt 0xFE "" - ptWithTrailing = pt ++ [trailingPkt] - result <- - try - ( DC.runConduitRes $ - CL.sourceList ptWithTrailing - DC..| fuseBoth - (conduitDecryptChecked (fakeCallback passphrase)) - CL.consume - ) - :: IO (Either SomeException (DecryptOutcome, [Pkt])) - case result of - Left err -> - assertFailure - ( "Expected DecryptMalformedStructure but got exception: " - ++ show err - ) - Right (DecryptMalformedStructure malformedReason, _) -> - assertBool - ( "Expected 'after message integrity boundary', got: " - ++ malformedReason - ) - ("after message integrity boundary" `isInfixOf` malformedReason) - Right (other, _) -> - assertFailure - ("Expected DecryptMalformedStructure but got: " ++ show other) - where - fakeCallback :: BL.ByteString -> String -> IO BL.ByteString - fakeCallback = const . return - encryptedSEIPDv2Packets :: IO [Pkt] encryptedSEIPDv2Packets = do let passphrase = @@ -2573,44 +2473,62 @@ testRecipientVersionStrategyForProfileHonorsHints = do (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner let recipient = setKeyVersion V6 baseRecipient - case recipientVersionStrategyForProfile - EncryptStrictDefault - ( recipientEncryptionTargetWithStrategy + case recipientVersionStrategyForProfileTyped + EncryptStrictDefaultW + ( recipientEncryptionTargetWithStrategyTyped recipient - RecipientForceV3Interop + RecipientForceV3InteropW ) of - Right RecipientForceV3Interop -> pure () - other -> + Right strategyW -> + case strategyW of + SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW -> pure () + _ -> + assertFailure + "Expected explicit recipient hint to win, got Right (non-ForceV3Interop strategy)" + >> return () + _ -> assertFailure - ("Expected explicit recipient hint to win, got " ++ show other) - case recipientVersionStrategyForProfile - EncryptInteropLegacy + "Expected explicit recipient hint to win, got non-Right result" + case recipientVersionStrategyForProfileTyped + EncryptInteropLegacyW (recipientEncryptionTarget recipient) of - Right RecipientForceV3Interop -> pure () - other -> + Right strategyW -> + case strategyW of + SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW -> pure () + _ -> + assertFailure + "Expected legacy profile fallback to force v3, got Right (non-ForceV3Interop strategy)" + >> return () + _ -> assertFailure - ( "Expected legacy profile fallback to force v3, got " - ++ show other - ) + "Expected legacy profile fallback to force v3, got non-Right result" let v4Recipient = setKeyVersion V4 recipient - case recipientVersionStrategyForProfile - EncryptStrictDefault + case recipientVersionStrategyForProfileTyped + EncryptStrictDefaultW (recipientEncryptionTarget recipient) of - Right RecipientPreferV6 -> pure () - other -> + Right strategyW -> + case strategyW of + SomeRecipientPKESKVersionStrategyW RecipientPreferV6W -> pure () + _ -> + assertFailure + "Expected strict profile auto-detect to prefer v6 for v6 recipients, got Right (non-PreferV6 strategy)" + >> return () + _ -> assertFailure - ( "Expected strict profile auto-detect to prefer v6 for v6 recipients, got " - ++ show other - ) - case recipientVersionStrategyForProfile - EncryptStrictDefault + "Expected strict profile auto-detect to prefer v6 for v6 recipients, got non-Right result" + case recipientVersionStrategyForProfileTyped + EncryptStrictDefaultW (recipientEncryptionTarget v4Recipient) of - Right RecipientForceV3Interop -> pure () - other -> + Right strategyW -> + case strategyW of + SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW -> pure () + _ -> + assertFailure + "Expected strict profile auto-detect to force v3 for legacy recipients, got Right (non-ForceV3Interop strategy)" + >> return () + _ -> assertFailure - ( "Expected strict profile auto-detect to force v3 for legacy recipients, got " - ++ show other - ) + "Expected strict profile auto-detect to force v3 for legacy recipients, got non-Right result" testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies :: Assertion @@ -3171,7 +3089,10 @@ } encryptingSubkey = setKeyTimestamp (_timestamp signingPrimary) baseEncryptingSubkey - targets = recipientEncryptionTargetsFromTK tk + targets = + recipientEncryptionTargetsFromTKAtTimestamp + (_timestamp (keyPktPKPayload (_tkPrimaryKey tk))) + tk assertEqual "TKUnknown-derived targets should include only encryption-capable keys" 1 @@ -3191,15 +3112,18 @@ (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner let primary = setKeyVersion V4 baseRecipient subkey = setKeyVersion V6 baseRecipient - tk = - TK - { _tkPrimaryKey = KeyPktPublicPrimary primary - , _tkRevs = [] - , _tkUIDs = [] - , _tkUAts = [] - , _tkSubs = [(KeyPktPublicSubkey subkey, [])] - } - case recipientEncryptionTargetFromTK tk of + tk + :: TK 'PublicTK = + TK + { _tkPrimaryKey = KeyPktPublicPrimary primary + , _tkRevs = [] + , _tkUIDs = [] + , _tkUAts = [] + , _tkSubs = [(KeyPktPublicSubkey subkey, [])] + } + case recipientEncryptionTargetFromTKWithPolicy + RecipientTargetSelectionFirstValid + tk of Right target -> assertEqual "TKUnknown-derived single target should prioritize encryption subkeys" @@ -3215,15 +3139,18 @@ :: Assertion testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys = do (signingPrimary, _signingKey) <- loadDeterministicEd25519Signer - let tk = - TK - { _tkPrimaryKey = KeyPktPublicPrimary signingPrimary - , _tkRevs = [] - , _tkUIDs = [] - , _tkUAts = [] - , _tkSubs = [] - } - case recipientEncryptionTargetFromTK tk of + let tk + :: TK 'PublicTK = + TK + { _tkPrimaryKey = KeyPktPublicPrimary signingPrimary + , _tkRevs = [] + , _tkUIDs = [] + , _tkUAts = [] + , _tkSubs = [] + } + case recipientEncryptionTargetFromTKWithPolicy + RecipientTargetSelectionFirstValid + tk of Left RecipientCapabilityNoEncryptableKeyMaterialInTK -> pure () Left other -> assertFailure @@ -3470,7 +3397,10 @@ , _tkUAts = [] , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])] } - case recipientEncryptionTargetFromTKAtTimestamp beforeSignature tk of + case recipientEncryptionTargetFromTKAtTimestampWithPolicy + RecipientTargetSelectionFirstValid + beforeSignature + tk of Left err -> assertFailure ( "Expected timestamp-scoped TKUnknown target selection to succeed, got " @@ -4192,13 +4122,6 @@ testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform "seipdv2-three-recipients.pgp.aa" (prependUnusableLatestPKESK . reorderPrecedingPKESKs) - -testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFile - :: FilePath -> Assertion -testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFile fixture = - testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform - fixture - id testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform :: FilePath 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,6 @@ ) import Codec.Encryption.OpenPGP.SecretKey ( SecretKeyEncryptOptions (..) - , changePrivateKeyPassphrase - , changeSecretKeyPassphrase , decryptPrivateKey , decryptSecretKey , decryptSecretKeyAddendum @@ -1656,20 +1654,26 @@ assertFailure "original legacy key should decrypt to unencrypted secret material" >> fail "expected unencrypted secret key" + encryptedResult <- + reencryptSecretKey + (SecretKey pkp ska) + (Passphrase passphrase) + (Passphrase "changed-pki-password") + SecretKeyEncryptOptions + { skeoPolicy = defaultPolicy + , skeoGenerateSaltAndIV = False + , skeoSalt = Just (Salt "12345678") + , skeoIV = Just (IV "1234567890ABCDEF") + } changed <- - case changePrivateKeyPassphrase - (pkp, ska) - passphrase - (Salt "12345678") - (IV "1234567890ABCDEF") - "changed-pki-password" of + case encryptedResult of Left err -> assertFailure ( "legacy passphrase change should preserve the existing protection envelope, got: " - ++ err + ++ show err ) >> fail "legacy passphrase change failed" - Right skaddendum -> pure skaddendum + Right sk -> pure (_secretKeySKAddendum sk) originalIterCount <- case ska of SUSSHA1 AES256 (IteratedSalted SHA512 _ iter) _ _ -> pure iter @@ -1739,19 +1743,23 @@ assertFailure "original v6 key should decrypt to unencrypted secret material" >> fail "expected unencrypted secret key" - let changedResult = - changePrivateKeyPassphrase - (pkp, ska) - oldPassphrase - (Salt "1234567890ABCDEF") - (IV "1234567890ABCDE") - newPassphrase + changedResult <- + reencryptSecretKey + (SecretKey pkp ska) + (Passphrase oldPassphrase) + (Passphrase newPassphrase) + SecretKeyEncryptOptions + { skeoPolicy = defaultPolicy + , skeoGenerateSaltAndIV = False + , skeoSalt = Just (Salt "1234567890ABCDEF") + , skeoIV = Just (IV "1234567890ABCDE") + } changed <- case changedResult of Left err -> - assertFailure ("changing v6 key passphrase failed: " ++ err) + assertFailure ("changing v6 key passphrase failed: " ++ show err) >> pure ska - Right skaddendum -> pure skaddendum + Right sk -> pure (_secretKeySKAddendum sk) case changed of SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do assertEqual @@ -2482,10 +2490,16 @@ "v6-encrypted-secret.pgp.aa did not begin with a secret key packet" >> fail "expected secret key packet" result <- - changeSecretKeyPassphrase + reencryptSecretKey (SecretKey pkp ska) (Passphrase oldPassphrase) (Passphrase "changed-pki-password") + SecretKeyEncryptOptions + { skeoPolicy = defaultPolicy + , skeoGenerateSaltAndIV = True + , skeoSalt = Nothing + , skeoIV = Nothing + } changed <- case result of Left err -> diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs --- a/tests/Tests/Properties.hs +++ b/tests/Tests/Properties.hs @@ -33,7 +33,7 @@ ) import Codec.Encryption.OpenPGP.SecretKey ( decryptPrivateKey - , encryptPrivateKey + , encryptSecretKeyWithPolicy ) import Codec.Encryption.OpenPGP.Serialize ( parsePktsEither @@ -81,15 +81,21 @@ fixture <- loadV6UnencryptedSecretKeyFixtureForProperty case fixture of Left err -> pure (QC.counterexample err False) - Right (pkp, ska, expectedSKey) -> do + Right (pkp, _ska, expectedSKey) -> do let passphraseChars = (QC.getNonEmpty passphraseNE :: String) passphrase = BL.pack (map (fromIntegral . fromEnum) passphraseChars) encryptedResult <- - encryptPrivateKey defaultPolicy pkp ska passphrase + encryptSecretKeyWithPolicy + defaultPolicy + pkp + expectedSKey + (Passphrase passphrase) pure $ case encryptedResult of Left err -> - QC.counterexample ("encryptPrivateKey failed: " ++ err) False + QC.counterexample + ("encryptPrivateKey failed: " ++ show err) + False Right encryptedSKA -> case decryptPrivateKey (pkp, encryptedSKA) passphrase of Left err -> @@ -113,7 +119,7 @@ fixture <- loadV4EncryptedSecretKeyFixtureForProperty case fixture of Left err -> pure (QC.counterexample err False) - Right (pkp, ska, expectedSKey, passphrase) -> do + Right (pkp, _ska, expectedSKey, passphrase) -> do let legacyOverridePolicy :: OpenPGPPolicy legacyOverridePolicy = (policyForRFC RFC4880) @@ -121,12 +127,18 @@ policySecretKeyProtection defaultPolicy } encryptedResult <- - encryptPrivateKey legacyOverridePolicy pkp ska passphrase + encryptSecretKeyWithPolicy + legacyOverridePolicy + pkp + expectedSKey + (Passphrase passphrase) pure $ case encryptedResult of Left err -> QC.counterexample - ("encryptPrivateKey failed under legacy override policy: " ++ err) + ( "encryptPrivateKey failed under legacy override policy: " + ++ show err + ) False Right encryptedSKA -> case decryptPrivateKey (pkp, encryptedSKA) passphrase of diff --git a/tests/Tests/Utilities.hs b/tests/Tests/Utilities.hs --- a/tests/Tests/Utilities.hs +++ b/tests/Tests/Utilities.hs @@ -40,7 +40,6 @@ , parseTKs , parseTKsEither , parseTKsWithWireRep - , parseUnknownTKs ) import Codec.Encryption.OpenPGP.Serialize ( PktParseError (..) @@ -70,7 +69,6 @@ , conduitToAuthSecretSubkeysAtReport , conduitToSomeTKsDroppingEither , conduitToSomeTKsEither - , conduitToTKsEither , conduitToTKsWithWireRepEither ) import Tests.Common @@ -100,13 +98,13 @@ "parsePktsEither reports truncation errors" (testParsePktsEitherFailureUtil "pubring.gpg") , testCase - "parseUnknownTKs drops disallowed primary-key signature context (v4)" + "parsePublicTKs drops disallowed primary-key signature context (v4)" testParseTKsDropsDisallowedPrimaryKeySigContextV4 , testCase - "parseUnknownTKs drops disallowed primary-key signature context (v6)" + "parsePublicTKs drops disallowed primary-key signature context (v6)" testParseTKsDropsDisallowedPrimaryKeySigContextV6 , testCase - "parseUnknownTKs accepts allowed primary-key signature context (v6)" + "parsePublicTKs accepts allowed primary-key signature context (v6)" testParseTKsAcceptsAllowedPrimaryKeySigContextV6 , testCase "pubring as TKs" (testParseTKsUtil "pubring.gpg") , testCase @@ -272,20 +270,20 @@ DC.runConduitRes $ CB.sourceLbs lbs DC..| conduitGet get - DC..| conduitToTKsEither + DC..| conduitToSomeTKsEither DC..| conduitDropErrorsAndNothings DC..| CL.consume - let pt = parseUnknownTKs True . parsePkts $ lbs + let pt = map someTKToUnknown (parseTKs True (parsePkts lbs)) assertEqual "parsePkts utility function gives same results as conduit pipeline" - cp + (map someTKToUnknown cp) pt testParseTKsTypedUtil :: FilePath -> Assertion testParseTKsTypedUtil fn = do lbs <- readFixtureLazy fn let packets = parsePkts lbs - plain = parseUnknownTKs True packets + plain = map someTKToUnknown (parseTKs True packets) typed = parseTKs True packets typedPublic = parsePublicTKs True packets typedSecret = parseSecretTKs True packets @@ -342,8 +340,8 @@ DC..| CL.catMaybes DC..| CL.consume assertEqual - "typed conduit round-trips to parseUnknownTKs semantics" - (parseUnknownTKs True (parsePkts lbs)) + "typed conduit round-trips to parseTKs semantics" + (map someTKToUnknown (parseTKs True (parsePkts lbs))) (map someTKToUnknown allTyped) assertEqual "typed conduit public + secret partitions preserve full count" @@ -850,9 +848,12 @@ packets = parsePktsWithWireRep src srcBytes parsed = parseTKsWithWireRep True packets plain = - parseUnknownTKs - True - (map (\p -> view (pktWireRep . pktValue) p) packets) + map + someTKToUnknown + ( parseTKs + True + (map (\p -> view (pktWireRep . pktValue) p) packets) + ) conduitParsed <- DC.runConduitRes $ CL.sourceList packets @@ -861,7 +862,7 @@ DC..| CL.catMaybes DC..| CL.consume assertEqual - "provenance-aware parseUnknownTKs preserves TKUnknown semantics" + "provenance-aware parseTKs preserves TKUnknown semantics" plain (map _tkValue parsed) assertEqual @@ -1464,7 +1465,10 @@ testTKTypedRoundTripAndPublicView :: Assertion testTKTypedRoundTripAndPublicView = do pubringBytes <- readFixtureLazy "pubring.gpg" - let publicParsed = parseUnknownTKs True (parsePkts pubringBytes) + let publicParsed = + map + someTKToUnknown + (map SomePublicTK (parsePublicTKs True (parsePkts pubringBytes))) publicTk <- case publicParsed of (tk : _) -> pure tk @@ -1496,7 +1500,9 @@ assertFailure ("failed to decode v6-secret fixture: " ++ err) >> fail "unreachable" Right (_, bs) -> pure bs - case parseUnknownTKs True (parsePkts payload) of + case map + someTKToUnknown + (map SomeSecretTK (parseSecretTKs True (parsePkts payload))) of (tk : _) -> pure tk [] -> assertFailure @@ -1560,10 +1566,15 @@ ) ) invalidSig = SigV4 GenericCert RSA SHA512 [] [] 0 (MPI 0 :| []) - case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig] of + case map + someTKToUnknown + ( map + SomePublicTK + (parsePublicTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig]) + ) of [tk] -> assertEqual - "parseUnknownTKs True should drop GenericCert as a primary-key signature in v4" + "parsePublicTKs True should drop GenericCert as a primary-key signature in v4" [] (_tkuRevs tk) other -> @@ -1591,10 +1602,15 @@ [] 0 (MPI 0 :| []) - case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig] of + case map + someTKToUnknown + ( map + SomePublicTK + (parsePublicTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig]) + ) of [tk] -> assertEqual - "parseUnknownTKs True should drop GenericCert as a primary-key signature in v6" + "parsePublicTKs True should drop GenericCert as a primary-key signature in v6" [] (_tkuRevs tk) other -> @@ -1622,10 +1638,15 @@ [] 0 (MPI 0 :| []) - case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt allowedSig] of + case map + someTKToUnknown + ( map + SomePublicTK + (parsePublicTKs True [PublicKeyPkt pkp, SignaturePkt allowedSig]) + ) of [tk] -> assertBool - "parseUnknownTKs True should keep allowed v6 key-revocation signatures on primary keys" + "parsePublicTKs True should keep allowed v6 key-revocation signatures on primary keys" (not (null (_tkuRevs tk))) other -> assertFailure