diff --git a/Codec/Encryption/OpenPGP/BlockCipher.hs b/Codec/Encryption/OpenPGP/BlockCipher.hs --- a/Codec/Encryption/OpenPGP/BlockCipher.hs +++ b/Codec/Encryption/OpenPGP/BlockCipher.hs @@ -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)) diff --git a/Codec/Encryption/OpenPGP/Encrypt.hs b/Codec/Encryption/OpenPGP/Encrypt.hs --- a/Codec/Encryption/OpenPGP/Encrypt.hs +++ b/Codec/Encryption/OpenPGP/Encrypt.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Expirations.hs b/Codec/Encryption/OpenPGP/Expirations.hs --- a/Codec/Encryption/OpenPGP/Expirations.hs +++ b/Codec/Encryption/OpenPGP/Expirations.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Policy.hs b/Codec/Encryption/OpenPGP/Policy.hs --- a/Codec/Encryption/OpenPGP/Policy.hs +++ b/Codec/Encryption/OpenPGP/Policy.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/SEIPDv2.hs b/Codec/Encryption/OpenPGP/SEIPDv2.hs --- a/Codec/Encryption/OpenPGP/SEIPDv2.hs +++ b/Codec/Encryption/OpenPGP/SEIPDv2.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Signatures.hs b/Codec/Encryption/OpenPGP/Signatures.hs --- a/Codec/Encryption/OpenPGP/Signatures.hs +++ b/Codec/Encryption/OpenPGP/Signatures.hs @@ -52,6 +52,9 @@ , payloadForSubkeyBinding , payloadForPrimaryKeyBinding + -- * V6 salt generation + , randomSignatureSalt + -- * SignablePrivateKey typeclass , SignablePrivateKey (..) , SignablePrivateKeyV6 (..) diff --git a/Codec/Encryption/OpenPGP/Signing.hs b/Codec/Encryption/OpenPGP/Signing.hs new file mode 100644 --- /dev/null +++ b/Codec/Encryption/OpenPGP/Signing.hs @@ -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) diff --git a/Codec/Encryption/OpenPGP/Subpackets.hs b/Codec/Encryption/OpenPGP/Subpackets.hs --- a/Codec/Encryption/OpenPGP/Subpackets.hs +++ b/Codec/Encryption/OpenPGP/Subpackets.hs @@ -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 diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP -Version: 3.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 diff --git a/tests/Tests/Encryption.hs b/tests/Tests/Encryption.hs --- a/tests/Tests/Encryption.hs +++ b/tests/Tests/Encryption.hs @@ -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" diff --git a/tests/Tests/Keys.hs b/tests/Tests/Keys.hs --- a/tests/Tests/Keys.hs +++ b/tests/Tests/Keys.hs @@ -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