hOpenPGP 3.7.1 → 3.7.2
raw patch · 9 files changed
+377/−103 lines, 9 files
Files
- Codec/Encryption/OpenPGP/Encrypt.hs +41/−27
- Codec/Encryption/OpenPGP/Expirations.hs +150/−4
- Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs +22/−12
- Codec/Encryption/OpenPGP/Policy.hs +5/−0
- Codec/Encryption/OpenPGP/Signatures.hs +114/−29
- Codec/Encryption/OpenPGP/Types/Internal/Errors.hs +7/−0
- Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +1/−0
- Data/Conduit/OpenPGP/Decrypt.hs +28/−22
- hOpenPGP.cabal +9/−9
Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -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
Codec/Encryption/OpenPGP/Expirations.hs view
@@ -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)
Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs view
@@ -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
Codec/Encryption/OpenPGP/Policy.hs view
@@ -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.
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -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
Codec/Encryption/OpenPGP/Types/Internal/Errors.hs view
@@ -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) =
Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs view
@@ -816,6 +816,7 @@ | LegacyIssuerKeyIdInV6Warning | InvalidSignatureContextWarning SigType | ExpiredSignatureWarning+ | KeyUsageViolationWarning SigType KeyFlag deriving (Eq, Show) data SOPVVerification
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -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
hOpenPGP.cabal view
@@ -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