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 @@ -282,7 +282,26 @@ -> PktStreamContext -> Maybe UTCTime -> Either VerificationError Verification -verifySigWith policy vf sig@(SignaturePkt _) state mt = +verifySigWith policy vf = verifySigWithSubject policy (\_subjectFP -> vf) + +{- | Subject-aware variant of 'verifySigWith' used internally when verifying +signatures over key material (e.g. inside 'verifyTKWith'), so that +self-signature detection can exempt self-certifications from key-usage flag +enforcement per RFC 9580 §5.2.3.10. +-} +verifySigWithSubject + :: VerificationPolicy + -> ( Maybe Fingerprint + -> Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification + ) + -> Pkt + -> PktStreamContext + -> Maybe UTCTime + -> Either VerificationError Verification +verifySigWithSubject policy vf sig@(SignaturePkt _) state mt = case fromPktEitherVerifiableSignatureV sig of Right verifiableSig -> let (st, hs, us, checkSubpacket, checkUnhashedSubpackets) = @@ -344,12 +363,13 @@ verifiableSignatureVerificationInputs (VerifiableSignatureV6 (SigPayloadV6Data st _ _ _ hs us _ _)) = (st, hs, us, checkV6Subpacket, mapM_ rejectV6UnhashedIssuer) -verifySigWith _ _ _ _ _ = +verifySigWithSubject _ _ _ _ _ = verificationError NonSignaturePacket verifyWithSubpacketChecks :: VerificationPolicy - -> ( Pkt + -> ( Maybe Fingerprint + -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification @@ -368,7 +388,12 @@ mapM_ (rejectUnsupportedCriticalSubpacket policy sigType) hashedSubpackets - v <- vf sig mt (payloadForSig sigType state) + v <- + vf + (subjectPrimaryFingerprint state) + sig + mt + (payloadForSig sigType state) mapM_ (checkSubpacket (v ^. verificationSigner) . _sspPayload) hashedSubpackets @@ -444,6 +469,7 @@ } case verifyAgainstKeyWithPolicy vp + Nothing -- No subject available for back-signature verification Nothing -- No TK available for back-signature verification subkeyPKP embSigPkt @@ -784,6 +810,7 @@ else verificationError (CandidateKeyFailures candidateErrors) else case verifyAgainstTKPKPsWithPolicy defaultVerificationPolicy + Nothing usableTkPkps sig verificationTime @@ -816,7 +843,43 @@ -> Maybe UTCTime -> ByteString -> Either VerificationError Verification -verifyAgainstKeysWithPolicy policy ks sig mt payload = do +verifyAgainstKeysWithPolicy policy ks sig mt payload = + verifyAgainstTKPKPsWithPolicy + policy + Nothing + (candidateTKPKPs ks sig) + sig + mt + payload + +{- | Internal variant of 'verifyAgainstKeys' that carries the signed subject's +primary-key fingerprint (when known) so key-usage enforcement can recognize +self-signatures per RFC 9580 §5.2.3.10. +-} +verifyAgainstKeysWithSubject + :: [TK 'PublicTK] + -> Maybe Fingerprint + -> Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification +verifyAgainstKeysWithSubject ks mSubjectFP sig mt payload = + verifyAgainstTKPKPsWithPolicy + defaultVerificationPolicy + mSubjectFP + (candidateTKPKPs ks sig) + sig + mt + payload + +{- | Candidate signer keys from a list of TKs, filtered by issuer hints when +any are present. +-} +candidateTKPKPs + :: [TK 'PublicTK] + -> Pkt + -> [(Maybe (TK 'PublicTK), SomePKPayload)] +candidateTKPKPs ks sig = let allTkPkps = concatMap ( \tk -> @@ -832,15 +895,9 @@ == Just True ) allTkPkps - normalizedCandidates - | null allpkps = allTkPkps - | otherwise = allpkps - verifyAgainstTKPKPsWithPolicy - policy - normalizedCandidates - sig - mt - payload + in if null allpkps + then allTkPkps + else allpkps verifyAgainstPKPs :: [SomePKPayload] @@ -867,6 +924,7 @@ verifyAgainstPKPsWithPolicy policy pkps sig mt payload = verifyAgainstTKPKPsWithPolicy policy + Nothing (map (Nothing,) pkps) sig mt @@ -877,12 +935,13 @@ -} verifyAgainstTKPKPsWithPolicy :: VerificationPolicy + -> Maybe Fingerprint -> [(Maybe (TK 'PublicTK), SomePKPayload)] -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification -verifyAgainstTKPKPsWithPolicy policy tkPkps sig mt payload = +verifyAgainstTKPKPsWithPolicy policy mSubjectFP tkPkps sig mt payload = case rights results of [] -> verificationError (CandidateKeyFailures (lefts results)) [r] -> isSignatureExpired sig mt *> pure r @@ -890,7 +949,15 @@ where results = map - ( \(mTK, pkp) -> verifyAgainstKeyWithPolicy policy mTK pkp sig mt payload + ( \(mTK, pkp) -> + verifyAgainstKeyWithPolicy + policy + mSubjectFP + mTK + pkp + sig + mt + payload ) tkPkps @@ -906,9 +973,9 @@ resolveCandidateSignerPKPs allKeys _ (Just validationTime) matchesP tk = let rawMatches = filter matchesP (candidatePKPs tk) in case verifyTKWith - ( verifySigWith + ( verifySigWithSubject defaultVerificationPolicy - (verifyAgainstKeys allKeys) + (verifyAgainstKeysWithSubject allKeys) ) (Just validationTime) tk of @@ -1100,6 +1167,19 @@ subkeyPKPFromPkt (SecretSubkeyPkt p _) = Just p subkeyPKPFromPkt _ = Nothing +primaryKeyPKPFromPkt :: Pkt -> Maybe SomePKPayload +primaryKeyPKPFromPkt (PublicKeyPkt p) = Just p +primaryKeyPKPFromPkt (SecretKeyPkt p _) = Just p +primaryKeyPKPFromPkt _ = Nothing + +{- | Fingerprint of the primary key the signature is computed over, if the +subject is known (e.g. from a 'PktStreamContext'). +-} +subjectPrimaryFingerprint + :: PktStreamContext -> Maybe Fingerprint +subjectPrimaryFingerprint state = + fingerprint <$> primaryKeyPKPFromPkt (lastPrimaryKey state) + {- | Verify a signature against a key with a custom verification policy. This allows callers to control whether certain signature features (deprecated hash algorithms, PKA mismatches, etc.) are treated as @@ -1107,6 +1187,8 @@ -} verifyAgainstKeyWithPolicy :: VerificationPolicy + -> Maybe Fingerprint + -- ^ Subject primary-key fingerprint (for self-signature detection) -> Maybe (TK 'PublicTK) -- ^ TK containing the signer's key (for key usage checks) -> SomePKPayload @@ -1114,7 +1196,7 @@ -> Maybe UTCTime -> ByteString -> Either VerificationError Verification -verifyAgainstKeyWithPolicy policy mSignerTK pkp sig mt payload = do +verifyAgainstKeyWithPolicy policy mSubjectFP mSignerTK pkp sig mt payload = do sigClass <- either (verificationError . const NonSignaturePacket) @@ -1133,7 +1215,13 @@ warnings <- enforcePKACompatibility policy sigPayload hashWarnings <- enforceSignatureHashPolicy policy sigHash keyUsageWarnings <- - enforceKeyUsagePolicy policy mSignerTK pkp sigPayload mt + enforceKeyUsagePolicy + policy + mSignerTK + mSubjectFP + pkp + sigPayload + mt _ <- isSignatureExpired sig mt let signedPayload = BL.toStrict (finalPayload sig payload) enforceLeft16Prefix sigClass sigHash signedPayload @@ -1193,41 +1281,62 @@ SHA1 -> enforceDeprecatedHash vp sigHash "SHA1" RIPEMD160 -> enforceDeprecatedHash vp sigHash "RIPEMD160" _ -> Right [] - enforceKeyUsagePolicy vp mSignerTK pkp sigPayload mt = + enforceKeyUsagePolicy vp mSignerTK mSubjectFP pkp sigPayload mt = case (sigType sigPayload, mt, mSignerTK) of - (Just st, Just ct, Just signerTK) -> - let requiredFlag = requiredKeyFlagForSigType st - isPrimaryKey = - fingerprint pkp - == fingerprint (keyPktPKPayload (_tkPrimaryKey signerTK)) - keyFlags = - if isPrimaryKey - then effectiveKeyFlagsAt ct signerTK - else do - subkeyFP <- findSubkeyFP pkp signerTK - effectiveSubkeyFlagsAt ct signerTK subkeyFP - in case keyFlags of - Nothing -> - -- No key flags found; per RFC 4880, absence means all flags allowed. - -- But we could also warn. For now, accept silently. - Right [] - Just flags - | requiredFlag `Set.member` flags -> Right [] - | otherwise -> - case applyVerificationPolicy - (vpKeyUsageViolation vp) - ( "Key usage violation: signature type " - ++ show st - ++ " requires " - ++ show requiredFlag - ++ " flag but key has flags " - ++ show (Set.toList flags) - ) of - Left err -> - verificationError - (SignaturePolicyKeyUsageViolation st requiredFlag) - Right warn -> Right [KeyUsageViolationWarning st requiredFlag] + (Just st, Just ct, Just signerTK) + | isSelfSignature st signerTK -> + -- RFC 9580 §5.2.3.10: a self-signature is accepted from a + -- primary key regardless of its Key Flags, so no key-usage + -- flag is required. + Right [] + | otherwise -> + let requiredFlag = requiredKeyFlagForSigType st + keyFlags = + if isPrimarySigner signerTK + then effectiveKeyFlagsAt ct signerTK + else do + subkeyFP <- findSubkeyFP pkp signerTK + effectiveSubkeyFlagsAt ct signerTK subkeyFP + in case keyFlags of + Nothing -> + -- No key flags found; per RFC 4880, absence means all flags allowed. + -- But we could also warn. For now, accept silently. + Right [] + Just flags + | requiredFlag `Set.member` flags -> Right [] + | otherwise -> + case applyVerificationPolicy + (vpKeyUsageViolation vp) + ( "Key usage violation: signature type " + ++ show st + ++ " requires " + ++ show requiredFlag + ++ " flag but key has flags " + ++ show (Set.toList flags) + ) of + Left err -> + verificationError + (SignaturePolicyKeyUsageViolation st requiredFlag) + Right warn -> Right [KeyUsageViolationWarning st requiredFlag] _ -> Right [] + where + isPrimarySigner signerTK = + fingerprint pkp + == fingerprint (keyPktPKPayload (_tkPrimaryKey signerTK)) + -- A self-signature is one a key makes over its own key material. When + -- the signed subject is known, any self-signature type qualifies if + -- the subject's primary key is the signer itself. When the subject is + -- unknown we fall back to the primary-made self-signature types, which + -- are always made by the primary on its own key material (excluding + -- certifications, which can be self- or non-self). + isSelfSignature st signerTK = + case mSubjectFP of + Just subjectFP -> + st `Set.member` selfSignatureTypes + && subjectFP == fingerprint pkp + Nothing -> + st `Set.member` primarySelfSignatureTypes + && isPrimarySigner signerTK enforceLeft16Prefix sigClass sigHash signedPayload = do expectedLeft16 <- either @@ -1423,6 +1532,31 @@ rsaMPItoSig _ _ = Nothing crazyHash h = BA.convert . hashWith h +{- | Primary-made self-signature types that are always recognized as +self-signatures (subkey binding, direct-key self-signature, and the key's +own revocations). These are accepted from any primary key regardless of its +Key Flags per RFC 9580 §5.2.3.10, and need no subject to be recognized. +-} +primarySelfSignatureTypes :: Set.Set SigType +primarySelfSignatureTypes = + Set.fromList + [ SubkeyBindingSig + , DirectKeySignature + , KeyRevocationSig + , SubkeyRevocationSig + , CertRevocationSig + ] + +{- | All self-signature types (RFC 9580 §5.2.3.10): certifications, direct-key +self-signatures, subkey bindings, and the key's own revocations. Used when +the signature's subject is known, to also recognize self-certifications +(which otherwise require the subject to distinguish from third-party certs). +-} +selfSignatureTypes :: Set.Set SigType +selfSignatureTypes = + primarySelfSignatureTypes + `Set.union` Set.fromList [GenericCert, PersonaCert, CasualCert, PositiveCert] + -- | Map a SigType to the required KeyFlag for key usage enforcement. requiredKeyFlagForSigType :: SigType -> KeyFlag requiredKeyFlagForSigType st = @@ -1433,9 +1567,10 @@ CasualCert -> CertifyKeysKey PositiveCert -> CertifyKeysKey CertRevocationSig -> CertifyKeysKey - SubkeyBindingSig -> SignDataKey + SubkeyBindingSig -> CertifyKeysKey + SubkeyRevocationSig -> CertifyKeysKey PrimaryKeyBindingSig -> SignDataKey - KeyRevocationSig -> SignDataKey + KeyRevocationSig -> CertifyKeysKey _ -> SignDataKey -- Conservative default for other types -- | Find the fingerprint of a subkey in a TK. 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.7.2 +Version: 3.7.3 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.7.2 + tag: v3.7.3