hOpenPGP 3.2.0.1 → 3.2.1
raw patch · 9 files changed
+184/−71 lines, 9 files
Files
- Codec/Encryption/OpenPGP/SerializeForSigs.hs +1/−2
- Codec/Encryption/OpenPGP/Signatures.hs +44/−49
- hOpenPGP.cabal +5/−2
- tests/Tests/Common.hs +18/−5
- tests/Tests/Keys.hs +0/−4
- tests/Tests/MessageAndArmor.hs +99/−9
- tests/data/v6.msg +9/−0
- tests/data/v6.txt +1/−0
- tests/data/v6.txt.sig +7/−0
Codec/Encryption/OpenPGP/SerializeForSigs.hs view
@@ -97,11 +97,10 @@ putWord32be . fromIntegral . (+ 6) . BL.length $ runPut $ mapM_ put hs--- this +6 seems like a bug in RFC4880 putSigTrailerCase signatureCase@(SignatureSerializationCaseV6 _) = do putWord8 0x06 putWord8 0xff- putWord32be . fromIntegral . (+ 6) . BL.length $+ putWord32be . fromIntegral . BL.length $ runPut (putPartialSigforSigningCase signatureCase) putSigforSigningCase :: SignatureSerializationCase -> Put
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -601,25 +601,22 @@ | not (isBindingSignatureType sigType) = Right () | otherwise = case payload of- UserDefinedSigSub {} ->- case applyVerificationPolicy- (vpUnsupportedCriticalSubpacket policy)- ( "Unsupported critical subpacket in "- ++ show sigType- ++ " signature"- ) of- Left err -> verificationError (UnsupportedCriticalSubpacket sigType)- Right warn -> Right () -- We don't have a warning type for this yet- OtherSigSub {} ->- case applyVerificationPolicy- (vpUnsupportedCriticalSubpacket policy)- ( "Unsupported critical subpacket in "- ++ show sigType- ++ " signature"- ) of- Left err -> verificationError (UnsupportedCriticalSubpacket sigType)- Right warn -> Right ()+ UserDefinedSigSub {} -> rejectUnsupported policy sigType+ OtherSigSub {} -> rejectUnsupported policy sigType _ -> Right ()+rejectUnsupported+ :: VerificationPolicy+ -> SigType+ -> Either VerificationError ()+rejectUnsupported policy sigType =+ case applyVerificationPolicy+ (vpUnsupportedCriticalSubpacket policy)+ ( "Unsupported critical subpacket in "+ ++ show sigType+ ++ " signature"+ ) of+ Left err -> verificationError (UnsupportedCriticalSubpacket sigType)+ Right warn -> Right () -- We don't have a warning type for this yet isBindingSignatureType :: SigType -> Bool isBindingSignatureType SubkeyBindingSig = True@@ -1277,6 +1274,12 @@ ) of Left err -> verificationError (SignaturePolicyPKAMismatch sigPka keyPka) Right warn -> Right [PkaMismatchWarning sigPka keyPka]+ enforceDeprecatedHash vp ha msg =+ case applyVerificationPolicy+ (vpDeprecatedHashAlgorithm vp)+ ("Deprecated hash algorithm: " ++ msg) of+ Left _ -> verificationError (SignaturePolicyHashUnsupported ha)+ Right _ -> Right [DeprecatedHashAlgorithmWarning ha] enforceSignatureHashPolicy vp sigHash = case sigHash of OtherHA {} ->@@ -1285,24 +1288,9 @@ ("Unsupported hash algorithm: " ++ show sigHash) of Left err -> verificationError (SignaturePolicyHashUnsupported sigHash) Right warn -> Right [UnsupportedHashAlgorithmWarning sigHash]- DeprecatedMD5 ->- case applyVerificationPolicy- (vpDeprecatedHashAlgorithm vp)- ("Deprecated hash algorithm: MD5") of- Left err -> verificationError (SignaturePolicyHashUnsupported sigHash)- Right warn -> Right [DeprecatedHashAlgorithmWarning sigHash]- SHA1 ->- case applyVerificationPolicy- (vpDeprecatedHashAlgorithm vp)- ("Deprecated hash algorithm: SHA1") of- Left err -> verificationError (SignaturePolicyHashUnsupported sigHash)- Right warn -> Right [DeprecatedHashAlgorithmWarning sigHash]- RIPEMD160 ->- case applyVerificationPolicy- (vpDeprecatedHashAlgorithm vp)- ("Deprecated hash algorithm: RIPEMD160") of- Left err -> verificationError (SignaturePolicyHashUnsupported sigHash)- Right warn -> Right [DeprecatedHashAlgorithmWarning sigHash]+ DeprecatedMD5 -> enforceDeprecatedHash vp sigHash "MD5"+ SHA1 -> enforceDeprecatedHash vp sigHash "SHA1"+ RIPEMD160 -> enforceDeprecatedHash vp sigHash "RIPEMD160" _ -> Right [] enforceLeft16Prefix sigClass sigHash signedPayload = do expectedLeft16 <-@@ -1351,28 +1339,28 @@ dsaVerify pub mpis hd pkey bs verify'' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs = ecdsaVerify pub mpis hd pkey bs- verify'' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve25519 pkey) bs- | sigPka `elem` [EdDSA, PKA.Ed25519] =- ed25519Verify sigPka pub mpis hd pkey bs- verify'' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve448 pkey) bs- | sigPka `elem` [EdDSA, PKA.Ed448] =- ed448Verify sigPka pub mpis hd pkey bs+ verify'' (sigPka, mpis) hd pub key@(EdDSAPubKey {}) bs =+ edVerify sigPka pub mpis hd key bs verify'' (RSA, mpis) hd pub (RSAPubKey (RSA_PublicKey pkey)) bs = rsaVerify pub mpis hd pkey bs verify'' (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka)+ verifyNoRSA ha' (sigPka, mpis) hd pub key@(EdDSAPubKey {}) bs =+ edVerify sigPka pub mpis hd key bs verifyNoRSA ha' (DSA, mpis) hd pub (DSAPubKey (DSA_PublicKey pkey)) bs = dsaVerify pub mpis hd pkey bs verifyNoRSA ha' (ECDSA, mpis) hd pub (ECDSAPubKey (ECDSA_PublicKey pkey)) bs = ecdsaVerify pub mpis hd pkey bs- verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve25519 pkey) bs- | sigPka `elem` [EdDSA, PKA.Ed25519] =- ed25519Verify sigPka pub mpis hd pkey bs- verifyNoRSA ha' (sigPka, mpis) hd pub (EdDSAPubKey EdSigningCurve448 pkey) bs- | sigPka `elem` [EdDSA, PKA.Ed448] =- ed448Verify sigPka pub mpis hd pkey bs verifyNoRSA ha' (RSA, _) _ _ _ _ = verificationError (SignatureHashUnsupportedByAlgorithm ha' RSA) verifyNoRSA _ (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka)+ edVerify sigPka pub mpis hd key bs = case key of+ EdDSAPubKey EdSigningCurve25519 pkey+ | sigPka `elem` [EdDSA, PKA.Ed25519] ->+ ed25519Verify sigPka pub mpis hd pkey bs+ EdDSAPubKey EdSigningCurve448 pkey+ | sigPka `elem` [EdDSA, PKA.Ed448] ->+ ed448Verify sigPka pub mpis hd pkey bs+ _ -> verificationError (UnsupportedKeyType sigPka) dsaVerify pub (r :| [s]) hd pkey bs = if DSA.verify hd pkey (dsaMPIsToSig r s) bs then Right pub@@ -1503,9 +1491,16 @@ expiredBefore _ _ = False finalPayload :: Pkt -> ByteString -> ByteString-finalPayload s pl = BL.concat [pl, sigbit, trailer s]+finalPayload s pl = BL.concat [v6Salt s, pl, sigbit, trailer s] where sigbit = runPut $ putPartialSigforSigning s+ v6Salt (SignaturePkt sigPayload) =+ case fromSignaturePayloadVerifiableSignatureV sigPayload of+ Just+ (VerifiableSignatureV6 (SigPayloadV6Data _ _ _ salt _ _ _ _)) ->+ unSignatureSalt salt+ _ -> BL.empty+ v6Salt _ = BL.empty trailer :: Pkt -> ByteString trailer (SignaturePkt sigPayload) = maybe
hOpenPGP.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP-Version: 3.2.0.1+Version: 3.2.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@@ -170,6 +170,9 @@ , tests/data/seipdv2-three-recipients.pgp.aa , tests/data/seipdv2-two-recipients.pgp.aa , tests/data/encryption-sym-aes256-sha256.pgp+ , tests/data/v6.msg+ , tests/data/v6.txt+ , tests/data/v6.txt.sig flag use-memory description: Use the 'memory' package instead of 'ram'@@ -334,4 +337,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v3.2.0.1+ tag: v3.2.1
tests/Tests/Common.hs view
@@ -41,6 +41,7 @@ , extractV4SignatureAlgorithmFields , fp , loadKeyring+ , loadArmorKeyring , loadDeterministicEd25519Signer , loadDeterministicEd25519SignerV6 , loadDeterministicEd448Signer@@ -804,11 +805,23 @@ loadKeyring keyring = DC.runConduitRes $ CB.sourceFile (fixturePath keyring)- DC..| conduitGet get- DC..| conduitToSomeTKsEither- DC..| CL.map (fmap someTKToPublicViewTK . join . hush)- DC..| CL.catMaybes- DC..| sinkPublicKeyringMap+ DC..| loadKeyringPipeline++loadArmorKeyring :: FilePath -> IO PublicKeyring+loadArmorKeyring keyring = do+ payload <- readFixturePayload keyring+ DC.runConduitRes $+ CB.sourceLbs payload+ DC..| loadKeyringPipeline++loadKeyringPipeline+ :: DC.ConduitT B.ByteString DC.Void (ResourceT IO) PublicKeyring+loadKeyringPipeline =+ conduitGet get+ DC..| conduitToSomeTKsEither+ DC..| CL.map (fmap someTKToPublicViewTK . join . hush)+ DC..| CL.catMaybes+ DC..| sinkPublicKeyringMap loadAndDecompressPkts :: FilePath -> IO [Pkt] loadAndDecompressPkts = readFixtureDecompressedPackets
tests/Tests/Keys.hs view
@@ -73,12 +73,8 @@ ( SecretKeyEncryptOptions (..) , decryptPrivateKey , decryptSecretKey- , decryptSecretKeyAddendum- , encryptSecretKey- , encryptSecretKeyWithPolicy , mkUnencryptedSKAddendum , reencryptSecretKey- , reencryptSecretKeyRandom , reinterpretUnknownSKeyForPKPayload ) import Codec.Encryption.OpenPGP.Serialize
tests/Tests/MessageAndArmor.hs view
@@ -13,8 +13,6 @@ , ArmorType (..) ) import Control.Lens ((^.))-import qualified Crypto.PubKey.Ed25519 as Ed25519-import qualified Crypto.PubKey.RSA as RSA import Data.Binary (get, put) import Data.Binary.Get (Get, runGetOrFail) import Data.Binary.Put@@ -29,6 +27,9 @@ import qualified Data.ByteString.Lazy as BL import Data.Either (isLeft, isRight) import Data.Foldable (forM_)+import qualified Data.IxSet.Typed as IxSet+ ( toList+ ) import Data.List (isInfixOf) import qualified Data.List.NonEmpty as NE import Test.Tasty (TestTree, testGroup)@@ -45,6 +46,7 @@ ( decryptPreservingNonce , validateSEIPD1MDC )+import Codec.Encryption.OpenPGP.Compression (decompressPkt) import Codec.Encryption.OpenPGP.Encrypt ( encryptSEIPDv2WithSKESKBlock )@@ -72,6 +74,8 @@ import Codec.Encryption.OpenPGP.SerializeForSigs ( payloadForSig , payloadForSigWith+ , putPartialSigforSigning+ , putSigTrailer ) import Codec.Encryption.OpenPGP.Signatures ( SignError (..)@@ -81,14 +85,11 @@ , signCertRevocationWithRSA , signCertificationWithRSA , signDataWithEd25519- , signDataWithEd25519Builder , signDataWithEd25519V6- , signDataWithEd25519V6Builder , signDataWithEd448 , signDataWithEd448V6 , signDataWithRSA , signDataWithRSABuilder- , signDirectKeyWithRSA , signKeyRevocationWithRSA , signSubkeyRevocationWithRSA , verifyAgainstKeyring@@ -106,9 +107,6 @@ ) import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA-import Codec.Encryption.OpenPGP.Types.Internal.TK- ( someTKToPublicTK- ) import Data.Conduit.OpenPGP.Message ( verifyMessage , verifyMessagePackets@@ -125,6 +123,7 @@ , fp , loadAndDecompressPkts , loadArmor+ , loadArmorKeyring , loadDeterministicEd25519Signer , loadDeterministicEd25519SignerV6 , loadDeterministicEd448Signer@@ -132,9 +131,9 @@ , loadKeyring , loadUnencryptedRsaSigner , loadUnencryptedRsaSignerV6- , messageIssuerSubpacketsAt , mkTestKeyring , readFixtureLazy+ , readFixtureStrict , setPKAlgorithm , signBinaryMessageWithEd25519At , signBinaryMessageWithRSAAt@@ -260,6 +259,15 @@ , testCase "streaming whitespace functions match strict variants" testStreamingWhitespaceMatchesStrict+ , testCase+ "v6.txt.sig V6 trailer length equals partial signature length"+ testV6DetachedTrailerLength+ , testCase+ "v6.msg V6 trailer length equals partial signature length"+ testV6MessageTrailerLength+ , testCase+ "v6.txt.sig verifies against v6.txt with v6-secret.pgp.aa public key"+ testV6DetachedVerification ] , testGroup "ASCII armor fixture group"@@ -2859,6 +2867,88 @@ Left err -> assertFailure ( "Ed25519 SigV4 verification with Ed25519 key algorithm failed: "+ ++ renderVerificationError err+ )+ Right _ -> pure ()++loadV6SignatureFrom :: FilePath -> IO Pkt+loadV6SignatureFrom file = do+ armors <- loadArmor file+ payload <-+ case armors of+ [Armor _ _ p] -> pure p+ _ ->+ assertFailure+ (file ++ " should contain one armored payload")+ >> fail "expected one armored payload"+ case parsePkts payload of+ (sigPkt@(SignaturePkt (SigV6 _ _ _ _ _ _ _ _)) : _) -> pure sigPkt+ other ->+ assertFailure+ ( file+ ++ " should contain a SigV6 signature packet, got: "+ ++ show other+ )+ >> fail "expected SigV6 signature packet"++assertV6TrailerLength :: Pkt -> Assertion+assertV6TrailerLength sigPkt = do+ let partialSig = runPut (putPartialSigforSigning sigPkt)+ expectedTrailer = runPut $ do+ putWord8 0x06+ putWord8 0xff+ putWord32be (fromIntegral (BL.length partialSig))+ actualTrailer = runPut (putSigTrailer sigPkt)+ assertEqual+ "V6 signature trailer length equals partial signature length (not partial + 6)"+ expectedTrailer+ actualTrailer++testV6DetachedTrailerLength :: Assertion+testV6DetachedTrailerLength = do+ sigPkt <- loadV6SignatureFrom "v6.txt.sig"+ assertV6TrailerLength sigPkt++testV6MessageTrailerLength :: Assertion+testV6MessageTrailerLength = do+ armors <- loadArmor "v6.msg"+ payload <-+ case armors of+ [Armor _ _ p] -> pure p+ _ ->+ assertFailure "v6.msg should contain one armored payload"+ >> fail "expected one armored payload"+ let pkts = parsePkts payload+ decompressed = concatMap (either (const []) id . decompressPkt) pkts+ v6Sigs =+ [ SignaturePkt sig+ | SignaturePkt sig@(SigV6 _ _ _ _ _ _ _ _) <- decompressed+ ]+ assertBool+ "v6.msg should contain at least one V6 signature packet"+ (not (null v6Sigs))+ forM_ v6Sigs assertV6TrailerLength++testV6DetachedVerification :: Assertion+testV6DetachedVerification = do+ keyring <- loadArmorKeyring "v6-secret.pgp.aa"+ fileContents <- readFixtureStrict "v6.txt"+ sigPkt <- loadV6SignatureFrom "v6.txt.sig"+ let publicTKs = IxSet.toList keyring+ state =+ emptyPSC+ { lastLD =+ LiteralDataPkt BinaryData BL.empty 0 (BL.fromStrict fileContents)+ }+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeys publicTKs)+ sigPkt+ state+ Nothing of+ Left err ->+ assertFailure+ ( "v6 detached signature should verify with v6-secret.pgp.aa public key: " ++ renderVerificationError err ) Right _ -> pure ()
+ tests/data/v6.msg view
@@ -0,0 +1,9 @@+-----BEGIN PGP MESSAGE-----++xEYGAAobIAZnWPc3iaOTXqmsLq49dDMdeY+d8QpB6JeN6N8je3aCBLW7iQgbOArh+Brulq39k17BEfv5Fbv8epvSfbah+Rf0Byw5iAAAAAAB2ZWUgc2l4CsKYBgAbCgAA+ACkFgmp6do8iIQYEtbuJCBs4CuEGu6Wrf2TXsER+/kVu/x6m9J9tqH5F/QAAAAA4+2SAGZ1j3N4mjk16prC6uPXQzHXmPnfEKQeiXjejfI3t2guAkHYrXf08Q6plu9Cy0+EPUl8rFyf7aYa9eHXanmUL4AtrscpZ9N6+am3mmIwY1tb59okpQ0XkkbhGz3VtZ++cAA=+-----END PGP MESSAGE-----
+ tests/data/v6.txt view
@@ -0,0 +1,1 @@+vee six
+ tests/data/v6.txt.sig view
@@ -0,0 +1,7 @@+-----BEGIN PGP SIGNATURE-----++wpgGABsKAAAAKQWCanp2pyIhBgS1u4kIGzgK4Qa7pat/ZNewRH7+RW7/Hqb0n22o+fkX9AAAAADPIIHP16EU0Q6gmc1h8ROLFmA6v8bX6xZH9EZpIhItuRDee/6cLBU6F+YCn080AzDt0oF7z427CPrSAo6afVbRpXshK/UV2j9H7P/jmbSA52ljHLoxQxcuQK+fwPZmQgY6q2PBA==+-----END PGP SIGNATURE-----