diff --git a/Codec/Encryption/OpenPGP/BlockCipher.hs b/Codec/Encryption/OpenPGP/BlockCipher.hs --- a/Codec/Encryption/OpenPGP/BlockCipher.hs +++ b/Codec/Encryption/OpenPGP/BlockCipher.hs @@ -16,7 +16,6 @@ import qualified Crypto.Cipher.TripleDES as TripleDES import qualified Crypto.Nettle.Ciphers as CNC import qualified Data.ByteString as B -import qualified Data.Set as Set import Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes ( HOWrappedOldCCT (..) @@ -124,18 +123,17 @@ Decryption backward-compatibility is unaffected: 'withSymmetricCipher' still handles all ten algorithms, including the three forbidden above. -} -supportedSymmetricAlgorithmsForCFB :: Set.Set SymmetricAlgorithm +supportedSymmetricAlgorithmsForCFB :: [SymmetricAlgorithm] supportedSymmetricAlgorithmsForCFB = - Set.fromList - [ Twofish - , Blowfish - , AES128 - , AES192 - , AES256 - , Camellia128 - , Camellia192 - , Camellia256 - ] + [ AES256 + , AES192 + , AES128 + , Camellia256 + , Camellia192 + , Camellia128 + , Twofish + , Blowfish + ] initAndRun :: HOBlockCipher cipher 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 @@ -1730,19 +1730,17 @@ recipientChoices (RecipientCapabilityNoCommonSymmetricAlgorithms []) where - senderSymmetricAlgorithms = Set.toList supportedSymmetricAlgorithmsForCFB + senderSet = Set.fromList supportedSymmetricAlgorithmsForCFB recipientChoices = map choicesForTarget targets choicesForTarget target = case recipientEncryptionTargetCapabilities target of Just caps -> let preferred = recipientCapabilityPreferredSymmetricAlgorithms caps - preferredSet = Set.fromList preferred - allowed = - [s | s <- senderSymmetricAlgorithms, s `Set.member` preferredSet] + allowed = [s | s <- preferred, s `Set.member` senderSet] in if null allowed - then senderSymmetricAlgorithms + then supportedSymmetricAlgorithmsForCFB else allowed - Nothing -> senderSymmetricAlgorithms + Nothing -> supportedSymmetricAlgorithmsForCFB chooseCommonAlgorithm :: (Eq a, Ord a) @@ -1761,7 +1759,11 @@ intersectOrdered as bs = [a | a <- as, a `Set.member` Set.fromList bs] orderByRecipientPreference candidates choices = sortOn - ( \c -> sum [fromMaybe 0 (elemIndex c allowed) | allowed <- choices] + ( \c -> + sum + [ fromMaybe (maxBound :: Int) (elemIndex c allowed) + | allowed <- choices + ] ) candidates @@ -2458,19 +2460,25 @@ materialBytes = unPKESKV3SessionMaterial material algoByte = B.head materialBytes rawKey = B.dropEnd 2 (B.drop 1 materialBytes) - wrapped <- - first (RecipientKeyWrapFailureCipher X25519) - . aesKeyWrapRFC3394 AES128 kek - $ rawKey - Right - ( PKESKPayloadV3 - 3 - eoki - X25519 - ( MPI (os2ip ephPublicBytes) - :| [MPI (os2ip (B.singleton algoByte <> wrapped))] - ) - ) + algoSym = toFVal algoByte + if algoSym `notElem` [AES128, AES192, AES256] + then + Left + (UnsupportedSessionKeyAlgorithmForPKESK X25519 algoSym) + else do + wrapped <- + first (RecipientKeyWrapFailureCipher X25519) + . aesKeyWrapRFC3394 AES128 kek + $ rawKey + Right + ( PKESKPayloadV3 + 3 + eoki + X25519 + ( MPI (os2ip ephPublicBytes) + :| [MPI (os2ip (B.singleton algoByte <> wrapped))] + ) + ) buildX448PKESKv3 :: MonadRandom m @@ -2501,19 +2509,25 @@ materialBytes = unPKESKV3SessionMaterial material algoByte = B.head materialBytes rawKey = B.dropEnd 2 (B.drop 1 materialBytes) - wrapped <- - first (RecipientKeyWrapFailureCipher X448) - . aesKeyWrapRFC3394 AES256 kek - $ rawKey - Right - ( PKESKPayloadV3 - 3 - eoki - X448 - ( MPI (os2ip ephPublicBytes) - :| [MPI (os2ip (B.singleton algoByte <> wrapped))] - ) - ) + algoSym = toFVal algoByte + if algoSym `notElem` [AES128, AES192, AES256] + then + Left + (UnsupportedSessionKeyAlgorithmForPKESK X448 algoSym) + else do + wrapped <- + first (RecipientKeyWrapFailureCipher X448) + . aesKeyWrapRFC3394 AES256 kek + $ rawKey + Right + ( PKESKPayloadV3 + 3 + eoki + X448 + ( MPI (os2ip ephPublicBytes) + :| [MPI (os2ip (B.singleton algoByte <> wrapped))] + ) + ) buildEcdhV6Esk :: SomePKPayload diff --git a/Codec/Encryption/OpenPGP/Policy.hs b/Codec/Encryption/OpenPGP/Policy.hs --- a/Codec/Encryption/OpenPGP/Policy.hs +++ b/Codec/Encryption/OpenPGP/Policy.hs @@ -246,6 +246,18 @@ -- ^ Action for unsupported/unknown hash algorithms , vpPkaMismatch :: VerificationPolicyAction -- ^ Action for PKA mismatch between signature and key + , vpDeprecatedSignatureAlgorithms :: Set.Set PubKeyAlgorithm + {- ^ Signature PKAs the caller considers deprecated + (e.g. RFC 9580 ยง9.3 forbids new DSA signatures). + -} + , vpDeprecatedSignatureAlgorithm :: VerificationPolicyAction + {- ^ Action for signatures using a PKA in + 'vpDeprecatedSignatureAlgorithms'. + -} + , vpUnsupportedSignatureAlgorithm :: VerificationPolicyAction + {- ^ Action for signatures using a PKA we cannot verify at all + (e.g. 'OtherPKA'). + -} , vpUnsupportedCriticalSubpacket :: VerificationPolicyAction -- ^ Action for unsupported critical subpackets , vpLegacyIssuerKeyIdInV6 :: VerificationPolicyAction @@ -268,6 +280,9 @@ { vpDeprecatedHashAlgorithm = VerificationWarning , vpUnsupportedHashAlgorithm = VerificationError , vpPkaMismatch = VerificationError + , vpDeprecatedSignatureAlgorithms = Set.fromList [DSA] + , vpDeprecatedSignatureAlgorithm = VerificationWarning + , vpUnsupportedSignatureAlgorithm = VerificationError , vpUnsupportedCriticalSubpacket = VerificationError , vpLegacyIssuerKeyIdInV6 = VerificationError , vpMissingSubkeyBackSignature = VerificationWarning @@ -282,6 +297,9 @@ { vpDeprecatedHashAlgorithm = VerificationError , vpUnsupportedHashAlgorithm = VerificationError , vpPkaMismatch = VerificationError + , vpDeprecatedSignatureAlgorithms = Set.fromList [DSA] + , vpDeprecatedSignatureAlgorithm = VerificationError + , vpUnsupportedSignatureAlgorithm = VerificationError , vpUnsupportedCriticalSubpacket = VerificationError , vpLegacyIssuerKeyIdInV6 = VerificationError , vpMissingSubkeyBackSignature = VerificationError @@ -298,6 +316,9 @@ { vpDeprecatedHashAlgorithm = VerificationWarning , vpUnsupportedHashAlgorithm = VerificationWarning , vpPkaMismatch = VerificationWarning + , vpDeprecatedSignatureAlgorithms = Set.empty + , vpDeprecatedSignatureAlgorithm = VerificationWarning + , vpUnsupportedSignatureAlgorithm = VerificationWarning , vpUnsupportedCriticalSubpacket = VerificationWarning , vpLegacyIssuerKeyIdInV6 = VerificationWarning , vpMissingSubkeyBackSignature = VerificationWarning 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 @@ -1086,13 +1086,17 @@ Right (sigHA sigPayload) sigDetails <- signaturePKAAndMPIsFromClass sigClass + algoWarnings <- enforceSignatureAlgorithmPolicy policy sigDetails warnings <- enforcePKACompatibility policy sigPayload hashWarnings <- enforceSignatureHashPolicy policy sigHash _ <- isSignatureExpired sig mt let signedPayload = BL.toStrict (finalPayload sig payload) enforceLeft16Prefix sigClass sigHash signedPayload ( \verifiedSigner -> - Verification verifiedSigner sigPayload (warnings ++ hashWarnings) + Verification + verifiedSigner + sigPayload + (warnings ++ algoWarnings ++ hashWarnings) ) <$> verify' sigDetails pkp sigHash signedPayload where @@ -1110,6 +1114,22 @@ ) of Left err -> verificationError (SignaturePolicyPKAMismatch sigPka keyPka) Right warn -> Right [PkaMismatchWarning sigPka keyPka] + enforceSignatureAlgorithmPolicy vp (sigPka, _) = + if sigPka `Set.member` vpDeprecatedSignatureAlgorithms vp + then case applyVerificationPolicy + (vpDeprecatedSignatureAlgorithm vp) + ("Deprecated signature algorithm: " ++ show sigPka) of + Left _ -> verificationError (SignaturePolicyAlgorithmDeprecated sigPka) + Right _ -> Right [DeprecatedSignatureAlgorithmWarning sigPka] + else case sigPka of + OtherPKA _ -> + case applyVerificationPolicy + (vpUnsupportedSignatureAlgorithm vp) + ("Unsupported signature algorithm: " ++ show sigPka) of + Left _ -> + verificationError (SignaturePolicyAlgorithmUnsupported sigPka) + Right _ -> Right [UnsupportedSignatureAlgorithmWarning sigPka] + _ -> Right [] enforceDeprecatedHash vp ha msg = case applyVerificationPolicy (vpDeprecatedHashAlgorithm vp) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Errors.hs b/Codec/Encryption/OpenPGP/Types/Internal/Errors.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Errors.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Errors.hs @@ -576,6 +576,8 @@ | SignatureEncodingInvalidLength !PubKeyAlgorithm !String !Int !Int | SignaturePolicyHashUnsupported !HashAlgorithm | SignaturePolicyPKAMismatch !PubKeyAlgorithm !PubKeyAlgorithm + | SignaturePolicyAlgorithmDeprecated !PubKeyAlgorithm + | SignaturePolicyAlgorithmUnsupported !PubKeyAlgorithm | SignatureExpired | CandidateKeyFailures [VerificationError] | InvalidSubkeyBackSignature !VerificationError @@ -674,6 +676,12 @@ ++ show sigPka ++ " does not match key algorithm " ++ show keyPka +renderVerificationError (SignaturePolicyAlgorithmDeprecated pka) = + "verification failed: signature uses deprecated public-key algorithm " + ++ show pka +renderVerificationError (SignaturePolicyAlgorithmUnsupported pka) = + "verification failed: signature uses unsupported public-key algorithm " + ++ show pka renderVerificationError SignatureExpired = "verification failed: signature expired" renderVerificationError (CandidateKeyFailures errs) = @@ -762,6 +770,9 @@ | RecipientKeyWrapFailureCipher !PubKeyAlgorithm !CipherError | RecipientKeyWrapFailureRSA !PubKeyAlgorithm !RSA.Error | RecipientKeyWrapFailureCrypto !PubKeyAlgorithm !CE.CryptoError + | UnsupportedSessionKeyAlgorithmForPKESK + !PubKeyAlgorithm + !SymmetricAlgorithm | RecipientCapabilitySelectionFailure !RecipientCapabilityError | PayloadBuildFailureCipher !CipherError | PayloadBuildFailureS2K !S2KError @@ -820,6 +831,11 @@ ++ show algo ++ ": " ++ show err +renderPKESKEncryptError (UnsupportedSessionKeyAlgorithmForPKESK algo symAlgo) = + "unsupported session key algorithm " + ++ show symAlgo + ++ " for v3 PKESK recipient algorithm " + ++ show algo renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) = renderRecipientCapabilityError err renderPKESKEncryptError (PayloadBuildFailureCipher err) = 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 @@ -712,6 +712,8 @@ | DeprecatedHashAlgorithmWarning HashAlgorithm | UnsupportedHashAlgorithmWarning HashAlgorithm | PkaMismatchWarning PubKeyAlgorithm PubKeyAlgorithm + | DeprecatedSignatureAlgorithmWarning PubKeyAlgorithm + | UnsupportedSignatureAlgorithmWarning PubKeyAlgorithm | UnsupportedCriticalSubpacketWarning SigType | LegacyIssuerKeyIdInV6Warning | InvalidSignatureContextWarning SigType 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.6.9 +Version: 3.6.10 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 @@ -347,4 +347,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git - tag: v3.6.9 + tag: v3.6.10 diff --git a/tests/Tests/Keys.hs b/tests/Tests/Keys.hs --- a/tests/Tests/Keys.hs +++ b/tests/Tests/Keys.hs @@ -68,6 +68,7 @@ , isAllowedPrimaryKeySig , isAllowedSubkeySig , isAllowedUIDSig + , strictVerificationPolicy ) import Codec.Encryption.OpenPGP.SecretKey ( SecretKeyEncryptOptions (..) @@ -279,6 +280,27 @@ (testRevokedCertificateMessage "revoked.pubkey") ] , testGroup + "Signature algorithm policy group" + [ testCase + "default policy accepts DSA signature with deprecation warning" + ( testDsaDefaultPolicyWarns + "pubring.gpg" + "uncompressed-ops-dsa.gpg" + ) + , testCase + "strict policy rejects DSA signature" + ( testDsaStrictPolicyRejects + "pubring.gpg" + "uncompressed-ops-dsa.gpg" + ) + , testCase + "strict policy rejects signature with unimplemented PKA" + ( testStrictPolicyRejectsUnsupportedPka + "pubring.gpg" + "uncompressed-ops-dsa.gpg" + ) + ] + , testGroup "Key expiration group" [ testCase "6F87040E pubkey" @@ -520,6 +542,132 @@ ) publicKs ) + +testDsaDefaultPolicyWarns :: FilePath -> FilePath -> Assertion +testDsaDefaultPolicyWarns keyring message = do + ks <- loadKeyringAsPublicTKs keyring + (payload, sigPkt) <- loadSignedMessage keyring message + case verifyAgainstKeysWithPolicy + defaultVerificationPolicy + ks + sigPkt + Nothing + payload of + Right verification -> + assertTrue + "expected DSA deprecation warning" + ( DeprecatedSignatureAlgorithmWarning DSA + `elem` _verificationWarnings verification + ) + Left err -> + assertFailure $ + "expected verification to succeed under default policy, got: " + ++ renderVerificationError err + +testDsaStrictPolicyRejects :: FilePath -> FilePath -> Assertion +testDsaStrictPolicyRejects keyring message = do + ks <- loadKeyringAsPublicTKs keyring + (payload, sigPkt) <- loadSignedMessage keyring message + case verifyAgainstKeysWithPolicy + strictVerificationPolicy + ks + sigPkt + Nothing + payload of + Right verification -> + assertFailure $ + "expected strict policy to reject signature, but it verified: " + ++ show (_verificationWarnings verification) + Left err -> + assertFailureUnlessMatches + "expected SignaturePolicyAlgorithmDeprecated DSA in candidate failures" + [SignaturePolicyAlgorithmDeprecated DSA] + err + +testStrictPolicyRejectsUnsupportedPka + :: FilePath -> FilePath -> Assertion +testStrictPolicyRejectsUnsupportedPka keyring message = do + ks <- loadKeyringAsPublicTKs keyring + pkts <- loadAndDecompressPkts message + let (origSig : _) = + [ s + | SignaturePkt s <- pkts + ] + synthSig = case origSig of + SigV3 st ts eoki _ ha w16 mpis -> + SigV3 st ts eoki (OtherPKA 99) ha w16 mpis + SigV4 st _ ha hsps usps w16 mpis -> + SigV4 st (OtherPKA 99) ha hsps usps w16 mpis + SigV6 st _ ha salt hsps usps w16 mpis -> + SigV6 st (OtherPKA 99) ha salt hsps usps w16 mpis + SigVOther v bs -> SigVOther v bs + newPkts = + SignaturePkt synthSig + : filter (\p -> case p of SignaturePkt _ -> False; _ -> True) pkts + assertEqual + "we must mutate exactly one signature packet" + (length pkts) + (length newPkts) + (payload, sigPkt) <- loadSignedMessagePackets newPkts + case verifyAgainstKeysWithPolicy + strictVerificationPolicy + ks + sigPkt + Nothing + payload of + Right verification -> + assertFailure $ + "expected strict policy to reject signature, but it verified: " + ++ show (_verificationWarnings verification) + Left err -> + assertFailureUnlessMatches + "expected SignaturePolicyAlgorithmUnsupported (OtherPKA 99) in candidate failures" + [SignaturePolicyAlgorithmUnsupported (OtherPKA 99)] + err + +assertFailureUnlessMatches + :: String -> [VerificationError] -> VerificationError -> Assertion +assertFailureUnlessMatches label expected err = + let actualErrors = case err of + CandidateKeyFailures errs -> errs + other -> [other] + matches = filter (`elem` actualErrors) expected + in assertBool + ( label + ++ "; actual = " + ++ show actualErrors + ) + (not (null matches)) + +loadSignedMessage + :: FilePath -> FilePath -> IO (BL.ByteString, Pkt) +loadSignedMessage _ message = do + pkts <- loadAndDecompressPkts message + loadSignedMessagePackets pkts + +loadSignedMessagePackets :: [Pkt] -> IO (BL.ByteString, Pkt) +loadSignedMessagePackets pkts = case find (\p -> case p of SignaturePkt _ -> True; _ -> False) pkts of + Just sigPkt@(SignaturePkt _) -> do + let payload :: BL.ByteString + payload = case [bs | Just bs <- map mLiteralDataPayload pkts] of + (bs : _) -> bs + [] -> BL.empty + pure (payload, sigPkt) + _ -> error "no signature packet found" + +mLiteralDataPayload :: Pkt -> Maybe BL.ByteString +mLiteralDataPayload (LiteralDataPkt _ _ _ bs) = Just bs +mLiteralDataPayload _ = Nothing + +loadKeyringAsPublicTKs :: FilePath -> IO [TK 'PublicTK] +loadKeyringAsPublicTKs keyring = + fmap (mapMaybe someTKToPublicTK) $ + DC.runConduitRes $ + CB.sourceFile ("tests/data/" ++ keyring) + DC..| conduitGet get + DC..| conduitToSomeTKsEither + DC..| conduitDropErrorsAndNothings + DC..| CL.consume testKeysSelfVerification :: Bool -> FilePath -> Assertion testKeysSelfVerification expectsuccess keyfile = do