hOpenPGP 3.5 → 3.5.1
raw patch · 11 files changed
+1677/−308 lines, 11 filesdep ~nettle
Dependency ranges changed: nettle
Files
- Codec/Encryption/OpenPGP/BlockCipher.hs +144/−65
- Codec/Encryption/OpenPGP/Encrypt.hs +320/−132
- Codec/Encryption/OpenPGP/Expirations.hs +1/−0
- Codec/Encryption/OpenPGP/Policy.hs +9/−2
- Codec/Encryption/OpenPGP/SEIPDv2.hs +30/−0
- Codec/Encryption/OpenPGP/Signatures.hs +3/−0
- Codec/Encryption/OpenPGP/Signing.hs +898/−0
- Codec/Encryption/OpenPGP/Subpackets.hs +1/−1
- hOpenPGP.cabal +5/−3
- tests/Tests/Encryption.hs +226/−105
- tests/Tests/Keys.hs +40/−0
Codec/Encryption/OpenPGP/BlockCipher.hs view
@@ -2,20 +2,15 @@ -- Copyright © 2013-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE RankNTypes #-} module Codec.Encryption.OpenPGP.BlockCipher- ( CipherError(..)- , renderCipherError- , keySize- , withSymmetricCipher- ) where--import Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes (HOWrappedOldCCT(..))-import Codec.Encryption.OpenPGP.Internal.Crypton (HOWrappedCCT(..))-import Codec.Encryption.OpenPGP.Internal.HOBlockCipher-import Codec.Encryption.OpenPGP.Types+ ( CipherError (..)+ , renderCipherError+ , keySize+ , supportedSymmetricAlgorithmsForCFB+ , withSymmetricCipher+ ) where import qualified Crypto.Cipher.AES as AES import qualified Crypto.Cipher.Blowfish as Blowfish@@ -23,87 +18,171 @@ 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 (..)+ )+import Codec.Encryption.OpenPGP.Internal.Crypton+ ( HOWrappedCCT (..)+ )+import Codec.Encryption.OpenPGP.Internal.HOBlockCipher+import Codec.Encryption.OpenPGP.Types+ -- | Errors that can arise from block-cipher operations in this library. data CipherError- = -- | The algorithm is not supported or not implemented.- UnsupportedAlgorithm SymmetricAlgorithm- | -- | Cipher initialization failed (bad key material).- CipherInitFailed SymmetricAlgorithm String- | -- | A CFB or other block-cipher operation failed.- CipherOperationFailed String- deriving (Eq, Show)+ = -- | The algorithm is not supported or not implemented.+ UnsupportedAlgorithm SymmetricAlgorithm+ | -- | Cipher initialization failed (bad key material).+ CipherInitFailed SymmetricAlgorithm String+ | -- | A CFB or other block-cipher operation failed.+ CipherOperationFailed String+ deriving (Eq, Show) renderCipherError :: CipherError -> String renderCipherError (UnsupportedAlgorithm sa) =- "Unsupported symmetric algorithm: " ++ show sa+ "Unsupported symmetric algorithm: " ++ show sa renderCipherError (CipherInitFailed sa msg) =- "Cipher initialization failed for " ++ show sa ++ ": " ++ msg+ "Cipher initialization failed for " ++ show sa ++ ": " ++ msg renderCipherError (CipherOperationFailed msg) =- "Cipher operation failed: " ++ msg+ "Cipher operation failed: " ++ msg -type HOCipher a- = forall cipher. HOBlockCipher cipher =>- cipher -> Either String a+type HOCipher a =+ forall cipher+ . HOBlockCipher cipher+ => cipher -> Either String a -withSymmetricCipher ::- SymmetricAlgorithm -> B.ByteString -> HOCipher a -> Either CipherError a+withSymmetricCipher+ :: SymmetricAlgorithm+ -> B.ByteString+ -> HOCipher a+ -> Either CipherError a withSymmetricCipher Plaintext _ _ = Left (UnsupportedAlgorithm Plaintext)-withSymmetricCipher IDEA _ _ = Left (UnsupportedAlgorithm IDEA)+withSymmetricCipher IDEA _ _ = Left (UnsupportedAlgorithm IDEA) withSymmetricCipher ReservedSAFER _ _ = Left (UnsupportedAlgorithm ReservedSAFER)-withSymmetricCipher ReservedDES _ _ = Left (UnsupportedAlgorithm ReservedDES)-withSymmetricCipher (OtherSA n) _ _ = Left (UnsupportedAlgorithm (OtherSA n))+withSymmetricCipher ReservedDES _ _ = Left (UnsupportedAlgorithm ReservedDES)+withSymmetricCipher (OtherSA n) _ _ = Left (UnsupportedAlgorithm (OtherSA n)) withSymmetricCipher CAST5 keyBytes f =- initAndRun CAST5 (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.CAST128)) f+ initAndRun+ CAST5+ ( cipherInit keyBytes+ :: Either String (HOWrappedOldCCT CNC.CAST128)+ )+ f withSymmetricCipher Twofish keyBytes f =- initAndRun Twofish (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.TWOFISH)) f+ initAndRun+ Twofish+ ( cipherInit keyBytes+ :: Either String (HOWrappedOldCCT CNC.TWOFISH)+ )+ f withSymmetricCipher TripleDES keyBytes f =- initAndRun TripleDES (cipherInit keyBytes :: Either String (HOWrappedCCT TripleDES.DES_EDE3)) f+ initAndRun+ TripleDES+ ( cipherInit keyBytes+ :: Either String (HOWrappedCCT TripleDES.DES_EDE3)+ )+ f withSymmetricCipher Blowfish keyBytes f =- initAndRun Blowfish (cipherInit keyBytes :: Either String (HOWrappedCCT Blowfish.Blowfish128)) f+ initAndRun+ Blowfish+ ( cipherInit keyBytes+ :: Either String (HOWrappedCCT Blowfish.Blowfish128)+ )+ f withSymmetricCipher AES128 keyBytes f =- initAndRun AES128 (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES128)) f+ initAndRun+ AES128+ (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES128))+ f withSymmetricCipher AES192 keyBytes f =- initAndRun AES192 (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES192)) f+ initAndRun+ AES192+ (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES192))+ f withSymmetricCipher AES256 keyBytes f =- initAndRun AES256 (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES256)) f+ initAndRun+ AES256+ (cipherInit keyBytes :: Either String (HOWrappedCCT AES.AES256))+ f withSymmetricCipher Camellia128 keyBytes f =- initAndRun Camellia128 (cipherInit keyBytes :: Either String (HOWrappedCCT Camellia.Camellia128)) f+ initAndRun+ Camellia128+ ( cipherInit keyBytes+ :: Either String (HOWrappedCCT Camellia.Camellia128)+ )+ f withSymmetricCipher Camellia192 keyBytes f =- initAndRun Camellia192 (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.Camellia192)) f+ initAndRun+ Camellia192+ ( cipherInit keyBytes+ :: Either String (HOWrappedOldCCT CNC.Camellia192)+ )+ f withSymmetricCipher Camellia256 keyBytes f =- initAndRun Camellia256 (cipherInit keyBytes :: Either String (HOWrappedOldCCT CNC.Camellia256)) f+ initAndRun+ Camellia256+ ( cipherInit keyBytes+ :: Either String (HOWrappedOldCCT CNC.Camellia256)+ )+ f -initAndRun ::- HOBlockCipher cipher- => SymmetricAlgorithm- -> Either String cipher- -> (cipher -> Either String a)- -> Either CipherError a+{- | Symmetric algorithms that the CFB (SEIPDv1) encryption backend can use for+new *encryption*, restricted to the RFC 9580 §9.3-permitted set.++This is the intersection of:+ * algorithms 'withSymmetricCipher' can actually encrypt+ (`CAST5`, `Twofish`, `TripleDES`, `Blowfish`, `AES128/192/256`,+ `Camellia128/192/256`), minus+ * algorithms RFC 9580 §9.3 forbids for new encryption (`IDEA`, `TripleDES`,+ `CAST5`).++Decryption backward-compatibility is unaffected: 'withSymmetricCipher' still+handles all ten algorithms, including the three forbidden above.+-}+supportedSymmetricAlgorithmsForCFB :: Set.Set SymmetricAlgorithm+supportedSymmetricAlgorithmsForCFB =+ Set.fromList+ [ Twofish+ , Blowfish+ , AES128+ , AES192+ , AES256+ , Camellia128+ , Camellia192+ , Camellia256+ ]++initAndRun+ :: HOBlockCipher cipher+ => SymmetricAlgorithm+ -> Either String cipher+ -> (cipher -> Either String a)+ -> Either CipherError a initAndRun algo initResult f =- case initResult of- Left err -> Left (CipherInitFailed algo err)- Right c ->- case f c of- Left err -> Left (CipherOperationFailed err)- Right x -> Right x+ case initResult of+ Left err -> Left (CipherInitFailed algo err)+ Right c ->+ case f c of+ Left err -> Left (CipherOperationFailed err)+ Right x -> Right x -- In octets. Keep this as an explicit OpenPGP algorithm mapping so behavior -- stays stable across mixed backends (crypton/nettle) and includes unsupported -- algorithms that never reach backend cipher types. keySize :: SymmetricAlgorithm -> Either CipherError Int-keySize Plaintext = Right 0-keySize IDEA = Right 16-keySize TripleDES = Right 24-keySize CAST5 = Right 16-keySize Blowfish = Right 16+keySize Plaintext = Right 0+keySize IDEA = Right 16+keySize TripleDES = Right 24+keySize CAST5 = Right 16+keySize Blowfish = Right 16 keySize ReservedSAFER = Left (UnsupportedAlgorithm ReservedSAFER)-keySize ReservedDES = Left (UnsupportedAlgorithm ReservedDES)-keySize AES128 = Right 16-keySize AES192 = Right 24-keySize AES256 = Right 32-keySize Twofish = Right 32-keySize Camellia128 = Right 16-keySize Camellia192 = Right 24-keySize Camellia256 = Right 32-keySize (OtherSA n) = Left (UnsupportedAlgorithm (OtherSA n))+keySize ReservedDES = Left (UnsupportedAlgorithm ReservedDES)+keySize AES128 = Right 16+keySize AES192 = Right 24+keySize AES256 = Right 32+keySize Twofish = Right 32+keySize Camellia128 = Right 16+keySize Camellia192 = Right 24+keySize Camellia256 = Right 32+keySize (OtherSA n) = Left (UnsupportedAlgorithm (OtherSA n))
Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -54,6 +54,10 @@ , encryptForRecipients , encryptForRecipientsLegacy , encryptForRecipientsWithCapabilityNegotiation+ , SharedSessionRecipient (..)+ , SharedSessionEncryptRequest (..)+ , SharedSessionEncryptResult (..)+ , encryptWithSharedSessionKey , PKESKV3SessionMaterial , PKESKV6RawSessionMaterial , PKESKSessionMaterial@@ -91,9 +95,13 @@ import Control.Applicative ((<|>)) import Control.Error.Util (note) import Control.Lens (ix, (.~))-import Control.Monad (when)+import Control.Monad (forM, when) import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT (..), runExceptT)+import Control.Monad.Trans.Except+ ( ExceptT (..)+ , runExceptT+ , throwE+ ) import qualified Crypto.Error as CE import qualified Crypto.Hash.Algorithms as CHA import Crypto.KDF.HKDF (expand, extract)@@ -114,7 +122,7 @@ import qualified Data.ByteString.Lazy as BL import Data.Containers.ListUtils (nubOrd) import Data.Int (Int64)-import Data.List (find, maximumBy)+import Data.List (elemIndex, find, maximumBy, sortOn) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromMaybe, listToMaybe) import Data.Ord (comparing)@@ -128,6 +136,7 @@ ( CipherError (..) , keySize , renderCipherError+ , supportedSymmetricAlgorithmsForCFB , withSymmetricCipher ) import Codec.Encryption.OpenPGP.CFB@@ -181,7 +190,6 @@ , messageDefaultChunkSize , messageDefaultSymmetricAlgorithm , messageSEIPDv2SaltOctets- , messageSEIPDv2SymmetricAlgorithms , policyForRFC , policyMessageEncryption )@@ -196,6 +204,8 @@ , encryptSKESK6SessionKey , renderSEIPDv2Failure , seipdv2SymmetricKeySize+ , supportedSEIPDv2AEADAlgorithms+ , supportedSEIPDv2SymmetricAlgorithms ) import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.SignatureQualities@@ -336,7 +346,8 @@ , recipientCapabilityFeatures :: Set.Set FeatureFlag , recipientCapabilityPreferredSymmetricAlgorithms :: [SymmetricAlgorithm]- , recipientCapabilityPreferredAEADAlgorithms :: [AEADAlgorithm]+ , recipientCapabilityPreferredCiphersuites+ :: [(SymmetricAlgorithm, AEADAlgorithm)] } deriving (Eq, Show) @@ -371,9 +382,6 @@ {- | Extract encrypt-relevant recipient capabilities from effective self-signature subpackets.--RFC 9580 preferred AEAD ciphersuites are currently carried through-'OtherSigSub' type 39 and decoded into AEAD preferences here. -} recipientCapabilitiesFromSubpacketPayloads :: SomePKPayload@@ -382,9 +390,6 @@ recipientCapabilitiesFromSubpacketPayloads recipient payloads = foldl' step (emptyRecipientCapabilities recipient) payloads where- preferredAEADCiphersuitesSubpacketType :: Word8- preferredAEADCiphersuitesSubpacketType = 39- step caps payload = case payload of KeyFlags flags ->@@ -404,17 +409,9 @@ } PreferredAEADCiphersuites ciphersuites -> caps- { recipientCapabilityPreferredAEADAlgorithms =- recipientCapabilityPreferredAEADAlgorithms caps- ++ preferredAEADAlgorithmsFromCiphersuitePairs ciphersuites+ { recipientCapabilityPreferredCiphersuites =+ recipientCapabilityPreferredCiphersuites caps ++ ciphersuites }- OtherSigSub subpacketType rawPayload- | subpacketType == preferredAEADCiphersuitesSubpacketType ->- caps- { recipientCapabilityPreferredAEADAlgorithms =- recipientCapabilityPreferredAEADAlgorithms caps- ++ preferredAEADAlgorithmsFromCiphersuites rawPayload- } _ -> caps emptyRecipientCapabilities key =@@ -424,23 +421,9 @@ , recipientCapabilityKeyFlags = Set.empty , recipientCapabilityFeatures = Set.empty , recipientCapabilityPreferredSymmetricAlgorithms = []- , recipientCapabilityPreferredAEADAlgorithms = []+ , recipientCapabilityPreferredCiphersuites = [] } - preferredAEADAlgorithmsFromCiphersuites- :: BL.ByteString -> [AEADAlgorithm]- preferredAEADAlgorithmsFromCiphersuites =- nubOrd . parsePairs . BL.unpack- where- parsePairs (_symAlgo : aeadAlgo : rest) =- (toFVal aeadAlgo :: AEADAlgorithm) : parsePairs rest- parsePairs _ = []-- preferredAEADAlgorithmsFromCiphersuitePairs- :: [(SymmetricAlgorithm, AEADAlgorithm)] -> [AEADAlgorithm]- preferredAEADAlgorithmsFromCiphersuitePairs =- nubOrd . map snd- recipientCapabilitySupportsEncryption :: RecipientCapabilities -> Bool recipientCapabilitySupportsEncryption caps =@@ -1040,6 +1023,132 @@ } deriving (Eq, Show) +data SharedSessionRecipient+ = SharedPublicKey RecipientEncryptionTarget+ | SharedPassword Passphrase+ deriving (Eq, Show)++data SharedSessionEncryptRequest+ = SharedSessionEncryptRequest+ { sharedSessionRecipients :: [SharedSessionRecipient]+ , sharedSessionPayloadShape :: RecipientPayloadShape+ , sharedSessionPayload :: B.ByteString+ , sharedSessionSymmetricAlgorithm :: SymmetricAlgorithm+ , sharedSessionAEADAlgorithm :: AEADAlgorithm+ , sharedSessionChunkSize :: Word8+ , sharedSessionSalt :: Salt+ , sharedSessionS2K :: S2K+ , sharedSessionKey :: Maybe PKESKSessionMaterial+ , sharedSessionSKESKVersionPolicy :: PassphraseSKESKVersionPolicy+ }+ deriving (Eq, Show)++data SharedSessionEncryptResult+ = SharedSessionEncryptResult+ { sharedSessionPackets :: [Pkt]+ , sharedSessionMaterial :: PKESKSessionMaterial+ }+ deriving (Eq, Show)++encryptWithSharedSessionKey+ :: MonadRandom m+ => SharedSessionEncryptRequest+ -> m (Either PKESKEncryptError SharedSessionEncryptResult)+encryptWithSharedSessionKey request+ | null recipients = pure (Left NoRecipientsProvided)+ | otherwise = runExceptT $ do+ material <- case sharedSessionKey request of+ Just explicit -> pure explicit+ Nothing -> ExceptT $ generateSessionKeyMaterial symalgo+ when (pkeskSessionAlgorithm material /= symalgo) $+ throwE (InvalidSessionKeyLength symalgo 0 0)+ publicPackets <-+ ExceptT $+ buildPKESKPktsForRecipientTargetsWithSelectorTyped+ (recipientVersionStrategyForProfileTyped EncryptStrictDefaultW)+ publicTargets+ material+ passwordPackets <- forM passwordRecipients $ \passphrase ->+ ExceptT . pure $+ buildSharedPasswordSKESK request material passphrase+ packets <-+ ExceptT . pure $+ buildEncryptedPacketSequenceWithShape+ symalgo+ aead+ chunkSize+ (sharedSessionPayloadShape request)+ salt+ (pkeskSessionKey material)+ (publicPackets <> passwordPackets)+ (sharedSessionPayload request)+ pure+ SharedSessionEncryptResult+ { sharedSessionPackets = packets+ , sharedSessionMaterial = material+ }+ where+ recipients = sharedSessionRecipients request+ publicTargets = [target | SharedPublicKey target <- recipients]+ passwordRecipients = [passphrase | SharedPassword passphrase <- recipients]+ symalgo = sharedSessionSymmetricAlgorithm request+ aead = sharedSessionAEADAlgorithm request+ chunkSize = sharedSessionChunkSize request+ salt = sharedSessionSalt request++buildSharedPasswordSKESK+ :: SharedSessionEncryptRequest+ -> PKESKSessionMaterial+ -> Passphrase+ -> Either PKESKEncryptError Pkt+buildSharedPasswordSKESK request material (Passphrase password) =+ case sharedSessionSKESKVersionPolicy request of+ PassphraseSKESKForceV4Interop -> buildV4+ PassphraseSKESKPreferV6 -> buildV6+ where+ symalgo = sharedSessionSymmetricAlgorithm request+ s2k = sharedSessionS2K request+ buildV4 = do+ keyLen <-+ first+ (UnsupportedSessionKeyAlgorithm symalgo . renderCipherError)+ $ keySize symalgo+ _wrappingKey <-+ first (PayloadBuildFailure . show) $+ string2Key s2k keyLen password+ pure . SKESKPkt . SKESKPayloadV4Packet $+ SKESKPayloadV4 symalgo s2k Nothing+ buildV6 = do+ keyLen <-+ first+ (UnsupportedSessionKeyAlgorithm symalgo . renderCipherError)+ $ keySize symalgo+ wrappingKey <-+ first (PayloadBuildFailure . show) $+ string2Key s2k keyLen password+ let iv = B.take nonceSize (unSalt (sharedSessionSalt request))+ kek <-+ first (PayloadBuildFailure . renderSEIPDv2Failure) $+ deriveSKESK6KEK symalgo aead wrappingKey+ (wrapped, tag) <-+ first (PayloadBuildFailure . renderSEIPDv2Failure) $+ encryptSKESK6SessionKey+ symalgo+ aead+ kek+ iv+ (unSessionKey (pkeskSessionKey material))+ pure . SKESKPkt . SKESKPayloadV6Packet $+ SKESKPayloadV6+ symalgo+ aead+ s2k+ iv+ wrapped+ tag+ aead = sharedSessionAEADAlgorithm request+ nonceSize = 15+ data RecipientEncryptRequestOverrides (v :: SEIPDVersion) where RecipientEncryptRequestSEIPDv1Overrides :: { recipientEncryptRequestIVOverride :: Maybe IV@@ -1346,8 +1455,8 @@ {- | Encrypt for recipient targets with an explicit capability-negotiation mode. When negotiation is on, symmetric and AEAD selection use the common-intersection of recipient preferences constrained by the active policy.-When off, policy defaults are used.+intersection of recipient ciphersuite preferences constrained by the active+policy. When off, policy defaults are used. -} encryptForRecipientsWithCapabilityNegotiation :: MonadRandom m@@ -1357,13 +1466,15 @@ encryptForRecipientsWithCapabilityNegotiation negotiationMode request | null targets = pure (Left NoRecipientsProvided) | otherwise = runExceptT $ do- symalgo <-+ (symalgo, aead) <- ExceptT . pure $- selectSymmetricAlgorithm+ selectCiphersuite negotiationMode request messagePolicy targets+ aeadOverride+ seipdVersion sessionMaterial <- ExceptT $ generateSessionKeyMaterial symalgo pkeskPkts <- ExceptT $@@ -1375,6 +1486,7 @@ request targets symalgo+ aead sessionMaterial pkeskPkts where@@ -1388,55 +1500,63 @@ policyMessageEncryption (policyForRFC RFC9580) EncryptInteropLegacyW -> policyMessageEncryption (policyForRFC RFC4880)+ aeadOverride =+ case recipientEncryptRequestOverrides request of+ RecipientEncryptRequestSEIPDv2Overrides+ { recipientEncryptRequestAEADOverride = override+ } ->+ override+ RecipientEncryptRequestSEIPDv1Overrides {} ->+ Nothing+ seipdVersion =+ case recipientEncryptRequestOverrides request of+ RecipientEncryptRequestSEIPDv1Overrides {} -> SEIPDv1+ RecipientEncryptRequestSEIPDv2Overrides {} ->+ if null (recipientsMissingSEIPDv2Support targets)+ then SEIPDv2+ else SEIPDv1 buildEncryptedPayload :: MonadRandom m => RecipientEncryptRequest v -> [RecipientEncryptionTarget] -> SymmetricAlgorithm+ -> AEADAlgorithm -> PKESKSessionMaterial -> [Pkt] -> ExceptT PKESKEncryptError m RecipientEncryptResult- buildEncryptedPayload request targets symalgo sessionMaterial pkeskPkts =+ buildEncryptedPayload request targets symalgo aead sessionMaterial pkeskPkts = case recipientEncryptRequestOverrides request of RecipientEncryptRequestSEIPDv2Overrides- { recipientEncryptRequestAEADOverride = aeadOverride- , recipientEncryptRequestChunkSizeOverride = chunkSizeOverride+ { recipientEncryptRequestChunkSizeOverride = chunkSizeOverride , recipientEncryptRequestSaltOverride = saltOverride } -> case recipientsMissingSEIPDv2Support targets of- [] ->- case selectAEADAlgorithm- negotiationMode- messagePolicy- targets- aeadOverride of- Left err -> ExceptT . pure $ Left err- Right aead -> do- salt <-- lift $ maybe (Salt <$> getRandomBytes 32) pure saltOverride- let chunkSize =- maybe- (messageDefaultChunkSize messagePolicy)- id- chunkSizeOverride- ExceptT . pure $- fmap- ( \pkts ->- RecipientEncryptResult- { recipientEncryptPackets = pkts- , recipientEncryptSessionMaterial = sessionMaterial- }- )- ( buildEncryptedPacketSequenceWithShape- symalgo- aead- chunkSize- (recipientEncryptRequestPayloadShape request)- salt- (pkeskSessionKey sessionMaterial)- pkeskPkts- (recipientEncryptRequestPayload request)- )+ [] -> do+ salt <-+ lift $ maybe (Salt <$> getRandomBytes 32) pure saltOverride+ let chunkSize =+ maybe+ (messageDefaultChunkSize messagePolicy)+ id+ chunkSizeOverride+ ExceptT . pure $+ fmap+ ( \pkts ->+ RecipientEncryptResult+ { recipientEncryptPackets = pkts+ , recipientEncryptSessionMaterial = sessionMaterial+ }+ )+ ( buildEncryptedPacketSequenceWithShape+ symalgo+ aead+ chunkSize+ (recipientEncryptRequestPayloadShape request)+ salt+ (pkeskSessionKey sessionMaterial)+ pkeskPkts+ (recipientEncryptRequestPayload request)+ ) _missingSEIPDv2 -> case recipientsMissingSEIPDv1Support targets of [] -> do@@ -1541,111 +1661,179 @@ Nothing -> True Just caps -> recipientCapabilityAdvertisesSEIPDv2Support caps -selectSymmetricAlgorithm+selectCiphersuite :: RecipientCapabilityNegotiationMode -> RecipientEncryptRequest v -> MessageEncryptionPolicy -> [RecipientEncryptionTarget]- -> Either PKESKEncryptError SymmetricAlgorithm-selectSymmetricAlgorithm negotiationMode request messagePolicy targets =+ -> Maybe AEADAlgorithm+ -> SEIPDVersion+ -> Either PKESKEncryptError (SymmetricAlgorithm, AEADAlgorithm)+selectCiphersuite negotiationMode request messagePolicy targets aeadOverride seipdVersion = case recipientEncryptRequestSymmetricOverride request of- Just override -> Right override+ Just symOverride ->+ case aeadOverride of+ Just aeadOverride ->+ Right (symOverride, aeadOverride)+ Nothing ->+ case negotiationMode of+ RecipientCapabilityNegotiationOff ->+ Right (symOverride, messageDefaultAEADAlgorithm messagePolicy)+ RecipientCapabilityNegotiationOn ->+ case seipdVersion of+ SEIPDv2 ->+ negotiateAEADAlgorithmWithSymmetric+ messagePolicy+ targets+ symOverride+ >>= \aead -> Right (symOverride, aead)+ SEIPDv1 ->+ Right+ ( symOverride+ , messageDefaultAEADAlgorithm messagePolicy+ ) Nothing -> case negotiationMode of RecipientCapabilityNegotiationOff ->- Right (messageDefaultSymmetricAlgorithm messagePolicy)+ case aeadOverride of+ Just aeadOverride ->+ Right+ (messageDefaultSymmetricAlgorithm messagePolicy, aeadOverride)+ Nothing ->+ Right+ ( messageDefaultSymmetricAlgorithm messagePolicy+ , messageDefaultAEADAlgorithm messagePolicy+ ) RecipientCapabilityNegotiationOn ->- negotiateSymmetricAlgorithm messagePolicy targets+ case seipdVersion of+ SEIPDv2 ->+ case aeadOverride of+ Just aeadOverride ->+ negotiateSymmetricAlgorithmWithAEADOverride+ messagePolicy+ targets+ aeadOverride+ >>= \sym -> Right (sym, aeadOverride)+ Nothing ->+ negotiateCiphersuite messagePolicy targets+ SEIPDv1 ->+ negotiateSymmetricAlgorithmOnly messagePolicy targets+ >>= \sym ->+ Right (sym, messageDefaultAEADAlgorithm messagePolicy) -selectAEADAlgorithm- :: RecipientCapabilityNegotiationMode- -> MessageEncryptionPolicy+negotiateCiphersuite+ :: MessageEncryptionPolicy -> [RecipientEncryptionTarget]- -> Maybe AEADAlgorithm+ -> Either PKESKEncryptError (SymmetricAlgorithm, AEADAlgorithm)+implicitSEIPDv2Ciphersuite :: (SymmetricAlgorithm, AEADAlgorithm)+implicitSEIPDv2Ciphersuite = (AES128, OCB)+negotiateCiphersuite messagePolicy targets =+ chooseCommonAlgorithm+ recipientChoices+ (RecipientCapabilityNoCommonAEADAlgorithms [])+ where+ supportedSymmetricSet = supportedSEIPDv2SymmetricAlgorithms+ supportedAEADSet = supportedSEIPDv2AEADAlgorithms+ recipientChoices = map choicesForTarget targets+ choicesForTarget target =+ case recipientEncryptionTargetCapabilities target of+ Just caps ->+ let preferred = recipientCapabilityPreferredCiphersuites caps+ supportedPreferred =+ [ c+ | c@(s, a) <- preferred+ , s `Set.member` supportedSymmetricSet+ , a `Set.member` supportedAEADSet+ ]+ in nubOrd (supportedPreferred ++ [implicitSEIPDv2Ciphersuite])+ Nothing -> [implicitSEIPDv2Ciphersuite]++negotiateAEADAlgorithmWithSymmetric+ :: MessageEncryptionPolicy+ -> [RecipientEncryptionTarget]+ -> SymmetricAlgorithm -> Either PKESKEncryptError AEADAlgorithm-selectAEADAlgorithm negotiationMode messagePolicy targets override =- case override of- Just explicit -> Right explicit- Nothing ->- case negotiationMode of- RecipientCapabilityNegotiationOff ->- Right (messageDefaultAEADAlgorithm messagePolicy)- RecipientCapabilityNegotiationOn ->- negotiateAEADAlgorithm messagePolicy targets+negotiateAEADAlgorithmWithSymmetric messagePolicy targets symOverride =+ chooseCommonAlgorithm+ recipientChoices+ (RecipientCapabilityNoCommonAEADAlgorithms [])+ where+ supportedAEADSet = supportedSEIPDv2AEADAlgorithms+ recipientChoices = map choicesForTarget targets+ choicesForTarget target =+ case recipientEncryptionTargetCapabilities target of+ Just caps ->+ let preferred = recipientCapabilityPreferredCiphersuites caps+ matching = [a | (s, a) <- preferred, s == symOverride]+ supportedMatching = [a | a <- matching, a `Set.member` supportedAEADSet]+ in nubOrd+ (supportedMatching ++ [messageDefaultAEADAlgorithm messagePolicy])+ Nothing -> [messageDefaultAEADAlgorithm messagePolicy] -negotiateSymmetricAlgorithm+negotiateSymmetricAlgorithmWithAEADOverride :: MessageEncryptionPolicy -> [RecipientEncryptionTarget]+ -> AEADAlgorithm -> Either PKESKEncryptError SymmetricAlgorithm-negotiateSymmetricAlgorithm messagePolicy targets =+negotiateSymmetricAlgorithmWithAEADOverride messagePolicy targets aeadOverride = chooseCommonAlgorithm- policyOrder recipientChoices- ( RecipientCapabilityNoCommonSymmetricAlgorithms- (concat recipientChoices)- )+ (RecipientCapabilityNoCommonAEADAlgorithms []) where- policyOrder =- case messageSEIPDv2SymmetricAlgorithms messagePolicy of- [] -> [messageDefaultSymmetricAlgorithm messagePolicy]- syms -> syms+ supportedSymmetricSet = supportedSEIPDv2SymmetricAlgorithms recipientChoices = map choicesForTarget targets choicesForTarget target = case recipientEncryptionTargetCapabilities target of Just caps ->- let preferred = recipientCapabilityPreferredSymmetricAlgorithms caps- preferredSet = Set.fromList preferred- allowed = [alg | alg <- policyOrder, alg `Set.member` preferredSet]- in if null allowed- then policyOrder- else allowed- Nothing -> policyOrder+ let preferred = recipientCapabilityPreferredCiphersuites caps+ matching = [s | (s, a) <- preferred, a == aeadOverride]+ supportedMatching = [s | s <- matching, s `Set.member` supportedSymmetricSet]+ in nubOrd (supportedMatching ++ [AES128])+ Nothing -> [AES128] -negotiateAEADAlgorithm+negotiateSymmetricAlgorithmOnly :: MessageEncryptionPolicy -> [RecipientEncryptionTarget]- -> Either PKESKEncryptError AEADAlgorithm-negotiateAEADAlgorithm messagePolicy targets =+ -> Either PKESKEncryptError SymmetricAlgorithm+negotiateSymmetricAlgorithmOnly messagePolicy targets = chooseCommonAlgorithm- policyOrder recipientChoices- ( RecipientCapabilityNoCommonAEADAlgorithms- (concat recipientChoices)- )+ (RecipientCapabilityNoCommonSymmetricAlgorithms []) where- policyOrder =- nubOrd- (messageDefaultAEADAlgorithm messagePolicy : [OCB, EAX, GCM])+ senderSymmetricAlgorithms = Set.toList supportedSymmetricAlgorithmsForCFB recipientChoices = map choicesForTarget targets choicesForTarget target = case recipientEncryptionTargetCapabilities target of Just caps ->- let preferred = recipientCapabilityPreferredAEADAlgorithms caps+ let preferred = recipientCapabilityPreferredSymmetricAlgorithms caps preferredSet = Set.fromList preferred- allowed = [alg | alg <- policyOrder, alg `Set.member` preferredSet]+ allowed =+ [s | s <- senderSymmetricAlgorithms, s `Set.member` preferredSet] in if null allowed- then policyOrder+ then senderSymmetricAlgorithms else allowed- Nothing -> policyOrder+ Nothing -> senderSymmetricAlgorithms chooseCommonAlgorithm :: (Eq a, Ord a)- => [a]- -> [[a]]+ => [[a]] -> RecipientCapabilityError -> Either PKESKEncryptError a-chooseCommonAlgorithm policyOrder recipientChoices err =+chooseCommonAlgorithm recipientChoices err = case recipientChoices of [] -> Left (RecipientCapabilitySelectionFailure err) (firstChoices : restChoices) -> let common = foldl' intersectOrdered firstChoices restChoices- commonSet = Set.fromList common- orderedCommon = [alg | alg <- policyOrder, alg `Set.member` commonSet]- in case orderedCommon of+ in case orderByRecipientPreference common recipientChoices of (selected : _) -> Right selected [] -> Left (RecipientCapabilitySelectionFailure err) where 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]+ )+ candidates promoteRecipientStrategy :: RecipientPKESKVersionStrategy
Codec/Encryption/OpenPGP/Expirations.hs view
@@ -346,6 +346,7 @@ isPreferenceSubpacket (SigSubPacket _ (KeyServerPreferences _)) = True isPreferenceSubpacket (SigSubPacket _ (PreferredKeyServer _)) = True isPreferenceSubpacket (SigSubPacket _ (Features _)) = True+isPreferenceSubpacket (SigSubPacket _ (PreferredAEADCiphersuites _)) = True isPreferenceSubpacket (SigSubPacket _ (OtherSigSub subpacketType _)) = subpacketType == 39 isPreferenceSubpacket _ = False
Codec/Encryption/OpenPGP/Policy.hs view
@@ -70,9 +70,13 @@ import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.Kind (Constraint)+import qualified Data.Set as Set import Data.Word (Word8) import GHC.TypeLits (ErrorMessage (..), TypeError) +import Codec.Encryption.OpenPGP.SEIPDv2+ ( supportedSEIPDv2SymmetricAlgorithms+ ) import Codec.Encryption.OpenPGP.SignatureQualities (sigType) import Codec.Encryption.OpenPGP.Types @@ -523,8 +527,11 @@ :: OpenPGPPolicy -> SymmetricAlgorithm -> Bool supportsSEIPDv2Symmetric policy sa = sa- `elem` messageSEIPDv2SymmetricAlgorithms- (policyMessageEncryption policy)+ `Set.member` Set.fromList+ ( messageSEIPDv2SymmetricAlgorithms+ (policyMessageEncryption policy)+ )+ && sa `Set.member` supportedSEIPDv2SymmetricAlgorithms secretKeyProtectionPolicyForKeyVersion :: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy
Codec/Encryption/OpenPGP/SEIPDv2.hs view
@@ -9,6 +9,8 @@ module Codec.Encryption.OpenPGP.SEIPDv2 ( SEIPDv2Failure (..) , aeadModeAndNonceSizeForSEIPDv2+ , supportedSEIPDv2AEADAlgorithms+ , supportedSEIPDv2SymmetricAlgorithms , seipdv2SymmetricKeySize , deriveSKESK6KEK , encryptSKESK6SessionKey@@ -23,6 +25,8 @@ import Data.Bifunctor (first) import qualified Data.ByteArray as BA import qualified Data.ByteString as B+import Data.Either (isRight)+import qualified Data.Set as Set import qualified "crypton" Crypto.Cipher.Types as CCT import Codec.Encryption.OpenPGP.BlockCipher@@ -99,6 +103,32 @@ aeadModeAndNonceSizeForSEIPDv2 GCM = Right (CCT.AEAD_GCM, 12) aeadModeAndNonceSizeForSEIPDv2 (OtherAEADAlgo _) = Left . SEIPDv2UnsupportedAEADAlgorithm $ OtherAEADAlgo 0++{- | AEAD algorithms that the SEIPDv2 encryption backend can actually use,+in descending preference order. Derived directly from+'aeadModeAndNonceSizeForSEIPDv2' so that enabling backend support for an+algorithm (e.g. flipping the EAX case to 'Right') automatically makes it+available to capability negotiation without touching the negotiation code.+-}+supportedSEIPDv2AEADAlgorithms :: Set.Set AEADAlgorithm+supportedSEIPDv2AEADAlgorithms =+ Set.fromList+ [ a+ | a <- [OCB, EAX, GCM]+ , isRight (aeadModeAndNonceSizeForSEIPDv2 a)+ ]++{- | Symmetric algorithms that the SEIPDv2 encryption backend can actually use.+Derived directly from 'seipdv2SymmetricKeySize' so that enabling backend support+for an algorithm automatically makes it available to capability negotiation.+-}+supportedSEIPDv2SymmetricAlgorithms :: Set.Set SymmetricAlgorithm+supportedSEIPDv2SymmetricAlgorithms =+ Set.fromList+ [ a+ | a <- [AES128, AES192, AES256]+ , isRight (seipdv2SymmetricKeySize a)+ ] seipdv2SymmetricKeySize :: SymmetricAlgorithm -> Either SEIPDv2Failure Int
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -52,6 +52,9 @@ , payloadForSubkeyBinding , payloadForPrimaryKeyBinding + -- * V6 salt generation+ , randomSignatureSalt+ -- * SignablePrivateKey typeclass , SignablePrivateKey (..) , SignablePrivateKeyV6 (..)
+ Codec/Encryption/OpenPGP/Signing.hs view
@@ -0,0 +1,898 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- | High-level signing monad transformer for OpenPGP.++'SigningT' wraps a 'TK' 'SecretTK' and provides a+unified interface for creating signatures with any+signing-capable subkey or the primary key.++It handles key selection, payload construction+and signature generation.+-}+module Codec.Encryption.OpenPGP.Signing+ ( -- * SigningT transformer+ SigningT+ , runSigningT+ , SigningError (..)+ , renderSigningError++ -- * Signing target selection+ , SigningTarget (..)+ , AvailableSigner (..)+ , asKeyId+ , asFingerprint+ , asKeyPacket+ , asSKey+ , asIsPrimary+ , asUsage+ , listAvailableSigners+ , filterSigningCapable+ , filterByKeyId+ , filterByFingerprint++ -- * Signing payloads+ , SigningPayload (..)++ -- * Low-level signing+ , signWith++ -- * High-level signing operations+ , signUserId+ , signUat++ -- * Timestamp control+ , getCurrentTimestamp+ , setCurrentTimestamp+ , withTimestamp+ ) where++import Control.Monad (guard)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT)+import Control.Monad.Trans.RWS+ ( RWST (..)+ , ask+ , get+ , put+ , runRWST+ )+import Crypto.Error (eitherCryptoError)+import qualified Crypto.PubKey.Ed25519 as Ed25519+import qualified Crypto.PubKey.Ed448 as Ed448+import qualified Crypto.PubKey.RSA.Types as RSATypes+import Crypto.Random.Types (MonadRandom, getRandomBytes)+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BL+import Data.List (find)+import Data.Maybe (listToMaybe)+import qualified Data.Set as Set+import Data.Text (Text)++import Codec.Encryption.OpenPGP.Fingerprint+ ( eightOctetKeyID+ , fingerprint+ )+import Codec.Encryption.OpenPGP.SignatureQualities+ ( signatureHashedSubpacketsKnown+ )+import Codec.Encryption.OpenPGP.Signatures+ ( SignError (..)+ , payloadForCertRevocation+ , payloadForDirectKey+ , payloadForPrimaryKeyBinding+ , payloadForSubkeyBinding+ , payloadForSubkeyRevocation+ , payloadForUat+ , payloadForUserId+ , randomSignatureSalt+ , renderSignError+ , signCertRevocation+ , signDataWithEd25519+ , signDataWithEd25519V6+ , signDataWithEd448+ , signDataWithEd448V6+ , signDataWithRSA+ , signDataWithRSAV6+ , signDirectKey+ , signSubkeyBinding+ , signSubkeyRevocation+ )+import qualified Codec.Encryption.OpenPGP.Signatures as S+import Codec.Encryption.OpenPGP.Subpackets+ ( TextNormalizationMode (..)+ )+import Codec.Encryption.OpenPGP.Types+import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA+import Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes+ ( RSA_PrivateKey (..)+ )+import Codec.Encryption.OpenPGP.Types.Internal.TK+ ( TK (..)+ , TKKind (..)+ , _tkPrimaryKey+ , _tkSubs+ )++-- | Signing-specific errors.+data SigningError+ = SigningSignError !SignError+ | SigningNoSignersAvailable+ | SigningInvalidTarget !ByteString+ | SigningKeyNotSigningCapable !ByteString+ | SigningKeyExpired !ByteString+ | SigningKeyNotYetValid !ByteString+ | SigningSKeyInitFailed !String+ deriving (Eq, Show)++renderSigningError :: SigningError -> String+renderSigningError (SigningSignError e) = renderSignError e+renderSigningError SigningNoSignersAvailable = "no signing-capable keys available"+renderSigningError (SigningInvalidTarget kid) = "invalid signing target: " ++ show kid+renderSigningError (SigningKeyNotSigningCapable kid) = "key is not signing-capable: " ++ show kid+renderSigningError (SigningKeyExpired kid) = "key has expired: " ++ show kid+renderSigningError (SigningKeyNotYetValid kid) = "key is not yet valid: " ++ show kid+renderSigningError (SigningSKeyInitFailed msg) = "failed to initialize secret key: " ++ msg++-- | The signing monad transformer.+newtype SigningT (tk :: TKKind) m a = SigningT+ { unSigningT+ :: ExceptT+ SigningError+ ( RWST+ (TK 'SecretTK)+ [Text]+ ThirtyTwoBitTimeStamp+ m+ )+ a+ }+ deriving newtype (Applicative, Functor, Monad)++-- | Run a 'SigningT' action.+runSigningT+ :: Monad m+ => TK 'SecretTK+ -- ^ The secret transferable key to sign with+ -> ThirtyTwoBitTimeStamp+ -- ^ Initial timestamp+ -> SigningT 'SecretTK m a+ -- ^ Action to run+ -> m (Either SigningError a)+runSigningT tk ts (SigningT action) =+ (runRWST (runExceptT action) tk) ts >>= \(e, _, _) -> return e++-- | Which key to sign with.+data SigningTarget+ = SignWithPrimary+ | SignWithKey !PKA.EightOctetKeyId+ | SignWithBest+ | SignWithBestFilter !(AvailableSigner -> Bool)++-- | A signing-capable key extracted from a 'TK'.+data AvailableSigner = AvailableSigner+ { asKeyId :: !PKA.EightOctetKeyId+ , asFingerprint :: !PKA.Fingerprint+ , asKeyPacket :: !(KeyPkt 'SecretPkt)+ , asSKey :: !SKey+ , asIsPrimary :: !Bool+ , asUsage :: !(Set.Set KeyFlag)+ }++signingCapableFlags :: Set.Set KeyFlag+signingCapableFlags = Set.fromList [SignDataKey, CertifyKeysKey, AuthKey]++isSigningCapable :: Set.Set KeyFlag -> Bool+isSigningCapable usage = not (Set.null (Set.intersection usage signingCapableFlags))++-- | List all signing-capable keys from a 'TK' 'SecretTK'.+listAvailableSigners :: TK 'SecretTK -> [AvailableSigner]+listAvailableSigners tk =+ primary : subs+ where+ primaryKp = _tkPrimaryKey tk+ primaryPkp = keyPktPKPayload primaryKp+ primarySka = secretKeyPktSKAddendum primaryKp+ primaryUsage =+ foldr+ Set.union+ Set.empty+ (map sigFlags (_tkDirectKeySigs tk ++ _tkRevs tk))+ primary =+ AvailableSigner+ { asKeyId = either error id (eightOctetKeyID primaryPkp)+ , asFingerprint = fingerprint primaryPkp+ , asKeyPacket = primaryKp+ , asSKey = case primarySka of+ SUSUnprotected sk _ -> sk+ _ -> error "encrypted secret key not supported in SigningT"+ , asIsPrimary = True+ , asUsage = primaryUsage+ }+ subs = do+ (subKp, subSigs) <- _tkSubs tk+ let subPkp = keyPktPKPayload subKp+ subSka = secretKeyPktSKAddendum subKp+ subUsage = foldr Set.union Set.empty (map sigFlags subSigs)+ guard (isSigningCapable subUsage)+ pure+ AvailableSigner+ { asKeyId = either error id (eightOctetKeyID subPkp)+ , asFingerprint = fingerprint subPkp+ , asKeyPacket = subKp+ , asSKey = case subSka of+ SUSUnprotected sk _ -> sk+ _ -> error "encrypted secret key not supported in SigningT"+ , asIsPrimary = False+ , asUsage = subUsage+ }+ sigFlags sig = case signatureHashedSubpacketsKnown sig of+ Nothing -> Set.empty+ Just hs -> foldr Set.union Set.empty (map goSub hs)+ goSub (SigSubPacket _ (KeyFlags flags)) = flags+ goSub _ = Set.empty++-- | A typed signing payload.+data SigningPayload+ = SPUserId !SigType !UserId+ | SPUat !SigType !UserAttribute+ | SPDirectKey+ | SPKeyRevocation+ | SPSubkeyRevocation !(KeyPkt 'PublicPkt)+ | SPCertRevocation !UserId+ | SPSignSubkeyBinding !(KeyPkt 'PublicPkt)+ | SPPrimaryKeyBinding !(KeyPkt 'PublicPkt)+ | SPRaw !SigType !ByteString+ deriving (Eq, Show)++-- | Sign an arbitrary payload with a selected key.+signWith+ :: forall m+ . MonadRandom m+ => SigningTarget+ -> SigningPayload+ -> SigningT 'SecretTK m (Either SigningError SignaturePayload)+signWith target payload = do+ tk <- SigningT . lift $ ask+ ts <- SigningT . lift $ get+ let signers = listAvailableSigners tk+ selected = resolveTarget target signers+ case selected of+ Nothing -> pure $ Left (signingErrorFromTarget target)+ Just signer -> do+ let kp = asKeyPacket signer+ ska = asSKey signer+ signWithPayload ts kp ska payload++signWithPayload+ :: (Monad m, MonadRandom m)+ => ThirtyTwoBitTimeStamp+ -> KeyPkt 'SecretPkt+ -> SKey+ -> SigningPayload+ -> SigningT 'SecretTK m (Either SigningError SignaturePayload)+signWithPayload ts kp ska payload = do+ result <- SigningT $ lift $ lift $ go ska+ pure $ first SigningSignError result+ where+ go _ska = case keyPktPKPayload kp of+ PKPayload V4 _ _ pka _ -> goV4 pka+ PKPayload V6 _ _ pka _ -> goV6 pka+ PKPayload DeprecatedV3 _ _ pka _ -> goV4 pka+ goV4 pka = case (pka, ska) of+ (RSA, RSAPrivateKey rsaPriv) -> signRSA ts kp (unRSA_PrivateKey rsaPriv) payload+ (EdDSALegacy, EdDSAPrivateKey EdSigningCurve25519 bs) ->+ signEd25519V4 ts kp bs payload+ (EdDSALegacy, Ed25519PrivateKey bs) ->+ signEd25519V4 ts kp bs payload+ (Ed448, EdDSAPrivateKey EdSigningCurve448 bs) ->+ signEd448V4 ts kp bs payload+ (Ed448, Ed448PrivateKey bs) ->+ signEd448V4 ts kp bs payload+ _ ->+ pure $+ Left (SignBackendError "unsupported signing key type for V4")+ goV6 pka = case (pka, ska) of+ (RSA, RSAPrivateKey rsaPriv) -> signRSA ts kp (unRSA_PrivateKey rsaPriv) payload+ (Ed25519, EdDSAPrivateKey EdSigningCurve25519 bs) ->+ signEd25519V6 ts kp bs payload+ (Ed25519, Ed25519PrivateKey bs) ->+ signEd25519V6 ts kp bs payload+ (Ed448, EdDSAPrivateKey EdSigningCurve448 bs) ->+ signEd448V6 ts kp bs payload+ (Ed448, Ed448PrivateKey bs) ->+ signEd448V6 ts kp bs payload+ _ ->+ pure $+ Left (SignBackendError "unsupported signing key type for V6")++signRSA+ :: MonadRandom m+ => ThirtyTwoBitTimeStamp+ -> KeyPkt 'SecretPkt+ -> RSATypes.PrivateKey+ -> SigningPayload+ -> m (Either SignError SignaturePayload)+signRSA ts kp p payload =+ case keyPktPKPayload kp of+ PKPayload V4 _ _ _ _ -> pure $ goV4 payload+ PKPayload V6 _ _ _ _ -> do+ salt <- randomSignatureSalt ha+ pure $ goV6 salt payload+ PKPayload DeprecatedV3 _ _ _ _ -> pure $ goV4 payload+ where+ ha = SHA512+ hashed = [SigSubPacket True (SigCreationTime ts)]+ unhashed = []+ goV4 = signPayloadWithRSA kp ha hashed unhashed p+ goV6 salt = signPayloadWithRSAV6 kp ha salt hashed unhashed p++signEd25519V4+ :: MonadRandom m+ => ThirtyTwoBitTimeStamp+ -> KeyPkt 'SecretPkt+ -> ByteString+ -> SigningPayload+ -> m (Either SignError SignaturePayload)+signEd25519V4 ts kp bs payload =+ case eitherCryptoError (Ed25519.secretKey bs) of+ Left err -> pure $ Left (SignBackendError (show err))+ Right sk ->+ let ha = SHA512+ hashed = [SigSubPacket True (SigCreationTime ts)]+ unhashed = []+ in pure $ signPayloadWithEd25519 kp ha hashed unhashed sk payload++signEd25519V6+ :: MonadRandom m+ => ThirtyTwoBitTimeStamp+ -> KeyPkt 'SecretPkt+ -> ByteString+ -> SigningPayload+ -> m (Either SignError SignaturePayload)+signEd25519V6 ts kp bs payload = do+ let ha = SHA512+ salt <- randomSignatureSalt ha+ case eitherCryptoError (Ed25519.secretKey bs) of+ Left err -> pure $ Left (SignBackendError (show err))+ Right sk ->+ let hashed = [SigSubPacket True (SigCreationTime ts)]+ unhashed = []+ in pure $+ signPayloadWithEd25519V6 kp ha salt hashed unhashed sk payload++signEd448V4+ :: MonadRandom m+ => ThirtyTwoBitTimeStamp+ -> KeyPkt 'SecretPkt+ -> ByteString+ -> SigningPayload+ -> m (Either SignError SignaturePayload)+signEd448V4 ts kp bs payload =+ case eitherCryptoError (Ed448.secretKey bs) of+ Left err -> pure $ Left (SignBackendError (show err))+ Right sk ->+ let ha = SHA512+ hashed = [SigSubPacket True (SigCreationTime ts)]+ unhashed = []+ in pure $ signPayloadWithEd448 kp ha hashed unhashed sk payload++signEd448V6+ :: MonadRandom m+ => ThirtyTwoBitTimeStamp+ -> KeyPkt 'SecretPkt+ -> ByteString+ -> SigningPayload+ -> m (Either SignError SignaturePayload)+signEd448V6 ts kp bs payload = do+ let ha = SHA512+ salt <- randomSignatureSalt ha+ case eitherCryptoError (Ed448.secretKey bs) of+ Left err -> pure $ Left (SignBackendError (show err))+ Right sk ->+ let hashed = [SigSubPacket True (SigCreationTime ts)]+ unhashed = []+ in pure $+ signPayloadWithEd448V6 kp ha salt hashed unhashed sk payload++signPayloadWithRSA+ :: KeyPkt 'SecretPkt+ -> HashAlgorithm+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> RSATypes.PrivateKey+ -> SigningPayload+ -> Either SignError SignaturePayload+signPayloadWithRSA kp ha hs us p payload =+ case payload of+ SPUserId st uid -> signDataWithRSA ha st p hs us (payloadForUserId pkp uid)+ SPUat st uat -> signDataWithRSA ha st p hs us (payloadForUat pkp uat)+ SPDirectKey ->+ signDataWithRSA+ ha+ DirectKeySignature+ p+ hs+ us+ (payloadForDirectKey pkp)+ SPKeyRevocation ->+ signDataWithRSA+ ha+ KeyRevocationSig+ p+ hs+ us+ (payloadForDirectKey pkp)+ SPSubkeyRevocation subKp ->+ signDataWithRSA+ ha+ SubkeyRevocationSig+ p+ hs+ us+ (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))+ SPCertRevocation uid ->+ signDataWithRSA+ ha+ CertRevocationSig+ p+ hs+ us+ (payloadForCertRevocation pkp uid)+ SPSignSubkeyBinding subKp ->+ signDataWithRSA+ ha+ SubkeyBindingSig+ p+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPPrimaryKeyBinding subKp ->+ signDataWithRSA+ ha+ PrimaryKeyBindingSig+ p+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPRaw st raw -> signDataWithRSA ha st p hs us (BL.fromStrict raw)+ where+ pkp = keyPktPKPayload kp++signPayloadWithRSAV6+ :: KeyPkt 'SecretPkt+ -> HashAlgorithm+ -> SignatureSalt+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> RSATypes.PrivateKey+ -> SigningPayload+ -> Either SignError SignaturePayload+signPayloadWithRSAV6 kp ha salt hs us p payload =+ case payload of+ SPUserId st uid ->+ signDataWithRSAV6 ha st salt p hs us (payloadForUserId pkp uid)+ SPUat st uat -> signDataWithRSAV6 ha st salt p hs us (payloadForUat pkp uat)+ SPDirectKey ->+ signDataWithRSAV6+ ha+ DirectKeySignature+ salt+ p+ hs+ us+ (payloadForDirectKey pkp)+ SPKeyRevocation ->+ signDataWithRSAV6+ ha+ KeyRevocationSig+ salt+ p+ hs+ us+ (payloadForDirectKey pkp)+ SPSubkeyRevocation subKp ->+ signDataWithRSAV6+ ha+ SubkeyRevocationSig+ salt+ p+ hs+ us+ (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))+ SPCertRevocation uid ->+ signDataWithRSAV6+ ha+ CertRevocationSig+ salt+ p+ hs+ us+ (payloadForCertRevocation pkp uid)+ SPSignSubkeyBinding subKp ->+ signDataWithRSAV6+ ha+ SubkeyBindingSig+ salt+ p+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPPrimaryKeyBinding subKp ->+ signDataWithRSAV6+ ha+ PrimaryKeyBindingSig+ salt+ p+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPRaw st raw -> signDataWithRSAV6 ha st salt p hs us (BL.fromStrict raw)+ where+ pkp = keyPktPKPayload kp++signPayloadWithEd25519+ :: KeyPkt 'SecretPkt+ -> HashAlgorithm+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> Ed25519.SecretKey+ -> SigningPayload+ -> Either SignError SignaturePayload+signPayloadWithEd25519 kp ha hs us sk payload =+ case payload of+ SPUserId st uid -> signDataWithEd25519 ha st sk hs us (payloadForUserId pkp uid)+ SPUat st uat -> signDataWithEd25519 ha st sk hs us (payloadForUat pkp uat)+ SPDirectKey ->+ signDataWithEd25519+ ha+ DirectKeySignature+ sk+ hs+ us+ (payloadForDirectKey pkp)+ SPKeyRevocation ->+ signDataWithEd25519+ ha+ KeyRevocationSig+ sk+ hs+ us+ (payloadForDirectKey pkp)+ SPSubkeyRevocation subKp ->+ signDataWithEd25519+ ha+ SubkeyRevocationSig+ sk+ hs+ us+ (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))+ SPCertRevocation uid ->+ signDataWithEd25519+ ha+ CertRevocationSig+ sk+ hs+ us+ (payloadForCertRevocation pkp uid)+ SPSignSubkeyBinding subKp ->+ signDataWithEd25519+ ha+ SubkeyBindingSig+ sk+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPPrimaryKeyBinding subKp ->+ signDataWithEd25519+ ha+ PrimaryKeyBindingSig+ sk+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPRaw st raw -> signDataWithEd25519 ha st sk hs us (BL.fromStrict raw)+ where+ pkp = keyPktPKPayload kp++signPayloadWithEd25519V6+ :: KeyPkt 'SecretPkt+ -> HashAlgorithm+ -> SignatureSalt+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> Ed25519.SecretKey+ -> SigningPayload+ -> Either SignError SignaturePayload+signPayloadWithEd25519V6 kp ha salt hs us sk payload =+ case payload of+ SPUserId st uid ->+ signDataWithEd25519V6+ ha+ st+ salt+ sk+ hs+ us+ (payloadForUserId pkp uid)+ SPUat st uat ->+ signDataWithEd25519V6 ha st salt sk hs us (payloadForUat pkp uat)+ SPDirectKey ->+ signDataWithEd25519V6+ ha+ DirectKeySignature+ salt+ sk+ hs+ us+ (payloadForDirectKey pkp)+ SPKeyRevocation ->+ signDataWithEd25519V6+ ha+ KeyRevocationSig+ salt+ sk+ hs+ us+ (payloadForDirectKey pkp)+ SPSubkeyRevocation subKp ->+ signDataWithEd25519V6+ ha+ SubkeyRevocationSig+ salt+ sk+ hs+ us+ (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))+ SPCertRevocation uid ->+ signDataWithEd25519V6+ ha+ CertRevocationSig+ salt+ sk+ hs+ us+ (payloadForCertRevocation pkp uid)+ SPSignSubkeyBinding subKp ->+ signDataWithEd25519V6+ ha+ SubkeyBindingSig+ salt+ sk+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPPrimaryKeyBinding subKp ->+ signDataWithEd25519V6+ ha+ PrimaryKeyBindingSig+ salt+ sk+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPRaw st raw -> signDataWithEd25519V6 ha st salt sk hs us (BL.fromStrict raw)+ where+ pkp = keyPktPKPayload kp++signPayloadWithEd448+ :: KeyPkt 'SecretPkt+ -> HashAlgorithm+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> Ed448.SecretKey+ -> SigningPayload+ -> Either SignError SignaturePayload+signPayloadWithEd448 kp ha hs us sk payload =+ case payload of+ SPUserId st uid -> signDataWithEd448 ha st sk hs us (payloadForUserId pkp uid)+ SPUat st uat -> signDataWithEd448 ha st sk hs us (payloadForUat pkp uat)+ SPDirectKey ->+ signDataWithEd448+ ha+ DirectKeySignature+ sk+ hs+ us+ (payloadForDirectKey pkp)+ SPKeyRevocation ->+ signDataWithEd448+ ha+ KeyRevocationSig+ sk+ hs+ us+ (payloadForDirectKey pkp)+ SPSubkeyRevocation subKp ->+ signDataWithEd448+ ha+ SubkeyRevocationSig+ sk+ hs+ us+ (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))+ SPCertRevocation uid ->+ signDataWithEd448+ ha+ CertRevocationSig+ sk+ hs+ us+ (payloadForCertRevocation pkp uid)+ SPSignSubkeyBinding subKp ->+ signDataWithEd448+ ha+ SubkeyBindingSig+ sk+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPPrimaryKeyBinding subKp ->+ signDataWithEd448+ ha+ PrimaryKeyBindingSig+ sk+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPRaw st raw -> signDataWithEd448 ha st sk hs us (BL.fromStrict raw)+ where+ pkp = keyPktPKPayload kp++signPayloadWithEd448V6+ :: KeyPkt 'SecretPkt+ -> HashAlgorithm+ -> SignatureSalt+ -> [SigSubPacket]+ -> [SigSubPacket]+ -> Ed448.SecretKey+ -> SigningPayload+ -> Either SignError SignaturePayload+signPayloadWithEd448V6 kp ha salt hs us sk payload =+ case payload of+ SPUserId st uid ->+ signDataWithEd448V6+ ha+ st+ salt+ sk+ hs+ us+ (payloadForUserId pkp uid)+ SPUat st uat ->+ signDataWithEd448V6 ha st salt sk hs us (payloadForUat pkp uat)+ SPDirectKey ->+ signDataWithEd448V6+ ha+ DirectKeySignature+ salt+ sk+ hs+ us+ (payloadForDirectKey pkp)+ SPKeyRevocation ->+ signDataWithEd448V6+ ha+ KeyRevocationSig+ salt+ sk+ hs+ us+ (payloadForDirectKey pkp)+ SPSubkeyRevocation subKp ->+ signDataWithEd448V6+ ha+ SubkeyRevocationSig+ salt+ sk+ hs+ us+ (payloadForSubkeyRevocation pkp (keyPktPKPayload subKp))+ SPCertRevocation uid ->+ signDataWithEd448V6+ ha+ CertRevocationSig+ salt+ sk+ hs+ us+ (payloadForCertRevocation pkp uid)+ SPSignSubkeyBinding subKp ->+ signDataWithEd448V6+ ha+ SubkeyBindingSig+ salt+ sk+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPPrimaryKeyBinding subKp ->+ signDataWithEd448V6+ ha+ PrimaryKeyBindingSig+ salt+ sk+ hs+ us+ (payloadForSubkeyBinding pkp (keyPktPKPayload subKp))+ SPRaw st raw -> signDataWithEd448V6 ha st salt sk hs us (BL.fromStrict raw)+ where+ pkp = keyPktPKPayload kp++signingErrorFromTarget :: SigningTarget -> SigningError+signingErrorFromTarget SignWithPrimary = SigningNoSignersAvailable+signingErrorFromTarget (SignWithKey kid) = SigningInvalidTarget (PKA.unEOKI kid)+signingErrorFromTarget SignWithBest = SigningNoSignersAvailable+signingErrorFromTarget (SignWithBestFilter _) = SigningNoSignersAvailable++resolveTarget+ :: SigningTarget -> [AvailableSigner] -> Maybe AvailableSigner+resolveTarget SignWithPrimary signers = listToMaybe (filter asIsPrimary signers)+resolveTarget (SignWithKey kid) signers = find (\s -> asKeyId s == kid) signers+resolveTarget SignWithBest signers = listToMaybe signers+resolveTarget (SignWithBestFilter p) signers = find p signers++-- | Sign a user ID with the primary key.+signUserId+ :: (MonadRandom m)+ => SigType+ -> UserId+ -> SigningT 'SecretTK m (Either SigningError SignaturePayload)+signUserId st uid = do+ result <- signWith SignWithPrimary (SPUserId st uid)+ pure result++-- | Sign a user attribute with the primary key.+signUat+ :: (MonadRandom m)+ => SigType+ -> UserAttribute+ -> SigningT 'SecretTK m (Either SigningError SignaturePayload)+signUat st uat = do+ result <- signWith SignWithPrimary (SPUat st uat)+ pure result++-- | Get the current signing timestamp.+getCurrentTimestamp+ :: Monad m => SigningT tk m ThirtyTwoBitTimeStamp+getCurrentTimestamp = SigningT $ lift get++-- | Set the current signing timestamp.+setCurrentTimestamp+ :: Monad m => ThirtyTwoBitTimeStamp -> SigningT tk m ()+setCurrentTimestamp ts = SigningT $ lift $ put ts++-- | Execute an action with a specific timestamp.+withTimestamp+ :: Monad m+ => ThirtyTwoBitTimeStamp -> SigningT tk m a -> SigningT tk m a+withTimestamp ts action = do+ old <- getCurrentTimestamp+ setCurrentTimestamp ts+ result <- action+ setCurrentTimestamp old+ pure result++-- | Filter to only signing-capable keys.+filterSigningCapable :: [AvailableSigner] -> [AvailableSigner]+filterSigningCapable = filter (\s -> isSigningCapable (asUsage s))++-- | Filter by key ID.+filterByKeyId+ :: PKA.EightOctetKeyId -> [AvailableSigner] -> [AvailableSigner]+filterByKeyId kid = filter (\s -> asKeyId s == kid)++-- | Filter by fingerprint.+filterByFingerprint+ :: PKA.Fingerprint -> [AvailableSigner] -> [AvailableSigner]+filterByFingerprint fp = filter (\s -> asFingerprint s == fp)
Codec/Encryption/OpenPGP/Subpackets.hs view
@@ -195,7 +195,7 @@ canBeCritical KeyFlags {} = True canBeCritical IssuerFingerprint {} = True canBeCritical EmbeddedSignature {} = True--- Future-proofing: unknown critical types are allowed to be critical+canBeCritical PreferredAEADCiphersuites {} = True canBeCritical UserDefinedSigSub {} = True canBeCritical OtherSigSub {} = True canBeCritical _ = False
hOpenPGP.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP-Version: 3.5+Version: 3.5.1 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@@ -199,7 +199,7 @@ , ixset-typed , lens >= 3.0 , monad-loops >= 0.4- , nettle+ , nettle >= 0.3 && < 0.4 , network-uri >= 2.6 , prettyprinter >= 1.7.0 , resourcet >= 0.4@@ -235,6 +235,7 @@ , Codec.Encryption.OpenPGP.SEIPDv1 , Codec.Encryption.OpenPGP.SEIPDv2 , Codec.Encryption.OpenPGP.Serialize+ , Codec.Encryption.OpenPGP.Signing , Codec.Encryption.OpenPGP.Signatures , Codec.Encryption.OpenPGP.SignatureQualities , Codec.Encryption.OpenPGP.Subpackets@@ -287,6 +288,7 @@ , Codec.Encryption.OpenPGP.SEIPDv1 , Codec.Encryption.OpenPGP.SEIPDv2 , Codec.Encryption.OpenPGP.Serialize+ , Codec.Encryption.OpenPGP.Signing , Codec.Encryption.OpenPGP.Signatures , Codec.Encryption.OpenPGP.SignatureQualities , Codec.Encryption.OpenPGP.Subpackets@@ -343,4 +345,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v3.5+ tag: v3.5.1
tests/Tests/Encryption.hs view
@@ -767,17 +767,20 @@ testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm , testCase "recipientCapabilitiesFromSubpacketPayloads extracts preferred AEAD algorithms"- testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms+ testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAlgorithms , testCase "encryptForRecipients negotiates AEAD algorithm from recipient capabilities when enabled" testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled , testCase- "encryptForRecipients capability negotiation fails when recipients share no AEAD algorithm"- testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm- , testCase "encryptForRecipients falls back to SEIPDv1 when recipients do not advertise SEIPDv2 support" testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 , testCase+ "SEIPDv1 negotiation selects symmetric algorithm from PreferredSymmetricAlgorithms ignoring ciphersuites"+ testEncryptRecipientsSEIPDv1NegotiatesSymmetricAlgorithmIgnoringAEADCiphersuites+ , testCase+ "SEIPDv1 negotiation offers the full RFC-permitted CFB set including Twofish/Camellia"+ testEncryptRecipientsSEIPDv1NegotiatesNonAESSymmetricAlgorithm+ , testCase "encryptForRecipients rejects SEIPDv1 when recipients do not advertise MDC support" testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC , testCase@@ -805,6 +808,9 @@ "recipientEncryptionTargetsFromTKAtTimestamp extracts effective self-signature capabilities" testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities , testCase+ "recipientEncryptionTargetsFromTKAtTimestamp extracts typed AEAD preferences"+ testRecipientEncryptionTargetsFromTKAtTimestampExtractsTypedAEADPreferences+ , testCase "recipientEncryptionTargetFromTKAtTimestampWithPolicy filters subkey self-signatures by timestamp" testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering , testCase@@ -2618,19 +2624,21 @@ { recipientCapabilityKeyVersion = V6 , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient , recipientCapabilityKeyFlags = Set.empty- , recipientCapabilityFeatures = Set.empty- , recipientCapabilityPreferredSymmetricAlgorithms =- [AES128, AES256]- , recipientCapabilityPreferredAEADAlgorithms = [OCB]+ , recipientCapabilityFeatures =+ Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]+ , recipientCapabilityPreferredSymmetricAlgorithms = []+ , recipientCapabilityPreferredCiphersuites =+ [(AES128, OCB), (AES256, OCB)] } v4Caps = RecipientCapabilities { recipientCapabilityKeyVersion = V4 , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient , recipientCapabilityKeyFlags = Set.empty- , recipientCapabilityFeatures = Set.empty- , recipientCapabilityPreferredSymmetricAlgorithms = [AES128]- , recipientCapabilityPreferredAEADAlgorithms = [OCB]+ , recipientCapabilityFeatures =+ Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]+ , recipientCapabilityPreferredSymmetricAlgorithms = []+ , recipientCapabilityPreferredCiphersuites = [(AES128, OCB)] } request = RecipientEncryptRequest@@ -2681,19 +2689,21 @@ { recipientCapabilityKeyVersion = V6 , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient , recipientCapabilityKeyFlags = Set.empty- , recipientCapabilityFeatures = Set.empty- , recipientCapabilityPreferredSymmetricAlgorithms =- [AES128, AES256]- , recipientCapabilityPreferredAEADAlgorithms = [OCB]+ , recipientCapabilityFeatures =+ Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]+ , recipientCapabilityPreferredSymmetricAlgorithms = []+ , recipientCapabilityPreferredCiphersuites =+ [(AES128, OCB), (AES256, OCB)] } v4Caps = RecipientCapabilities { recipientCapabilityKeyVersion = V4 , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient , recipientCapabilityKeyFlags = Set.empty- , recipientCapabilityFeatures = Set.empty- , recipientCapabilityPreferredSymmetricAlgorithms = [AES128]- , recipientCapabilityPreferredAEADAlgorithms = [OCB]+ , recipientCapabilityFeatures =+ Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]+ , recipientCapabilityPreferredSymmetricAlgorithms = []+ , recipientCapabilityPreferredCiphersuites = [(AES128, OCB)] } request = RecipientEncryptRequest@@ -2742,9 +2752,9 @@ , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient , recipientCapabilityKeyFlags = Set.empty , recipientCapabilityFeatures = Set.empty- , recipientCapabilityPreferredSymmetricAlgorithms =- [AES128, AES256]- , recipientCapabilityPreferredAEADAlgorithms = [OCB]+ , recipientCapabilityPreferredSymmetricAlgorithms = []+ , recipientCapabilityPreferredCiphersuites =+ [(AES128, OCB), (AES256, OCB)] } v4Caps = RecipientCapabilities@@ -2752,8 +2762,8 @@ , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient , recipientCapabilityKeyFlags = Set.empty , recipientCapabilityFeatures = Set.empty- , recipientCapabilityPreferredSymmetricAlgorithms = [AES128]- , recipientCapabilityPreferredAEADAlgorithms = [OCB]+ , recipientCapabilityPreferredSymmetricAlgorithms = []+ , recipientCapabilityPreferredCiphersuites = [(AES128, OCB)] } request = RecipientEncryptRequest@@ -2803,7 +2813,7 @@ , recipientCapabilityKeyFlags = Set.empty , recipientCapabilityFeatures = Set.empty , recipientCapabilityPreferredSymmetricAlgorithms = [AES128]- , recipientCapabilityPreferredAEADAlgorithms = [OCB]+ , recipientCapabilityPreferredCiphersuites = [(AES128, OCB)] } v4Caps = RecipientCapabilities@@ -2812,7 +2822,7 @@ , recipientCapabilityKeyFlags = Set.empty , recipientCapabilityFeatures = Set.empty , recipientCapabilityPreferredSymmetricAlgorithms = [AES256]- , recipientCapabilityPreferredAEADAlgorithms = [OCB]+ , recipientCapabilityPreferredCiphersuites = [(AES256, OCB)] } request = RecipientEncryptRequest@@ -2851,18 +2861,24 @@ assertFailure "Expected recipient capability negotiation to fail without common symmetric algorithm" -testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms+testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAlgorithms :: Assertion-testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms = do+testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAlgorithms = do (recipient, _privateKey) <- loadUnencryptedRsaSigner let caps = recipientCapabilitiesFromSubpacketPayloads recipient- [OtherSigSub 39 (BL.pack [9, 2, 7, 3, 9, 2])]+ [ PreferredSymmetricAlgorithms [AES128, AES256]+ , PreferredAEADCiphersuites [(AES128, OCB), (AES256, GCM)]+ ] assertEqual- "preferred AEAD ciphersuites subpacket should extract unique AEAD preferences in declaration order"- [OCB, GCM]- (recipientCapabilityPreferredAEADAlgorithms caps)+ "preferred symmetric algorithms subpacket should extract preferences in declaration order"+ [AES128, AES256]+ (recipientCapabilityPreferredSymmetricAlgorithms caps)+ assertEqual+ "preferred AEAD ciphersuites subpacket should extract unique ciphersuite pairs in declaration order"+ [(AES128, OCB), (AES256, GCM)]+ (recipientCapabilityPreferredCiphersuites caps) testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled :: Assertion@@ -2877,9 +2893,9 @@ , recipientCapabilityKeyFlags = Set.empty , recipientCapabilityFeatures = Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]- , recipientCapabilityPreferredSymmetricAlgorithms =- [AES128, AES256]- , recipientCapabilityPreferredAEADAlgorithms = [GCM, OCB]+ , recipientCapabilityPreferredSymmetricAlgorithms = []+ , recipientCapabilityPreferredCiphersuites =+ [(AES128, GCM), (AES128, OCB), (AES256, GCM), (AES256, OCB)] } v4Caps = RecipientCapabilities@@ -2888,8 +2904,8 @@ , recipientCapabilityKeyFlags = Set.empty , recipientCapabilityFeatures = Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]- , recipientCapabilityPreferredSymmetricAlgorithms = [AES128]- , recipientCapabilityPreferredAEADAlgorithms = [GCM]+ , recipientCapabilityPreferredSymmetricAlgorithms = []+ , recipientCapabilityPreferredCiphersuites = [(AES128, GCM)] } request = RecipientEncryptRequest@@ -2940,31 +2956,92 @@ other -> assertFailure ("Expected one SEIPDv2 packet, got " ++ show other) -testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm+testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 :: Assertion-testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm = do+testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 = do (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner let v4Recipient = setKeyVersion V4 baseRecipient v6Recipient = setKeyVersion V6 baseRecipient+ sharedCaps keyVersion recipient =+ RecipientCapabilities+ { recipientCapabilityKeyVersion = keyVersion+ , recipientCapabilityPublicKeyAlgorithm = _pkalgo recipient+ , recipientCapabilityKeyFlags = Set.empty+ , recipientCapabilityFeatures = Set.singleton FeatureSEIPDv1+ , recipientCapabilityPreferredSymmetricAlgorithms = [AES256]+ , recipientCapabilityPreferredCiphersuites = [(AES256, OCB)]+ }+ request =+ RecipientEncryptRequest+ { recipientEncryptRequestTargets =+ [ recipientEncryptionTargetWithCapabilities+ v6Recipient+ (sharedCaps V6 v6Recipient)+ , recipientEncryptionTargetWithCapabilities+ v4Recipient+ (sharedCaps V4 v4Recipient)+ ]+ , recipientEncryptRequestPayloadShape =+ defaultRecipientPayloadShape+ , recipientEncryptRequestPayload =+ "recipient seipd fallback payload"+ , recipientEncryptRequestSymmetricOverride = Nothing+ , recipientEncryptRequestOverrides =+ RecipientEncryptRequestSEIPDv2Overrides+ { recipientEncryptRequestAEADOverride = Nothing+ , recipientEncryptRequestChunkSizeOverride = Just 6+ , recipientEncryptRequestSaltOverride =+ Just (Salt (B.replicate 32 0x28))+ }+ }+ result <- encryptForRecipients request+ case result of+ Left err ->+ assertFailure+ ( "Expected fallback to SEIPDv1 when recipients do not advertise SEIPDv2, got "+ ++ show err+ )+ Right+ RecipientEncryptResult+ { recipientEncryptPackets = packets+ , recipientEncryptSessionMaterial = material+ } -> do+ assertEqual+ "SEIPDv1 fallback should negotiate symmetric algorithm from PreferredSymmetricAlgorithms"+ AES256+ (pkeskSessionAlgorithm material)+ let seipdPkts = [p | SymEncIntegrityProtectedDataPkt p <- packets]+ case seipdPkts of+ [SEIPD1 1 _] -> pure ()+ [SEIPD2 {}] ->+ assertFailure+ "Expected SEIPDv1 fallback when recipients do not advertise SEIPDv2 support"+ other -> assertFailure ("Unexpected SEIPD packets: " ++ show other)++testEncryptRecipientsSEIPDv1NegotiatesSymmetricAlgorithmIgnoringAEADCiphersuites+ :: Assertion+testEncryptRecipientsSEIPDv1NegotiatesSymmetricAlgorithmIgnoringAEADCiphersuites = do+ (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner+ let v4Recipient = setKeyVersion V4 baseRecipient+ v6Recipient = setKeyVersion V6 baseRecipient v6Caps = RecipientCapabilities { recipientCapabilityKeyVersion = V6 , recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient , recipientCapabilityKeyFlags = Set.empty- , recipientCapabilityFeatures =- Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]- , recipientCapabilityPreferredSymmetricAlgorithms = [AES256]- , recipientCapabilityPreferredAEADAlgorithms = [OCB]+ , recipientCapabilityFeatures = Set.singleton FeatureSEIPDv1+ , recipientCapabilityPreferredSymmetricAlgorithms =+ [AES128, AES256]+ , recipientCapabilityPreferredCiphersuites = [(AES256, OCB)] } v4Caps = RecipientCapabilities { recipientCapabilityKeyVersion = V4 , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient , recipientCapabilityKeyFlags = Set.empty- , recipientCapabilityFeatures =- Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]- , recipientCapabilityPreferredSymmetricAlgorithms = [AES256]- , recipientCapabilityPreferredAEADAlgorithms = [GCM]+ , recipientCapabilityFeatures = Set.singleton FeatureSEIPDv1+ , recipientCapabilityPreferredSymmetricAlgorithms = [AES128]+ , recipientCapabilityPreferredCiphersuites = [(AES256, OCB)] } request = RecipientEncryptRequest@@ -2975,14 +3052,11 @@ , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape , recipientEncryptRequestPayload =- "recipient AEAD mismatch payload"- , recipientEncryptRequestSymmetricOverride = Just AES256+ "seipd v1 symmetric negotiation payload"+ , recipientEncryptRequestSymmetricOverride = Nothing , recipientEncryptRequestOverrides =- RecipientEncryptRequestSEIPDv2Overrides- { recipientEncryptRequestAEADOverride = Nothing- , recipientEncryptRequestChunkSizeOverride = Just 6- , recipientEncryptRequestSaltOverride =- Just (Salt (B.replicate 32 0x27))+ RecipientEncryptRequestSEIPDv1Overrides+ { recipientEncryptRequestIVOverride = Nothing } } result <-@@ -2990,72 +3064,72 @@ RecipientCapabilityNegotiationOn request case result of- Left- ( RecipientCapabilitySelectionFailure- (RecipientCapabilityNoCommonAEADAlgorithms _)- ) -> pure ()- Left other ->+ Left err -> assertFailure- ( "Expected RecipientCapabilityNoCommonAEADAlgorithms, got "- ++ show other+ ( "Expected SEIPDv1 symmetric capability negotiation to succeed, got "+ ++ show err )- Right _ ->- assertFailure- "Expected recipient capability negotiation to fail without common AEAD algorithm"+ Right+ RecipientEncryptResult+ { recipientEncryptPackets = packets+ , recipientEncryptSessionMaterial = material+ } -> do+ assertEqual+ "SEIPDv1 negotiation should pick common preferred symmetric algorithm and ignore ciphersuites"+ AES128+ (pkeskSessionAlgorithm material)+ let seipdPkts = [p | SymEncIntegrityProtectedDataPkt p <- packets]+ case seipdPkts of+ [SEIPD1 1 _] -> pure ()+ other ->+ assertFailure ("Expected one SEIPDv1 packet, got " ++ show other) -testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2+testEncryptRecipientsSEIPDv1NegotiatesNonAESSymmetricAlgorithm :: Assertion-testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 = do+testEncryptRecipientsSEIPDv1NegotiatesNonAESSymmetricAlgorithm = do (baseRecipient, _privateKey) <- loadUnencryptedRsaSigner let v4Recipient = setKeyVersion V4 baseRecipient- v6Recipient = setKeyVersion V6 baseRecipient- sharedCaps keyVersion recipient =+ caps = RecipientCapabilities- { recipientCapabilityKeyVersion = keyVersion- , recipientCapabilityPublicKeyAlgorithm = _pkalgo recipient+ { recipientCapabilityKeyVersion = V4+ , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient , recipientCapabilityKeyFlags = Set.empty , recipientCapabilityFeatures = Set.singleton FeatureSEIPDv1- , recipientCapabilityPreferredSymmetricAlgorithms = [AES256]- , recipientCapabilityPreferredAEADAlgorithms = [OCB]+ , recipientCapabilityPreferredSymmetricAlgorithms = [Camellia128]+ , recipientCapabilityPreferredCiphersuites = [(AES256, OCB)] } request = RecipientEncryptRequest { recipientEncryptRequestTargets =- [ recipientEncryptionTargetWithCapabilities- v6Recipient- (sharedCaps V6 v6Recipient)- , recipientEncryptionTargetWithCapabilities- v4Recipient- (sharedCaps V4 v4Recipient)- ]+ [recipientEncryptionTargetWithCapabilities v4Recipient caps] , recipientEncryptRequestPayloadShape = defaultRecipientPayloadShape , recipientEncryptRequestPayload =- "recipient seipd fallback payload"- , recipientEncryptRequestSymmetricOverride = Just AES256+ "seipd v1 non-aes symmetric negotiation payload"+ , recipientEncryptRequestSymmetricOverride = Nothing , recipientEncryptRequestOverrides =- RecipientEncryptRequestSEIPDv2Overrides- { recipientEncryptRequestAEADOverride = Nothing- , recipientEncryptRequestChunkSizeOverride = Just 6- , recipientEncryptRequestSaltOverride =- Just (Salt (B.replicate 32 0x28))+ RecipientEncryptRequestSEIPDv1Overrides+ { recipientEncryptRequestIVOverride = Nothing } }- result <- encryptForRecipients request+ result <-+ encryptForRecipientsWithCapabilityNegotiation+ RecipientCapabilityNegotiationOn+ request case result of Left err -> assertFailure- ( "Expected fallback to SEIPDv1 when recipients do not advertise SEIPDv2, got "+ ( "Expected SEIPDv1 symmetric capability negotiation to succeed, got " ++ show err )- Right RecipientEncryptResult {recipientEncryptPackets = packets} -> do- let seipdPkts = [p | SymEncIntegrityProtectedDataPkt p <- packets]- case seipdPkts of- [SEIPD1 1 _] -> pure ()- [SEIPD2 {}] ->- assertFailure- "Expected SEIPDv1 fallback when recipients do not advertise SEIPDv2 support"- other -> assertFailure ("Unexpected SEIPD packets: " ++ show other)+ Right+ RecipientEncryptResult+ { recipientEncryptSessionMaterial = material+ } ->+ assertEqual+ "SEIPDv1 negotiation should pick the recipient-preferred non-AES algorithm"+ Camellia128+ (pkeskSessionAlgorithm material) testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC :: Assertion@@ -3068,8 +3142,8 @@ , recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient , recipientCapabilityKeyFlags = Set.empty , recipientCapabilityFeatures = Set.singleton FeatureSEIPDv2- , recipientCapabilityPreferredSymmetricAlgorithms = [AES256]- , recipientCapabilityPreferredAEADAlgorithms = [OCB]+ , recipientCapabilityPreferredSymmetricAlgorithms = []+ , recipientCapabilityPreferredCiphersuites = [(AES256, OCB)] } request = RecipientEncryptRequest@@ -3368,7 +3442,9 @@ signingKey signatureTime [ SigSubPacket False (PreferredSymmetricAlgorithms [AES128])- , SigSubPacket False (OtherSigSub 39 (BL.pack [9, 2, 7, 3]))+ , SigSubPacket+ False+ (PreferredAEADCiphersuites [(AES128, OCB), (AES256, GCM)]) ] subkeyBindingSig <- signSubkeyBindingWithRSAExtrasAt@@ -3398,17 +3474,62 @@ "Expected TKUnknown-derived target to include extracted capabilities" Just caps -> do assertEqual- "self-signature capability extraction should include primary-key symmetric preferences"- [AES128]- (recipientCapabilityPreferredSymmetricAlgorithms caps)- assertEqual- "self-signature capability extraction should include primary-key preferred AEAD algorithms"- [OCB, GCM]- (recipientCapabilityPreferredAEADAlgorithms caps)+ "self-signature capability extraction should include primary-key ciphersuite preferences"+ [(AES128, OCB), (AES256, GCM)]+ (recipientCapabilityPreferredCiphersuites caps) assertEqual "self-signature capability extraction should include subkey key flags" (Set.fromList [EncryptCommunicationsKey]) (recipientCapabilityKeyFlags caps)+ [] ->+ assertFailure "Expected at least one TKUnknown-derived target"++testRecipientEncryptionTargetsFromTKAtTimestampExtractsTypedAEADPreferences+ :: Assertion+testRecipientEncryptionTargetsFromTKAtTimestampExtractsTypedAEADPreferences = do+ (primary, signingKey) <- loadUnencryptedRsaSigner+ (subkey, _privateKey) <- loadUnencryptedRsaSigner+ let signatureTime = ThirtyTwoBitTimeStamp 1700000000+ directKeySig <-+ signDirectKeyWithRSAExtrasAt+ primary+ signingKey+ signatureTime+ [ SigSubPacket+ False+ (PreferredAEADCiphersuites [(AES128, OCB), (AES256, GCM)])+ ]+ subkeyBindingSig <-+ signSubkeyBindingWithRSAExtrasAt+ primary+ subkey+ signingKey+ signatureTime+ [ SigSubPacket+ False+ (KeyFlags (Set.fromList [EncryptCommunicationsKey]))+ ]+ let tk =+ TK+ { _tkPrimaryKey = KeyPktPublicPrimary primary+ , _tkRevs = []+ , _tkDirectKeySigs = [directKeySig]+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]+ }+ targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk+ case targets of+ (target : _) ->+ case recipientEncryptionTargetCapabilities target of+ Nothing ->+ assertFailure+ "Expected TKUnknown-derived target to include extracted capabilities"+ Just caps -> do+ assertEqual+ "typed self-signature AEAD preference extraction should include primary-key ciphersuite preferences"+ [(AES128, OCB), (AES256, GCM)]+ (recipientCapabilityPreferredCiphersuites caps) [] -> assertFailure "Expected at least one TKUnknown-derived target"
tests/Tests/Keys.hs view
@@ -375,6 +375,9 @@ "preference resolution tracks active self-certification timeline" testPreferencesAtTimestamp , testCase+ "preference resolution extracts typed AEAD preferences"+ testKeyPreferencesAtTimestampExtractsAEADPreferences+ , testCase "verifySigWith rejects v6 revocation Issuer key-id subpackets" testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID , testCase@@ -1631,6 +1634,43 @@ "key preferences should become unavailable when no active self-certification remains" Nothing (effectiveKeyPreferencesAtTimestamp queryAfterRevocation tk)++testKeyPreferencesAtTimestampExtractsAEADPreferences :: Assertion+testKeyPreferencesAtTimestampExtractsAEADPreferences = do+ (signer, signingKey) <- loadUnencryptedRsaSigner+ let uid = UserId "aead-prefs@example.org"+ UserId uidText = uid+ t1 = addTimestampSeconds (_timestamp signer) 1++ certification <-+ signCertificationAt+ signer+ signingKey+ uid+ t1+ [SigSubPacket False (PreferredAEADCiphersuites [(AES128, OCB)])]++ let tk :: TK 'PublicTK =+ TK+ { _tkPrimaryKey = KeyPktPublicPrimary signer+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs =+ [+ ( uidText+ ,+ [ certification+ ]+ )+ ]+ , _tkUAts = []+ , _tkSubs = []+ }++ assertEqual+ "key preferences at timestamp should extract AEAD preferences"+ (Just [PreferredAEADCiphersuites [(AES128, OCB)]])+ (effectiveKeyPreferencesAtTimestamp t1 tk) testChangePrivateKeyPassphraseLegacy :: Assertion testChangePrivateKeyPassphraseLegacy = do