hOpenPGP 3.7.2 → 3.7.3
raw patch · 2 files changed
+192/−57 lines, 2 files
Files
- Codec/Encryption/OpenPGP/Signatures.hs +190/−55
- hOpenPGP.cabal +2/−2
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -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.
hOpenPGP.cabal view
@@ -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