hOpenPGP 3.2 → 3.2.0.1
raw patch · 7 files changed
+221/−267 lines, 7 files
Files
- Codec/Encryption/OpenPGP/Serialize.hs +27/−44
- bench/mark.hs +9/−8
- hOpenPGP.cabal +2/−2
- tests/Tests/Encryption.hs +86/−163
- tests/Tests/Keys.hs +34/−20
- tests/Tests/Properties.hs +19/−7
- tests/Tests/Utilities.hs +44/−23
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -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 "
bench/mark.hs view
@@ -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 )
hOpenPGP.cabal view
@@ -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
tests/Tests/Encryption.hs view
@@ -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
tests/Tests/Keys.hs view
@@ -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 ->
tests/Tests/Properties.hs view
@@ -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
tests/Tests/Utilities.hs view
@@ -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