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 @@ -157,13 +157,15 @@ , keyIdFromFingerprint ) import Codec.Encryption.OpenPGP.Internal - ( bsToFixedWidth + ( FixedWidthBytes + , bsToFixedWidth , checksum16BE , chunksOf8 , edPointBytes , encodeWord64be , leftPadTo , point2MBS + , unSizedByteArray , xorBS ) import Codec.Encryption.OpenPGP.Internal.CryptoECDH @@ -2209,7 +2211,8 @@ pure $ do recipientPublicBytes <- - normalizeX25519Public (edPointBytes recipientPoint) + unSizedByteArray + <$> normalizeX25519Public (edPointBytes recipientPoint) ephSecretBS <- case bsToFixedWidth @32 ephSecretRaw of Nothing -> Left @@ -2304,14 +2307,16 @@ pure $ do recipientPublicBytes <- - normalizeX25519Public (edPointBytes recipientPoint) - ephSecretBS <- - note - ( InvalidRecipientKeyMaterial - ECDH - "leftPadTo: input exceeds target" - ) - (leftPadTo 32 ephSecretRaw) + unSizedByteArray + <$> normalizeX25519Public (edPointBytes recipientPoint) + ephSecretBS <- case bsToFixedWidth @32 ephSecretRaw of + Nothing -> + Left + ( InvalidRecipientKeyMaterial + ECDH + "bsToFixedWidth @32: input exceeds target" + ) + Just fwb -> Right (unSizedByteArray fwb) ephSecret <- first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError @@ -2336,7 +2341,8 @@ pure $ do recipientPublicBytes <- - normalizeX448Public (edPointBytes recipientPoint) + unSizedByteArray + <$> normalizeX448Public (edPointBytes recipientPoint) ephSecretBS <- case bsToFixedWidth @56 ephSecretRaw of Nothing -> Left @@ -2390,7 +2396,8 @@ ephSecretRaw <- getRandomBytes 32 pure $ do - recipientPublic <- extractX25519RecipientPublic recipient + recipientPublicFWB <- extractX25519RecipientPublic recipient + let recipientPublic = unSizedByteArray recipientPublicFWB ephSecretBS <- case bsToFixedWidth @32 ephSecretRaw of Nothing -> Left @@ -2431,7 +2438,8 @@ ephSecretRaw <- getRandomBytes 56 pure $ do - recipientPublic <- extractX448RecipientPublic recipient + recipientPublicFWB <- extractX448RecipientPublic recipient + let recipientPublic = unSizedByteArray recipientPublicFWB ephSecretBS <- case bsToFixedWidth @56 ephSecretRaw of Nothing -> Left @@ -2477,7 +2485,8 @@ ephSecretRaw <- getRandomBytes 32 pure $ do - recipientPublic <- extractX25519RecipientPublic recipient + recipientPublicFWB <- extractX25519RecipientPublic recipient + let recipientPublic = unSizedByteArray recipientPublicFWB ephSecretBS <- case bsToFixedWidth @32 ephSecretRaw of Nothing -> Left @@ -2534,7 +2543,8 @@ ephSecretRaw <- getRandomBytes 56 pure $ do - recipientPublic <- extractX448RecipientPublic recipient + recipientPublicFWB <- extractX448RecipientPublic recipient + let recipientPublic = unSizedByteArray recipientPublicFWB ephSecretBS <- case bsToFixedWidth @56 ephSecretRaw of Nothing -> Left @@ -2701,7 +2711,7 @@ ) extractX25519RecipientPublic - :: SomePKPayload -> Either PKESKEncryptError B.ByteString + :: SomePKPayload -> Either PKESKEncryptError (FixedWidthBytes 32) extractX25519RecipientPublic recipient = case _pubkey recipient of EdDSAPubKey EdSigningCurve25519 point -> @@ -2716,7 +2726,7 @@ ) extractX448RecipientPublic - :: SomePKPayload -> Either PKESKEncryptError B.ByteString + :: SomePKPayload -> Either PKESKEncryptError (FixedWidthBytes 56) extractX448RecipientPublic recipient = case _pubkey recipient of EdDSAPubKey EdSigningCurve448 point -> @@ -2731,20 +2741,24 @@ ) normalizeX25519Public - :: B.ByteString -> Either PKESKEncryptError B.ByteString -normalizeX25519Public = - first (InvalidRecipientKeyMaterial X25519) - . normalizeMontgomeryPublic - 32 + :: B.ByteString -> Either PKESKEncryptError (FixedWidthBytes 32) +normalizeX25519Public bs = + first + (InvalidRecipientKeyMaterial X25519) + ( normalizeMontgomeryPublic @32 "invalid X25519 public key length/prefix: " + bs + ) normalizeX448Public - :: B.ByteString -> Either PKESKEncryptError B.ByteString -normalizeX448Public = - first (InvalidRecipientKeyMaterial X448) - . normalizeMontgomeryPublic - 56 + :: B.ByteString -> Either PKESKEncryptError (FixedWidthBytes 56) +normalizeX448Public bs = + first + (InvalidRecipientKeyMaterial X448) + ( normalizeMontgomeryPublic @56 "invalid X448 public key length/prefix: " + bs + ) deriveX25519Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString diff --git a/Codec/Encryption/OpenPGP/Expirations.hs b/Codec/Encryption/OpenPGP/Expirations.hs --- a/Codec/Encryption/OpenPGP/Expirations.hs +++ b/Codec/Encryption/OpenPGP/Expirations.hs @@ -2,7 +2,12 @@ -- Copyright © 2014-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Codec.Encryption.OpenPGP.Expirations ( KeyState (..) @@ -22,13 +27,19 @@ , signatureEffectiveAt , addDurationToTime , newestByCreationTime + , keyFlagsFromSignature + , effectiveKeyFlagsAt + , effectiveSubkeyFlagsAt + , effectiveFeaturesAt ) where import Control.Error.Util (hush) import Control.Lens ((&), (^.)) -import Data.List (maximumBy) -import Data.Maybe (listToMaybe, mapMaybe) +import Data.List (find, maximumBy) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) import Data.Ord (comparing) +import Data.Set (Set) +import qualified Data.Set as Set import Data.Text (Text) import Data.Time.Clock (UTCTime, addUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) @@ -46,6 +57,21 @@ ) import Codec.Encryption.OpenPGP.Types +{- | Type class for extracting PK payload from subkeys. +This is needed because TKKeyPkt k varies by key kind. +-} +class TKSubkeyPKPayload (k :: TKKind) where + tkSubkeyPKPayload :: TKKeyPkt k -> SomePKPayload + +instance TKSubkeyPKPayload 'PublicTK where + tkSubkeyPKPayload = keyPktPKPayload + +instance TKSubkeyPKPayload 'SecretTK where + tkSubkeyPKPayload = keyPktPKPayload + +instance TKSubkeyPKPayload 'MixedTK where + tkSubkeyPKPayload (SomeKeyPkt kp) = keyPktPKPayload kp + data KeyState = KeyState { keyStateValid :: Bool @@ -402,5 +428,125 @@ getKeyExpirationTimesFromSignature :: SignaturePayload -> [ThirtyTwoBitDuration] getKeyExpirationTimesFromSignature sig = - map (\(SigSubPacket _ (KeyExpirationTime x)) -> x) $ - filter isKET (signatureHashedSubpackets sig) + mapMaybe + ( \(SigSubPacket _ payload) -> + case payload of + KeyExpirationTime x -> Just x + _ -> Nothing + ) + (signatureHashedSubpackets sig) + +-- | Extract KeyFlags from a single signature's hashed subpackets. +keyFlagsFromSignature :: SignaturePayload -> Maybe (Set KeyFlag) +keyFlagsFromSignature sig = + case signatureHashedSubpacketsKnown sig of + Nothing -> Nothing + Just subpackets -> + foldr + ( \(SigSubPacket _ payload) acc -> + case payload of + KeyFlags flags -> Just (maybe flags (Set.union flags) acc) + _ -> acc + ) + Nothing + subpackets + +{- | Get effective key flags for the primary key at a given timestamp. +Finds the latest effective self-signature (direct key sig, UID self-cert, or UAT self-cert) +and extracts KeyFlags from its hashed subpackets. +Returns Nothing if no effective self-signature exists or if no KeyFlags subpacket is present. +-} +effectiveKeyFlagsAt + :: TKPrimaryPKPayload k + => UTCTime -> TK k -> Maybe (Set KeyFlag) +effectiveKeyFlagsAt ct tk = do + sig <- latestEffectivePreferenceCarrierAt ct tk + keyFlagsFromSignature sig + +{- | Get effective key flags for a subkey at a given timestamp. +Finds the subkey by fingerprint, then finds the latest effective +subkey binding signature and extracts KeyFlags from its hashed subpackets. +-} +effectiveSubkeyFlagsAt + :: forall k + . (TKPrimaryPKPayload k, TKSubkeyPKPayload k) + => UTCTime -> TK k -> Fingerprint -> Maybe (Set KeyFlag) +effectiveSubkeyFlagsAt ct tk fp = do + (_, bindingSigs) <- + find + (\(kp, _) -> fingerprint (tkSubkeyPKPayload @k kp) == fp) + (tk ^. tkSubs) + bindingSig <- + latestEffectiveSubkeyBindingSignatureAt ct bindingSigs + keyFlagsFromSignature bindingSig + +{- | Get effective features for the primary key at a given timestamp. +Finds the latest effective self-signature and extracts Features from its hashed subpackets. +-} +effectiveFeaturesAt + :: TKPrimaryPKPayload k + => UTCTime -> TK k -> Maybe (Set FeatureFlag) +effectiveFeaturesAt ct tk = do + sig <- latestEffectivePreferenceCarrierAt ct tk + featuresFromSignature sig + +-- | Extract Features from a single signature's hashed subpackets. +featuresFromSignature + :: SignaturePayload -> Maybe (Set FeatureFlag) +featuresFromSignature sig = + case signatureHashedSubpacketsKnown sig of + Nothing -> Nothing + Just subpackets -> + foldr + ( \(SigSubPacket _ payload) acc -> + case payload of + Features flags -> Just (maybe flags (Set.union flags) acc) + _ -> acc + ) + Nothing + subpackets + +{- | Find the latest effective subkey binding signature at a given timestamp. +This is similar to the function in Encrypt.hs but uses UTCTime instead of ThirtyTwoBitTimeStamp. +-} +latestEffectiveSubkeyBindingSignatureAt + :: UTCTime -> [SignaturePayload] -> Maybe SignaturePayload +latestEffectiveSubkeyBindingSignatureAt ct sigs = + case filter (isEffectiveSubkeyBindingSignatureAt ct) sigs of + [] -> Nothing + candidates -> + Just + (maximumBy (comparing signatureCreationTimeOrZero) candidates) + +-- | Check if a signature is an effective subkey binding signature at the given time. +isEffectiveSubkeyBindingSignatureAt + :: UTCTime -> SignaturePayload -> Bool +isEffectiveSubkeyBindingSignatureAt ct sig = + isSubkeyBindingSig sig + && maybe + False + ( \created -> + created <= ct + && maybe + True + ( \duration -> + if unThirtyTwoBitDuration duration == 0 + then True + else + ct + < addUTCTime + (fromIntegral (unThirtyTwoBitDuration duration)) + created + ) + (signatureExpirationDuration sig) + ) + (signatureCreationTime sig) + +-- | Check if a signature is a subkey binding signature. +isSubkeyBindingSig :: SignaturePayload -> Bool +isSubkeyBindingSig sig = sigType sig == Just SubkeyBindingSig + +-- | Get signature creation time or zero if not present. +signatureCreationTimeOrZero :: SignaturePayload -> UTCTime +signatureCreationTimeOrZero sig = + fromMaybe (posixSecondsToUTCTime 0) (signatureCreationTime sig) diff --git a/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs b/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs --- a/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs +++ b/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs @@ -2,7 +2,11 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Codec.Encryption.OpenPGP.Internal.CryptoECDH ( normalizeMontgomeryPublic @@ -14,34 +18,40 @@ import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import Data.Bifunctor (first) import qualified Data.ByteString as B +import GHC.TypeNats (KnownNat) import Codec.Encryption.OpenPGP.BlockCipher ( keySize ) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.Internal - ( curveFromCurve + ( FixedWidthBytes + , bsToFixedWidth + , byteWidth + , curveFromCurve , curveToCurveoidBS - , leftPadTo ) import Codec.Encryption.OpenPGP.Policy (ecdhKdfHashDigest) import Codec.Encryption.OpenPGP.Types -import Codec.Encryption.OpenPGP.Types.Internal.Errors - ( CipherError (..) - ) normalizeMontgomeryPublic - :: Int - -> String + :: forall n + . KnownNat n + => String -> B.ByteString - -> Either String B.ByteString -normalizeMontgomeryPublic targetLen label bs - | B.length bs == targetLen = Right bs + -> Either String (FixedWidthBytes n) +normalizeMontgomeryPublic label bs + | B.length bs == targetLen = + note (label ++ show (B.length bs)) (bsToFixedWidth @n bs) | B.length bs < targetLen = - note "leftPadTo: input exceeds target" (leftPadTo targetLen bs) + note "leftPadTo: input exceeds target" (bsToFixedWidth @n bs) | B.length bs == targetLen + 1 && B.head bs == 0x40 = - Right (B.tail bs) + note + (label ++ show (B.length bs)) + (bsToFixedWidth @n (B.tail bs)) | otherwise = Left (label ++ show (B.length bs)) + where + targetLen = byteWidth @n buildECDHKDFParam :: 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 @@ -268,6 +268,8 @@ -- ^ Action for signature context violations (wrong sig type for context) , vpExpiredSignature :: VerificationPolicyAction -- ^ Action for expired signatures + , vpKeyUsageViolation :: VerificationPolicyAction + -- ^ Action for key usage violations (signing with encryption-only key, etc.) } deriving (Eq, Show) @@ -288,6 +290,7 @@ , vpMissingSubkeyBackSignature = VerificationWarning , vpInvalidSignatureContext = VerificationError , vpExpiredSignature = VerificationError + , vpKeyUsageViolation = VerificationError } -- | Strict verification policy: all policy violations are hard errors. @@ -305,6 +308,7 @@ , vpMissingSubkeyBackSignature = VerificationError , vpInvalidSignatureContext = VerificationError , vpExpiredSignature = VerificationError + , vpKeyUsageViolation = VerificationError } {- | Lenient verification policy: all policy violations are warnings. @@ -324,6 +328,7 @@ , vpMissingSubkeyBackSignature = VerificationWarning , vpInvalidSignatureContext = VerificationWarning , vpExpiredSignature = VerificationWarning + , vpKeyUsageViolation = VerificationWarning } -- | Check if a policy action is an error. 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 @@ -9,6 +9,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -114,7 +115,10 @@ ) import Codec.Encryption.OpenPGP.Expirations - ( isPKTimeValidWithSelfSignatures + ( effectiveKeyFlagsAt + , effectiveSubkeyFlagsAt + , isPKTimeValidWithSelfSignatures + , keyFlagsFromSignature , keyStateAt , keyStateValid ) @@ -440,6 +444,7 @@ } case verifyAgainstKeyWithPolicy vp + Nothing -- No TK available for back-signature verification subkeyPKP embSigPkt mt @@ -769,15 +774,20 @@ ) candidateTks candidateErrors = concatMap fst candidateResults - usablePkps = concatMap snd candidateResults - in if null usablePkps + usableTkPkps = concatMap snd candidateResults + in if null usableTkPkps then if null candidateErrors then verificationError (SigningKeyNotFound (issuer sig) (issuerFP sig)) else verificationError (CandidateKeyFailures candidateErrors) - else case verifyAgainstPKPs usablePkps sig verificationTime payload of + else case verifyAgainstTKPKPsWithPolicy + defaultVerificationPolicy + usableTkPkps + sig + verificationTime + payload of Left (CandidateKeyFailures errs) | not (null candidateErrors) -> verificationError @@ -807,31 +817,25 @@ -> ByteString -> Either VerificationError Verification verifyAgainstKeysWithPolicy policy ks sig mt payload = do - let allpkps = + let allTkPkps = + concatMap + ( \tk -> + (Just tk, keyPktPKPayload (_tkPrimaryKey tk)) + : map (\sub -> (Just tk, keyPktPKPayload (fst sub))) (_tkSubs tk) + ) + ks + allpkps = filter - ( \x -> + ( \(_, x) -> (((fingerprint x ==) <$> issuerFP sig) == Just True) || ((==) <$> issuer sig <*> hush (eightOctetKeyID x)) == Just True ) - ( concatMap - ( \x -> - keyPktPKPayload (_tkPrimaryKey x) - : map (keyPktPKPayload . fst) (_tkSubs x) - ) - ks - ) - allCandidatePkps = - concatMap - ( \x -> - keyPktPKPayload (_tkPrimaryKey x) - : map (keyPktPKPayload . fst) (_tkSubs x) - ) - ks + allTkPkps normalizedCandidates - | null allpkps = allCandidatePkps + | null allpkps = allTkPkps | otherwise = allpkps - verifyAgainstPKPsWithPolicy + verifyAgainstTKPKPsWithPolicy policy normalizedCandidates sig @@ -861,6 +865,24 @@ -> ByteString -> Either VerificationError Verification verifyAgainstPKPsWithPolicy policy pkps sig mt payload = + verifyAgainstTKPKPsWithPolicy + policy + (map (Nothing,) pkps) + sig + mt + payload + +{- | Verify a signature against a list of (TK, PKP) pairs with a custom verification policy. +The TK is used for key usage flag checks. +-} +verifyAgainstTKPKPsWithPolicy + :: VerificationPolicy + -> [(Maybe (TK 'PublicTK), SomePKPayload)] + -> Pkt + -> Maybe UTCTime + -> ByteString + -> Either VerificationError Verification +verifyAgainstTKPKPsWithPolicy policy tkPkps sig mt payload = case rights results of [] -> verificationError (CandidateKeyFailures (lefts results)) [r] -> isSignatureExpired sig mt *> pure r @@ -868,8 +890,9 @@ where results = map - (\pkp -> verifyAgainstKeyWithPolicy policy pkp sig mt payload) - pkps + ( \(mTK, pkp) -> verifyAgainstKeyWithPolicy policy mTK pkp sig mt payload + ) + tkPkps resolveCandidateSignerPKPs :: [TK 'PublicTK] @@ -877,9 +900,9 @@ -> Maybe UTCTime -> (SomePKPayload -> Bool) -> TK 'PublicTK - -> ([VerificationError], [SomePKPayload]) + -> ([VerificationError], [(Maybe (TK 'PublicTK), SomePKPayload)]) resolveCandidateSignerPKPs _ _ Nothing matchesP tk = - ([], filter matchesP (candidatePKPs tk)) + ([], map (Just tk,) (filter matchesP (candidatePKPs tk))) resolveCandidateSignerPKPs allKeys _ (Just validationTime) matchesP tk = let rawMatches = filter matchesP (candidatePKPs tk) in case verifyTKWith @@ -901,7 +924,7 @@ pkp ) rawMatches - in (lefts verifiedMatches, rights verifiedMatches) + in (lefts verifiedMatches, map (Just tk,) (rights verifiedMatches)) where timelineValidationTK pkp verifiedTK' | fingerprint pkp @@ -1084,12 +1107,14 @@ -} verifyAgainstKeyWithPolicy :: VerificationPolicy + -> Maybe (TK 'PublicTK) + -- ^ TK containing the signer's key (for key usage checks) -> SomePKPayload -> Pkt -> Maybe UTCTime -> ByteString -> Either VerificationError Verification -verifyAgainstKeyWithPolicy policy pkp sig mt payload = do +verifyAgainstKeyWithPolicy policy mSignerTK pkp sig mt payload = do sigClass <- either (verificationError . const NonSignaturePacket) @@ -1107,6 +1132,8 @@ algoWarnings <- enforceSignatureAlgorithmPolicy policy sigDetails warnings <- enforcePKACompatibility policy sigPayload hashWarnings <- enforceSignatureHashPolicy policy sigHash + keyUsageWarnings <- + enforceKeyUsagePolicy policy mSignerTK pkp sigPayload mt _ <- isSignatureExpired sig mt let signedPayload = BL.toStrict (finalPayload sig payload) enforceLeft16Prefix sigClass sigHash signedPayload @@ -1114,7 +1141,7 @@ Verification verifiedSigner sigPayload - (warnings ++ algoWarnings ++ hashWarnings) + (warnings ++ algoWarnings ++ hashWarnings ++ keyUsageWarnings) ) <$> verify' sigDetails pkp sigHash signedPayload where @@ -1166,6 +1193,41 @@ SHA1 -> enforceDeprecatedHash vp sigHash "SHA1" RIPEMD160 -> enforceDeprecatedHash vp sigHash "RIPEMD160" _ -> Right [] + enforceKeyUsagePolicy vp mSignerTK 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] + _ -> Right [] enforceLeft16Prefix sigClass sigHash signedPayload = do expectedLeft16 <- either @@ -1360,6 +1422,29 @@ in leftPadTo sz raw rsaMPItoSig _ _ = Nothing crazyHash h = BA.convert . hashWith h + +-- | Map a SigType to the required KeyFlag for key usage enforcement. +requiredKeyFlagForSigType :: SigType -> KeyFlag +requiredKeyFlagForSigType st = + case st of + DirectKeySignature -> SignDataKey + GenericCert -> CertifyKeysKey + PersonaCert -> CertifyKeysKey + CasualCert -> CertifyKeysKey + PositiveCert -> CertifyKeysKey + CertRevocationSig -> CertifyKeysKey + SubkeyBindingSig -> SignDataKey + PrimaryKeyBindingSig -> SignDataKey + KeyRevocationSig -> SignDataKey + _ -> SignDataKey -- Conservative default for other types + +-- | Find the fingerprint of a subkey in a TK. +findSubkeyFP + :: SomePKPayload -> TK 'PublicTK -> Maybe Fingerprint +findSubkeyFP pkp tk = + case find (\(kp, _) -> keyPktPKPayload kp == pkp) (_tkSubs tk) of + Just (kp, _) -> Just (fingerprint (keyPktPKPayload kp)) + Nothing -> Nothing isSignatureExpired :: Pkt -> Maybe UTCTime -> Either VerificationError Bool 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 @@ -644,6 +644,7 @@ | SignaturePolicyPKAMismatch !PubKeyAlgorithm !PubKeyAlgorithm | SignaturePolicyAlgorithmDeprecated !PubKeyAlgorithm | SignaturePolicyAlgorithmUnsupported !PubKeyAlgorithm + | SignaturePolicyKeyUsageViolation !SigType !KeyFlag | SignatureExpired | CandidateKeyFailures [VerificationError] | InvalidSubkeyBackSignature !VerificationError @@ -748,6 +749,12 @@ renderVerificationError (SignaturePolicyAlgorithmUnsupported pka) = "verification failed: signature uses unsupported public-key algorithm " ++ show pka +renderVerificationError (SignaturePolicyKeyUsageViolation sigType keyFlag) = + "verification failed: key usage violation - signature type " + ++ show sigType + ++ " requires " + ++ show keyFlag + ++ " flag" renderVerificationError SignatureExpired = "verification failed: signature expired" renderVerificationError (CandidateKeyFailures errs) = 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 @@ -816,6 +816,7 @@ | LegacyIssuerKeyIdInV6Warning | InvalidSignatureContextWarning SigType | ExpiredSignatureWarning + | KeyUsageViolationWarning SigType KeyFlag deriving (Eq, Show) data SOPVVerification diff --git a/Data/Conduit/OpenPGP/Decrypt.hs b/Data/Conduit/OpenPGP/Decrypt.hs --- a/Data/Conduit/OpenPGP/Decrypt.hs +++ b/Data/Conduit/OpenPGP/Decrypt.hs @@ -90,7 +90,8 @@ ) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.Internal - ( bsToFixedWidth + ( FixedWidthBytes + , bsToFixedWidth , checksum16 , checksum16BE , chunksOf8 @@ -140,10 +141,6 @@ ( decryptSecretKeyAddendum ) import Codec.Encryption.OpenPGP.Types -import Codec.Encryption.OpenPGP.Types.Internal.Errors - ( CipherError (..) - , renderCipherError - ) import Data.Conduit.OpenPGP.Compression (conduitDecompress) import Data.Conduit.OpenPGP.Keyring.Instances () @@ -2040,7 +2037,8 @@ . CE.eitherCryptoError $ C25519.secretKey recipientSecretRaw ephBytes <- - either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + unSizedByteArray + <$> either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) ephPub <- either fail pure . first show @@ -2140,7 +2138,8 @@ . CE.eitherCryptoError $ C25519.secretKey recipientSecretRaw ephBytes <- - either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + unSizedByteArray + <$> either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) ephPub <- either fail pure . first show @@ -2213,7 +2212,8 @@ (ephemeralBytes, wrappedSessionKeyBytes) <- either fail pure (parsePKESKv6ECDHEsk X25519 esk) ephBytes <- - either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + unSizedByteArray + <$> either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) recipientSecret <- either fail pure . first show @@ -2233,9 +2233,11 @@ extractX25519RecipientPublic recipientPKP = case _pubkey recipientPKP of EdDSAPubKey EdSigningCurve25519 point -> - normalizeX25519EphemeralPublic (edPointBytes point) + unSizedByteArray + <$> normalizeX25519EphemeralPublic (edPointBytes point) ECDHPubKey (EdDSAPubKey EdSigningCurve25519 point) _ _ -> - normalizeX25519EphemeralPublic (edPointBytes point) + unSizedByteArray + <$> normalizeX25519EphemeralPublic (edPointBytes point) other -> Left ( "X25519 PKESKv6 unwrap requires an X25519 recipient public key, got " @@ -2245,9 +2247,11 @@ extractX448RecipientPublic recipientPKP = case _pubkey recipientPKP of EdDSAPubKey EdSigningCurve448 point -> - normalizeX448EphemeralPublic (edPointBytes point) + unSizedByteArray + <$> normalizeX448EphemeralPublic (edPointBytes point) ECDHPubKey (EdDSAPubKey EdSigningCurve448 point) _ _ -> - normalizeX448EphemeralPublic (edPointBytes point) + unSizedByteArray + <$> normalizeX448EphemeralPublic (edPointBytes point) other -> Left ( "X448 PKESKv6 unwrap requires an X448 recipient public key, got " @@ -2277,7 +2281,8 @@ (ephemeralBytes, wrappedSessionKeyBytes) <- either fail pure (parsePKESKv6ECDHEsk X448 esk) ephBytes <- - either fail pure (normalizeX448EphemeralPublic ephemeralBytes) + unSizedByteArray + <$> either fail pure (normalizeX448EphemeralPublic ephemeralBytes) recipientSecret <- either fail pure . first show @@ -2307,7 +2312,8 @@ (ephemeralBytes, eskBytes) <- either fail pure (parseECDHPKESKMPIs mpis) ephBytes <- - either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) + unSizedByteArray + <$> either fail pure (normalizeX25519EphemeralPublic ephemeralBytes) recipientSecret <- either fail pure . first show @@ -2613,18 +2619,18 @@ ) normalizeX25519EphemeralPublic - :: B.ByteString -> Either String B.ByteString -normalizeX25519EphemeralPublic = - normalizeMontgomeryPublic - 32 + :: B.ByteString -> Either String (FixedWidthBytes 32) +normalizeX25519EphemeralPublic bs = + normalizeMontgomeryPublic @32 "invalid X25519 ephemeral public key length/prefix: " + bs normalizeX448EphemeralPublic - :: B.ByteString -> Either String B.ByteString -normalizeX448EphemeralPublic = - normalizeMontgomeryPublic - 56 + :: B.ByteString -> Either String (FixedWidthBytes 56) +normalizeX448EphemeralPublic bs = + normalizeMontgomeryPublic @56 "invalid X448 ephemeral public key length/prefix: " + bs parseUncompressedPointForCurve :: MonadFail m => ECCT.Curve -> B.ByteString -> m ECCT.Point 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.1 +Version: 3.7.2 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 @@ -251,7 +251,7 @@ common internalmods other-modules: Codec.Encryption.OpenPGP.Internal - , Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes + , Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes , Codec.Encryption.OpenPGP.Internal.CryptoECDH , Codec.Encryption.OpenPGP.Internal.Crypton , Codec.Encryption.OpenPGP.Internal.HOBlockCipher @@ -259,12 +259,12 @@ , Codec.Encryption.OpenPGP.Internal.Whitespace , Codec.Encryption.OpenPGP.Types.Internal.Base , Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes - , Codec.Encryption.OpenPGP.Types.Internal.PKITypes - , Codec.Encryption.OpenPGP.Types.Internal.Errors - , Codec.Encryption.OpenPGP.Types.Internal.PacketClass - , Codec.Encryption.OpenPGP.Types.Internal.Pkt - , Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils - , Codec.Encryption.OpenPGP.Types.Internal.TK + , Codec.Encryption.OpenPGP.Types.Internal.PKITypes + , Codec.Encryption.OpenPGP.Types.Internal.Errors + , Codec.Encryption.OpenPGP.Types.Internal.PacketClass + , Codec.Encryption.OpenPGP.Types.Internal.Pkt + , Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils + , Codec.Encryption.OpenPGP.Types.Internal.TK , Codec.Encryption.OpenPGP.BlockCipher , Codec.Encryption.OpenPGP.SerializeForSigs , Paths_hOpenPGP @@ -347,4 +347,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git - tag: v3.7.1 + tag: v3.7.2