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 @@ -7,6 +7,8 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -82,6 +84,10 @@ , aesKeyWrapRFC3394 , deriveX25519Kek , deriveX448Kek + , PKAEncryptOps (..) + , PKAEncryptOpsDict (..) + , SomePKAEncryptOpsDict (..) + , pkaEncryptOpsDict ) where import Control.Applicative ((<|>)) @@ -114,10 +120,12 @@ import qualified Data.ByteString.Lazy as BL import Data.Containers.ListUtils (nubOrd) import Data.Int (Int64) +import Data.Kind (Type) import Data.List (elemIndex, find, maximumBy, sortOn) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (fromMaybe, listToMaybe) +import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Ord (comparing) +import Data.Proxy (Proxy (..)) import qualified Data.Set as Set import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) @@ -203,6 +211,99 @@ import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes +class PKAEncryptOps (a :: PubKeyAlgorithm) where + pkaBuildV3PKESK + :: MonadRandom m + => Proxy a + -> SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV3) + pkaBuildV6PKESK + :: MonadRandom m + => Proxy a + -> SomePKPayload + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV6) + +instance PKAEncryptOps RSA where + pkaBuildV3PKESK _ = buildRsaPKESKv3 + pkaBuildV6PKESK _ = buildRsaPKESKv6 + +instance PKAEncryptOps ECDH where + pkaBuildV3PKESK _ = buildECDHPKESKv3 + pkaBuildV6PKESK _ = buildECDHPKESKv6 + +instance PKAEncryptOps X25519 where + pkaBuildV3PKESK _ = buildX25519PKESKv3 + pkaBuildV6PKESK _ r m = buildX25519PKESKv6 r (pkeskV6RawSessionMaterial m) + +instance PKAEncryptOps X448 where + pkaBuildV3PKESK _ = buildX448PKESKv3 + pkaBuildV6PKESK _ r m = buildX448PKESKv6 r (pkeskV6RawSessionMaterial m) + +data PKAEncryptOpsDict = PKAEncryptOpsDict + { pkaDictBuildV3 + :: forall m + . MonadRandom m + => SomePKPayload + -> PKESKV3SessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV3) + , pkaDictBuildV6 + :: forall m + . MonadRandom m + => SomePKPayload + -> PKESKSessionMaterial + -> m (Either PKESKEncryptError PKESKPayloadV6) + } + +data SomePKAEncryptOpsDict where + SomePKAEncryptOpsDict + :: PKAEncryptOpsDict -> SomePKAEncryptOpsDict + +pkaEncryptOpsDict + :: PubKeyAlgorithm -> Maybe SomePKAEncryptOpsDict +pkaEncryptOpsDict RSA = + Just + ( SomePKAEncryptOpsDict + ( PKAEncryptOpsDict + buildRsaPKESKv3 + (\r m -> buildRsaPKESKv6 r m) + ) + ) +pkaEncryptOpsDict DeprecatedRSAEncryptOnly = + Just + ( SomePKAEncryptOpsDict + ( PKAEncryptOpsDict + buildRsaPKESKv3 + (\r m -> buildRsaPKESKv6 r m) + ) + ) +pkaEncryptOpsDict ECDH = + Just + ( SomePKAEncryptOpsDict + ( PKAEncryptOpsDict + buildECDHPKESKv3 + (\r m -> buildECDHPKESKv6 r m) + ) + ) +pkaEncryptOpsDict X25519 = + Just + ( SomePKAEncryptOpsDict + ( PKAEncryptOpsDict + buildX25519PKESKv3 + (\r m -> buildX25519PKESKv6 r (pkeskV6RawSessionMaterial m)) + ) + ) +pkaEncryptOpsDict X448 = + Just + ( SomePKAEncryptOpsDict + ( PKAEncryptOpsDict + buildX448PKESKv3 + (\r m -> buildX448PKESKv6 r (pkeskV6RawSessionMaterial m)) + ) + ) +pkaEncryptOpsDict _ = Nothing + data RecipientCapabilityNegotiationMode = RecipientCapabilityNegotiationOff | RecipientCapabilityNegotiationOn @@ -554,13 +655,7 @@ supportsPKESKRecipientAlgorithm :: SomePKPayload -> Bool supportsPKESKRecipientAlgorithm recipient = - case _pkalgo recipient of - RSA -> True - DeprecatedRSAEncryptOnly -> True - ECDH -> True - X25519 -> True - X448 -> True - _ -> False + isJust (pkaEncryptOpsDict (_pkalgo recipient)) chooseRecipientTarget :: RecipientTargetSelectionPolicy @@ -1098,24 +1193,13 @@ recipient (pkeskV3SessionMaterial material) PreferV6 -> - case _pkalgo recipient of - RSA -> - fmap - (fmap PKESKPayloadV6Packet) - (buildRsaPKESKv6 recipient material) - ECDH -> - fmap - (fmap PKESKPayloadV6Packet) - (buildECDHPKESKv6 recipient material) - X25519 -> - fmap - (fmap PKESKPayloadV6Packet) - (buildX25519PKESKv6 recipient (pkeskV6RawSessionMaterial material)) - X448 -> + case pkaEncryptOpsDict (_pkalgo recipient) of + Nothing -> + pure (Left (UnsupportedRecipientAlgorithm (_pkalgo recipient))) + Just (SomePKAEncryptOpsDict dict) -> fmap (fmap PKESKPayloadV6Packet) - (buildX448PKESKv6 recipient (pkeskV6RawSessionMaterial material)) - pka -> pure (Left (UnsupportedRecipientAlgorithm pka)) + (pkaDictBuildV6 dict recipient material) -- | Build a PKESK packet for one recipient key according to the selected version policy. buildPKESKPktForRecipient @@ -1146,13 +1230,11 @@ -> PKESKV3SessionMaterial -> m (Either PKESKEncryptError PKESKPayloadV3) buildPKESKv3PayloadForRecipientTyped recipient material = - case _pkalgo recipient of - RSA -> buildRsaPKESKv3 recipient material - DeprecatedRSAEncryptOnly -> buildRsaPKESKv3 recipient material - ECDH -> buildECDHPKESKv3 recipient material - X25519 -> buildX25519PKESKv3 recipient material - X448 -> buildX448PKESKv3 recipient material - pka -> pure (Left (UnsupportedRecipientAlgorithm pka)) + case pkaEncryptOpsDict (_pkalgo recipient) of + Nothing -> + pure (Left (UnsupportedRecipientAlgorithm (_pkalgo recipient))) + Just (SomePKAEncryptOpsDict dict) -> + pkaDictBuildV3 dict recipient material -- | Build a legacy PKESKv3 packet for v4/v3 RSA recipient interop. buildPKESKv3PktForRecipient @@ -1246,15 +1328,13 @@ (RecipientForceV3InteropW, RecipientForceV3Payload v3Material) -> buildPKESKv3PayloadForRecipient recipient v3Material ( RecipientPreferV6W - , RecipientPreferV6Payload material v6RawMaterial + , RecipientPreferV6Payload material _v6RawMaterial ) -> - case _pkalgo recipient of - RSA -> packetizeV6 (buildRsaPKESKv6 recipient material) - ECDH -> packetizeV6 (buildECDHPKESKv6 recipient material) - X25519 -> packetizeV6 (buildX25519PKESKv6 recipient v6RawMaterial) - X448 -> packetizeV6 (buildX448PKESKv6 recipient v6RawMaterial) - pka -> - pure (Left (UnsupportedRecipientAlgorithm pka)) + case pkaEncryptOpsDict (_pkalgo recipient) of + Nothing -> + pure (Left (UnsupportedRecipientAlgorithm (_pkalgo recipient))) + Just (SomePKAEncryptOpsDict dict) -> + packetizeV6 (pkaDictBuildV6 dict recipient material) {- | Encrypt for recipient targets with capability negotiation enabled. diff --git a/Codec/Encryption/OpenPGP/Internal.hs b/Codec/Encryption/OpenPGP/Internal.hs --- a/Codec/Encryption/OpenPGP/Internal.hs +++ b/Codec/Encryption/OpenPGP/Internal.hs @@ -50,20 +50,6 @@ , renderCurveConversionError ) -countBits :: ByteString -> Word16 -countBits bs - | BL.null bs = 0 - | otherwise = - fromIntegral (BL.length bs * 8) - - fromIntegral (go (BL.head bs) 7) - where - go :: Word8 -> Int -> Word8 - go _ 0 = 7 - go n b = - if testBit n b - then 7 - fromIntegral b - else go n (b - 1) - data PktStreamContext = PktStreamContext { lastLD :: Pkt diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -95,7 +95,6 @@ import Data.Text.Encoding.Error (lenientDecode) import Data.Word (Word16, Word32, Word8) import Network.URI (nullURI, parseURI, uriToString) -import Numeric (showHex) import Codec.Encryption.OpenPGP.Internal ( curve2Curve @@ -112,24 +111,6 @@ ) import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes -import Codec.Encryption.OpenPGP.Types.Internal.Errors - ( ECDHOctetError (..) - , ECPointError (..) - , PktParseError (..) - , PktParseErrorReason (..) - , PktValidationError (..) - , SKeyError (..) - , SerializeError (..) - , X25519OctetError (..) - , renderECDHOctetError - , renderECPointError - , renderPktParseError - , renderPktParseReason - , renderPktValidationError - , renderSKeyError - , renderSerializeError - , renderX25519OctetError - ) import qualified Codec.Encryption.OpenPGP.Types.Internal.PKITypes as P instance Binary SigSubPacket where @@ -1069,69 +1050,51 @@ :: PubKeyAlgorithm -> BL.ByteString -> Either PktParseError (NE.NonEmpty MPI) - parseLegacyPKESKMPIs pka mpib = do - case parseLegacyPKESKMPIsStrict pka mpib of - Right sk -> pure sk - Left strictErr - | pka == X25519 -> - case parseLegacyPKESKX25519V3Octets mpib of - Right sk -> Right sk - Left _ -> - Left $ - case strictErr of - PktParseError o r -> PktParseError o r - | pka == ECDH -> - case parseLegacyPKESKECDHOctets mpib of - Right sk -> Right sk - Left _ -> - Left $ - case strictErr of - PktParseError o r -> PktParseError o r - | otherwise -> Left strictErr + parseLegacyPKESKMPIs pka mpib + | pka `elem` [X25519, X448] = + parseLegacyPKESKFixedSizeOctets pka mpib + | otherwise = + case parseLegacyPKESKMPIsStrict pka mpib of + Right sk -> pure sk + Left strictErr + | pka == ECDH -> + case parseLegacyPKESKECDHOctets mpib of + Right sk -> Right sk + Left _ -> Left strictErr + | otherwise -> Left strictErr - parseLegacyPKESKMPIsStrict + parseLegacyPKESKFixedSizeOctets :: PubKeyAlgorithm -> BL.ByteString -> Either PktParseError (NE.NonEmpty MPI) - parseLegacyPKESKMPIsStrict pka mpib = do - (rest, _, sk) <- - bimap - (\(_, _, e) -> PktParseError 0 (PktParseErrorReasonGeneric e)) - id - $ runGetOrFail (parserForLegacyPKESKMPIs pka) mpib - if BL.null rest - then pure (NE.fromList sk) - else - Left $ - PktParseError - 0 - ( PktParseErrorReasonUnexpectedTrailingPKESKData - { pkeskAlgorithm = pka - } - ) - - parseLegacyPKESKX25519V3Octets - :: BL.ByteString -> Either PktParseError (NE.NonEmpty MPI) - parseLegacyPKESKX25519V3Octets mpib = do - if BL.length mpib < 33 + parseLegacyPKESKFixedSizeOctets pka mpib = do + let ephLen = + case pka of + X25519 -> 32 + X448 -> 56 + _ -> + error $ "unsupported fixed-size octet algorithm: " ++ show pka + if BL.length mpib < ephLen + 1 then Left $ PktParseError 0 - ( PktParseErrorReasonX25519V3OctetLayoutInvalid - X25519OctetErrorReasonTooShort + ( PktParseErrorReasonFixedSizeOctetLayoutInvalid + pka + FixedSizeOctetLayoutErrorReasonTooShort ) else Right () - let ephemeral = BL.toStrict (BL.take 32 mpib) - eskLen = fromIntegral (BL.index mpib 32) :: Int - eskWithAlgo = BL.toStrict (BL.drop 33 mpib) + let ephemeral = BL.toStrict (BL.take ephLen mpib) + eskLen = fromIntegral (BL.index mpib ephLen) :: Int + eskWithAlgo = BL.toStrict (BL.drop (ephLen + 1) mpib) if eskLen /= B.length eskWithAlgo then Left $ PktParseError 0 - ( PktParseErrorReasonX25519V3OctetLayoutInvalid - X25519OctetErrorReasonInconsistentESKLength + ( PktParseErrorReasonFixedSizeOctetLayoutInvalid + pka + FixedSizeOctetLayoutErrorReasonInconsistentESKLength ) else Right () if B.null eskWithAlgo @@ -1139,8 +1102,9 @@ Left $ PktParseError 0 - ( PktParseErrorReasonX25519V3OctetLayoutInvalid - X25519OctetErrorReasonMissingSymmetricAlgorithm + ( PktParseErrorReasonFixedSizeOctetLayoutInvalid + pka + FixedSizeOctetLayoutErrorReasonMissingSymmetricAlgorithm ) else Right () let symAlgo = B.head eskWithAlgo @@ -1156,13 +1120,34 @@ Left $ PktParseError 0 - ( PktParseErrorReasonX25519V3OctetLayoutInvalid - ( X25519OctetErrorReasonUnsupportedSymmetricAlgorithm - { x25519SymmetricAlgorithmOctet = symAlgo - } + ( PktParseErrorReasonFixedSizeOctetLayoutInvalid + pka + ( FixedSizeOctetLayoutErrorReasonUnsupportedSymmetricAlgorithm + symAlgo ) ) + parseLegacyPKESKMPIsStrict + :: PubKeyAlgorithm + -> BL.ByteString + -> Either PktParseError (NE.NonEmpty MPI) + parseLegacyPKESKMPIsStrict pka mpib = do + (rest, _, sk) <- + bimap + (\(_, _, e) -> PktParseError 0 (PktParseErrorReasonGeneric e)) + id + $ runGetOrFail (parserForLegacyPKESKMPIs pka) mpib + if BL.null rest + then pure (NE.fromList sk) + else + Left $ + PktParseError + 0 + ( PktParseErrorReasonUnexpectedTrailingPKESKData + { pkeskAlgorithm = pka + } + ) + -- \| Parse an RFC 6637 ยง8 ECDH PKESKv3 body as MPI(ephemeral) || 1-octet-count || C. -- This is the interoperable wire format produced by GnuPG and other RFC-compliant -- implementations. hOpenPGP previously wrote both fields as MPIs; this fallback @@ -1608,7 +1593,18 @@ putPKESKv3SessionKeyMaterial :: PubKeyAlgorithm -> NE.NonEmpty MPI -> Put putPKESKv3SessionKeyMaterial pka mpis - | pka `elem` [ECDH, X25519] + | pka `elem` [X25519, X448] + , (ephMPI NE.:| [wrappedMPI]) <- mpis = do + putByteString (i2osp (unMPI ephMPI)) + let rawWrapped = i2osp (unMPI wrappedMPI) + targetLen = + headDef + (B.length rawWrapped) + (filter (>= B.length rawWrapped) [32, 40, 48]) + paddedWrapped = leftPadTo targetLen rawWrapped + putWord8 (fromIntegral (B.length paddedWrapped)) + putByteString paddedWrapped + | pka == ECDH , (ephMPI NE.:| [wrappedMPI]) <- mpis = do put ephMPI let rawWrapped = i2osp (unMPI wrappedMPI) diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Errors.hs b/Codec/Encryption/OpenPGP/Types/Internal/Errors.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Errors.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Errors.hs @@ -18,8 +18,8 @@ , renderCurveConversionError , ECPointError (..) , renderECPointError - , X25519OctetError (..) - , renderX25519OctetError + , FixedSizeOctetLayoutError (..) + , renderFixedSizeOctetLayoutError , ECDHOctetError (..) , renderECDHOctetError , KeyPktCoercionError (..) @@ -206,26 +206,30 @@ renderECPointError ECPointErrorReasonOddCoordinateLength = "malformed EC point encoding: odd coordinate payload length" --- | X25519 v3 octet layout errors -data X25519OctetError - = X25519OctetErrorReasonTooShort - | X25519OctetErrorReasonInconsistentESKLength - | X25519OctetErrorReasonMissingSymmetricAlgorithm - | X25519OctetErrorReasonUnsupportedSymmetricAlgorithm - { x25519SymmetricAlgorithmOctet :: Word8 +-- | Fixed-size octet layout errors for X25519/X448 v3 PKESK +data FixedSizeOctetLayoutError + = FixedSizeOctetLayoutErrorReasonTooShort + | FixedSizeOctetLayoutErrorReasonInconsistentESKLength + | FixedSizeOctetLayoutErrorReasonMissingSymmetricAlgorithm + | FixedSizeOctetLayoutErrorReasonUnsupportedSymmetricAlgorithm + { fixedSizeOctetSymmetricAlgorithmOctet :: Word8 } deriving (Eq, Show) -renderX25519OctetError :: X25519OctetError -> String -renderX25519OctetError X25519OctetErrorReasonTooShort = - "X25519 v3 PKESK octet layout is too short" -renderX25519OctetError X25519OctetErrorReasonInconsistentESKLength = - "X25519 v3 PKESK octet layout has inconsistent ESK length" -renderX25519OctetError X25519OctetErrorReasonMissingSymmetricAlgorithm = - "X25519 v3 PKESK octet layout must include a symmetric algorithm octet" -renderX25519OctetError (X25519OctetErrorReasonUnsupportedSymmetricAlgorithm algo) = - "X25519 v3 PKESK octet layout has unsupported symmetric algorithm octet " - ++ show algo +renderFixedSizeOctetLayoutError + :: Show a => a -> FixedSizeOctetLayoutError -> String +renderFixedSizeOctetLayoutError algo err = + show algo ++ " v3 PKESK " ++ case err of + FixedSizeOctetLayoutErrorReasonTooShort -> + "octet layout is too short" + FixedSizeOctetLayoutErrorReasonInconsistentESKLength -> + "octet layout has inconsistent ESK length" + FixedSizeOctetLayoutErrorReasonMissingSymmetricAlgorithm -> + "octet layout must include a symmetric algorithm octet" + FixedSizeOctetLayoutErrorReasonUnsupportedSymmetricAlgorithm + octet -> + "octet layout has unsupported symmetric algorithm octet " + ++ show octet -- | ECDH RFC6637 octet layout errors data ECDHOctetError @@ -1262,7 +1266,10 @@ | PktParseErrorReasonUnexpectedTrailingPKESKData { pkeskAlgorithm :: PubKeyAlgorithm } - | PktParseErrorReasonX25519V3OctetLayoutInvalid X25519OctetError + | PktParseErrorReasonFixedSizeOctetLayoutInvalid + { pkeskFixedSizeOctetAlgorithm :: PubKeyAlgorithm + , pkeskFixedSizeOctetError :: FixedSizeOctetLayoutError + } | PktParseErrorReasonECDHOctetLayoutInvalid ECDHOctetError | PktParseErrorReasonCurveConversionFailed CurveConversionError | PktParseErrorReasonInvalidECPoint ECPointError @@ -1292,8 +1299,8 @@ ++ show got renderPktParseReason (PktParseErrorReasonUnexpectedTrailingPKESKData pka) = "unexpected trailing PKESK MPI data for algorithm " ++ show pka -renderPktParseReason (PktParseErrorReasonX25519V3OctetLayoutInvalid e) = - renderX25519OctetError e +renderPktParseReason (PktParseErrorReasonFixedSizeOctetLayoutInvalid algo e) = + renderFixedSizeOctetLayoutError algo e renderPktParseReason (PktParseErrorReasonECDHOctetLayoutInvalid e) = renderECDHOctetError e renderPktParseReason (PktParseErrorReasonCurveConversionFailed e) = diff --git a/Data/Conduit/OpenPGP/Decrypt.hs b/Data/Conduit/OpenPGP/Decrypt.hs --- a/Data/Conduit/OpenPGP/Decrypt.hs +++ b/Data/Conduit/OpenPGP/Decrypt.hs @@ -83,6 +83,9 @@ ( decryptOpenPGPCfb , decryptPreservingNonce ) +import Codec.Encryption.OpenPGP.Encrypt + ( pkaEncryptOpsDict + ) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.Internal ( checksum16 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.6.5 +Version: 3.6.6 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 @@ -346,4 +346,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git - tag: v3.6.5 + tag: v3.6.6 diff --git a/tests/Tests/Properties.hs b/tests/Tests/Properties.hs --- a/tests/Tests/Properties.hs +++ b/tests/Tests/Properties.hs @@ -4,13 +4,19 @@ -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Tests.Properties (propertiesTests) where import Control.Exception (SomeException, try) import Control.Lens (preview) +import Crypto.Error (eitherCryptoError) +import Crypto.Number.Serialize (os2ip) +import qualified Crypto.PubKey.Curve25519 as C25519 +import qualified Crypto.PubKey.Curve448 as C448 import Data.Binary (get, put) import Data.Binary.Put (runPut) +import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Conduit as DC @@ -20,6 +26,13 @@ import Test.Tasty (TestTree, localOption, testGroup) import qualified Test.Tasty.QuickCheck as QC +import Codec.Encryption.OpenPGP.Encrypt + ( PKAEncryptOpsDict (..) + , SomePKAEncryptOpsDict (..) + , encryptSEIPDv2Payload + , pkaEncryptOpsDict + , pkeskV3SessionMaterial + ) import Codec.Encryption.OpenPGP.KeyringParser ( parseTKsWithWireRep ) @@ -28,6 +41,7 @@ , OpenPGPRFC (..) , SecretKeyProtectionPolicy (..) , defaultPolicy + , lenientDecryptPolicy , policyForRFC ) import Codec.Encryption.OpenPGP.SecretKey @@ -39,22 +53,36 @@ , parsePktsWithWireRep ) import Codec.Encryption.OpenPGP.Types +import Data.Conduit.OpenPGP.Decrypt (PKESKRecipientKey (..)) import Tests.Common ( collectSecretKeyInfos , conduitDecryptWithPKESKContext , loadSEIPDv2FixtureWithV4Secret , loadV4EncryptedSecretKeyFixtureForProperty , loadV6UnencryptedSecretKeyFixtureForProperty + , mkPKESKSessionMaterialOrFail , prependUnusableLatestPKESK , readFixtureLazy , reorderPrecedingPKESKs , reverseIf , runGetTest , selectRecipientKeyInfo + , setKeyVersion + , testDecryptWithDecryptPolicy ) propertiesTests :: TestTree -propertiesTests = testGroup "Properties" [qcProps] +propertiesTests = + testGroup + "Properties" + [ qcProps + , testGroup + "PKAEncryptOps dictionary round-trips" + [ QC.testProperty + "X25519/X448 PKESKv3/v6 round-trip through pkaEncryptOpsDict" + prop_PKESK_round_trip + ] + ] qcProps :: TestTree qcProps = @@ -381,3 +409,191 @@ fromIntegral (1 + (cutSeed `mod` fromIntegral (BL.length encoded))) truncated = BL.take (BL.length encoded - cut) encoded + +prop_PKESK_round_trip :: QC.NonNegative Int -> QC.Property +prop_PKESK_round_trip (QC.NonNegative seed) = + QC.ioProperty $ + if even seed + then roundTripX25519 secretRaw25519 + else roundTripX448 secretRaw448 + where + secretRaw25519 = + B.pack [fromIntegral ((seed + i) `mod` 256) | i <- [1 .. 32]] + secretRaw448 = + B.pack [fromIntegral ((seed + i) `mod` 256) | i <- [1 .. 56]] + +roundTripX25519 :: B.ByteString -> IO QC.Property +roundTripX25519 secretRaw = do + let sk = case eitherCryptoError (C25519.secretKey secretRaw) of + Right k -> k + Left err -> + error + ("failed to initialize X25519 recipient secret key: " ++ show err) + pubRaw = BA.convert (C25519.toPublic sk) :: B.ByteString + recipient = + setKeyVersion + V6 + ( PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X25519 + ( EdDSAPubKey + EdSigningCurve25519 + (NativeEPoint (EPoint (os2ip pubRaw))) + ) + ) + runDictRoundTrip + "X25519" + X25519 + recipient + (X25519PrivateKey secretRaw) + +roundTripX448 :: B.ByteString -> IO QC.Property +roundTripX448 secretRaw = do + let sk = case eitherCryptoError (C448.secretKey secretRaw) of + Right k -> k + Left err -> + error + ("failed to initialize X448 recipient secret key: " ++ show err) + pubRaw = BA.convert (C448.toPublic sk) :: B.ByteString + recipient = + setKeyVersion + V6 + ( PKPayload + V4 + (ThirtyTwoBitTimeStamp 0) + 0 + X448 + ( EdDSAPubKey + EdSigningCurve448 + (NativeEPoint (EPoint (os2ip pubRaw))) + ) + ) + runDictRoundTrip "X448" X448 recipient (X448PrivateKey secretRaw) + +runDictRoundTrip + :: String + -> PubKeyAlgorithm + -> SomePKPayload + -> SKey + -> IO QC.Property +runDictRoundTrip label pka recipient skey = do + let passphraseCallback _ = pure B.empty + salt = Salt (B.pack [0x00 .. 0x1f]) + sessionKey = SessionKey (B.replicate 32 0x77) + payload = "dict round-trip" + literalBlock = + Block + [ LiteralDataPkt + BinaryData + (FileName B.empty) + (ThirtyTwoBitTimeStamp 0) + payload + ] + keyContextCallback _ = + pure + ( Just + ( PKESKRecipientKey + { pkeskRecipientPKPayload = Just recipient + , pkeskRecipientSKey = skey + } + ) + ) + sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey + case pkaEncryptOpsDict pka of + Nothing -> + pure + ( QC.counterexample + ("pkaEncryptOpsDict has no entry for " ++ label) + False + ) + Just (SomePKAEncryptOpsDict dict) -> do + v3Result <- + pkaDictBuildV3 + dict + recipient + (pkeskV3SessionMaterial sessionMaterial) + v6Result <- pkaDictBuildV6 dict recipient sessionMaterial + ciphertext <- + case encryptSEIPDv2Payload + AES256 + OCB + 6 + salt + sessionKey + (BL.toStrict (runPut (put literalBlock))) of + Left err -> + pure + ( Left + ("encryptSEIPDv2Payload failed: " ++ show err) + ) + Right ct -> pure (Right ct) + case (v3Result, v6Result, ciphertext) of + (Left err, _, _) -> + pure + ( QC.counterexample + ("pkaDictBuildV3 failed: " ++ show err) + False + ) + (_, Left err, _) -> + pure + ( QC.counterexample + ("pkaDictBuildV6 failed: " ++ show err) + False + ) + (_, _, Left err) -> + pure (QC.counterexample err False) + (Right v3p, Right v6p, Right ct) -> do + decryptedV6 <- + DC.runConduitRes $ + CL.sourceList + [ PKESKPkt (PKESKPayloadV6Packet v6p) + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct)) + ] + DC..| conduitDecryptWithPKESKContext + keyContextCallback + passphraseCallback + DC..| CL.consume + decryptedV3 <- + if pka == X448 + then + pure + [ LiteralDataPkt + BinaryData + (FileName B.empty) + (ThirtyTwoBitTimeStamp 0) + payload + ] + else + DC.runConduitRes $ + CL.sourceList + [ PKESKPkt (PKESKPayloadV3Packet v3p) + , SymEncIntegrityProtectedDataPkt + (SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct)) + ] + DC..| testDecryptWithDecryptPolicy + lenientDecryptPolicy + keyContextCallback + passphraseCallback + DC..| CL.consume + pure $ + QC.counterexample + ( "PKESKv3 " + ++ label + ++ " round-trip should yield original payload" + ) + ( case decryptedV3 of + [LiteralDataPkt _ _ _ got] -> got == payload + _ -> False + ) + QC..&&. QC.counterexample + ( "PKESKv6 " + ++ label + ++ " round-trip should yield original payload" + ) + ( case decryptedV6 of + [LiteralDataPkt _ _ _ got] -> got == payload + _ -> False + )