hOpenPGP 3.2.1 → 3.3
raw patch · 36 files changed
+2834/−2270 lines, 36 files
Files
- Codec/Encryption/OpenPGP/Arbitrary.hs +1/−1
- Codec/Encryption/OpenPGP/CFB.hs +138/−170
- Codec/Encryption/OpenPGP/Encrypt.hs +280/−400
- Codec/Encryption/OpenPGP/Expirations.hs +10/−9
- Codec/Encryption/OpenPGP/Internal.hs +40/−3
- Codec/Encryption/OpenPGP/Internal/CryptoAES.hs +37/−24
- Codec/Encryption/OpenPGP/Internal/CryptoSEIPDv2.hs +0/−135
- Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs +10/−12
- Codec/Encryption/OpenPGP/Internal/Whitespace.hs +31/−33
- Codec/Encryption/OpenPGP/KeyInfo.hs +1/−1
- Codec/Encryption/OpenPGP/KeyringParser.hs +10/−15
- Codec/Encryption/OpenPGP/Message.hs +260/−201
- Codec/Encryption/OpenPGP/Policy.hs +7/−8
- Codec/Encryption/OpenPGP/SEIPDv1.hs +87/−0
- Codec/Encryption/OpenPGP/SEIPDv2.hs +212/−0
- Codec/Encryption/OpenPGP/SecretKey.hs +50/−124
- Codec/Encryption/OpenPGP/Serialize.hs +142/−98
- Codec/Encryption/OpenPGP/SerializeForSigs.hs +0/−1
- Codec/Encryption/OpenPGP/Signatures.hs +20/−67
- Codec/Encryption/OpenPGP/Subpackets.hs +388/−334
- Codec/Encryption/OpenPGP/Types/Internal/Base.hs +13/−5
- Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs +8/−0
- Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs +2/−1
- Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +4/−3
- Codec/Encryption/OpenPGP/Types/Internal/TK.hs +16/−12
- Data/Conduit/OpenPGP/Decrypt.hs +292/−196
- Data/Conduit/OpenPGP/Filter.hs +2/−24
- Data/Conduit/OpenPGP/Keyring.hs +16/−45
- Data/Conduit/OpenPGP/Keyring/Instances.hs +0/−7
- hOpenPGP.cabal +6/−3
- tests/Tests/Common.hs +32/−143
- tests/Tests/Encryption.hs +110/−77
- tests/Tests/Keys.hs +17/−49
- tests/Tests/MessageAndArmor.hs +467/−55
- tests/Tests/Serialization.hs +120/−9
- tests/Tests/Utilities.hs +5/−5
Codec/Encryption/OpenPGP/Arbitrary.hs view
@@ -266,7 +266,7 @@ -- instance Arbitrary PubKeyAlgorithm where- arbitrary = elements [RSA, DSA, ECDH, ECDSA, DH, EdDSA]+ arbitrary = elements [RSA, DSA, ECDH, ECDSA, DH, EdDSALegacy] instance Arbitrary EightOctetKeyId where arbitrary = fmap (EightOctetKeyId . BL.pack) (vector 8)
Codec/Encryption/OpenPGP/CFB.hs view
@@ -3,213 +3,181 @@ -- Copyright © 2013 Daniel Kahn Gillmor -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} module Codec.Encryption.OpenPGP.CFB- ( decrypt- , decryptPreservingNonce- , decryptNoNonce- , decryptOpenPGPCfb- , decryptOpenPGPCfbWithNonce- , OpenPGPCFBMode(..)- , OpenPGPCFBModeW(..)- , encryptNoNonce- , encryptOpenPGPCfbRaw- , mdcTrailerForSEIPDv1- , seipdv1NonceFromIV- , validateSEIPD1MDC- , calculateMDC- ) where+ ( decrypt+ , decryptPreservingNonce+ , decryptNoNonce+ , decryptOpenPGPCfb+ , decryptOpenPGPCfbWithNonce+ , OpenPGPCFBMode (..)+ , OpenPGPCFBModeW (..)+ , encryptNoNonce+ , encryptOpenPGPCfbRaw+ ) where -import Codec.Encryption.OpenPGP.BlockCipher (CipherError(..), withSymmetricCipher)+import qualified Data.ByteString as B++import Codec.Encryption.OpenPGP.BlockCipher+ ( CipherError (..)+ , withSymmetricCipher+ ) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types-import qualified Crypto.Hash as CH-import qualified Crypto.Hash.Algorithms as CHA-import qualified Data.ByteArray as BA-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL-import Control.Monad (when) data OpenPGPCFBMode- = OpenPGPCFBResync- | OpenPGPCFBNoResync- deriving (Eq, Show)+ = OpenPGPCFBResync+ | OpenPGPCFBNoResync+ deriving (Eq, Show) data OpenPGPCFBModeW (mode :: OpenPGPCFBMode) where- OpenPGPCFBResyncW :: OpenPGPCFBModeW 'OpenPGPCFBResync- OpenPGPCFBNoResyncW :: OpenPGPCFBModeW 'OpenPGPCFBNoResync+ OpenPGPCFBResyncW :: OpenPGPCFBModeW 'OpenPGPCFBResync+ OpenPGPCFBNoResyncW :: OpenPGPCFBModeW 'OpenPGPCFBNoResync -decryptOpenPGPCfb ::- SymmetricAlgorithm- -> B.ByteString- -> B.ByteString- -> Either CipherError B.ByteString+decryptOpenPGPCfb+ :: SymmetricAlgorithm+ -> B.ByteString+ -> B.ByteString+ -> Either CipherError B.ByteString decryptOpenPGPCfb sa ciphertext keydata =- snd <$> decryptOpenPGPCfbWithNonce sa ciphertext keydata+ snd <$> decryptOpenPGPCfbWithNonce sa ciphertext keydata -decryptOpenPGPCfbWithNonce ::- SymmetricAlgorithm- -> B.ByteString- -> B.ByteString- -> Either CipherError (B.ByteString, B.ByteString)+decryptOpenPGPCfbWithNonce+ :: SymmetricAlgorithm+ -> B.ByteString+ -> B.ByteString+ -> Either CipherError (B.ByteString, B.ByteString) decryptOpenPGPCfbWithNonce Plaintext ciphertext _ = return (mempty, ciphertext) decryptOpenPGPCfbWithNonce sa ciphertext keydata =- withSymmetricCipher sa keydata $ \bc -> do- nonce <- decrypt1 ciphertext bc- cleartext <- decrypt2 ciphertext bc- if nonceCheck bc nonce- then return (nonce, cleartext)- else Left "Session key quickcheck failed"+ withSymmetricCipher sa keydata $ \bc -> do+ nonce <- decrypt1 ciphertext bc+ cleartext <- decrypt2 ciphertext bc+ if nonceCheck bc nonce+ then return (nonce, cleartext)+ else Left "Session key quickcheck failed" where- decrypt1 ::- HOBlockCipher cipher- => B.ByteString- -> cipher- -> Either String B.ByteString+ decrypt1+ :: HOBlockCipher cipher+ => B.ByteString+ -> cipher+ -> Either String B.ByteString decrypt1 ct cipher =- paddedCfbDecrypt- cipher- (B.replicate (blockSize cipher) 0)- (B.take (blockSize cipher + 2) ct)- decrypt2 ::- HOBlockCipher cipher- => B.ByteString- -> cipher- -> Either String B.ByteString+ paddedCfbDecrypt+ cipher+ (B.replicate (blockSize cipher) 0)+ (B.take (blockSize cipher + 2) ct)+ decrypt2+ :: HOBlockCipher cipher+ => B.ByteString+ -> cipher+ -> Either String B.ByteString decrypt2 ct cipher =- let i = B.take (blockSize cipher) (B.drop 2 ct)- in paddedCfbDecrypt cipher i (B.drop (blockSize cipher + 2) ct)+ let i = B.take (blockSize cipher) (B.drop 2 ct)+ in paddedCfbDecrypt cipher i (B.drop (blockSize cipher + 2) ct) -- should deprecate this?-decrypt ::- SymmetricAlgorithm- -> B.ByteString- -> B.ByteString- -> Either CipherError B.ByteString+decrypt+ :: SymmetricAlgorithm+ -> B.ByteString+ -> B.ByteString+ -> Either CipherError B.ByteString decrypt x y z = snd <$> (decryptPreservingNonce x y z) -decryptPreservingNonce ::- SymmetricAlgorithm- -> B.ByteString- -> B.ByteString- -> Either CipherError (B.ByteString, B.ByteString)+decryptPreservingNonce+ :: SymmetricAlgorithm+ -> B.ByteString+ -> B.ByteString+ -> Either CipherError (B.ByteString, B.ByteString) decryptPreservingNonce Plaintext ciphertext _ = return (mempty, ciphertext) decryptPreservingNonce sa ciphertext keydata =- withSymmetricCipher sa keydata $ \bc -> do- let bs = blockSize bc- decrypted <- paddedCfbDecrypt bc (B.replicate bs 0) ciphertext- let (nonce, cleartext) = B.splitAt (bs + 2) decrypted- if nonceCheck bc nonce- then return (nonce, cleartext)- else Left "Session key quickcheck failed"+ withSymmetricCipher sa keydata $ \bc -> do+ let bs = blockSize bc+ decrypted <- paddedCfbDecrypt bc (B.replicate bs 0) ciphertext+ let (nonce, cleartext) = B.splitAt (bs + 2) decrypted+ if nonceCheck bc nonce+ then return (nonce, cleartext)+ else Left "Session key quickcheck failed" -decryptNoNonce ::- SymmetricAlgorithm- -> IV- -> B.ByteString- -> B.ByteString- -> Either CipherError B.ByteString+decryptNoNonce+ :: SymmetricAlgorithm+ -> IV+ -> B.ByteString+ -> B.ByteString+ -> Either CipherError B.ByteString decryptNoNonce Plaintext _ ciphertext _ = return ciphertext decryptNoNonce sa iv ciphertext keydata =- withSymmetricCipher sa keydata (decrypt' ciphertext)+ withSymmetricCipher sa keydata (decrypt' ciphertext) where- decrypt' ::- HOBlockCipher cipher- => B.ByteString- -> cipher- -> Either String B.ByteString+ decrypt'+ :: HOBlockCipher cipher+ => B.ByteString+ -> cipher+ -> Either String B.ByteString decrypt' ct cipher = paddedCfbDecrypt cipher (unIV iv) ct -nonceCheck :: HOBlockCipher cipher => cipher -> B.ByteString -> Bool+nonceCheck+ :: HOBlockCipher cipher => cipher -> B.ByteString -> Bool nonceCheck bc =- (==) <$> B.take 2 . B.drop (blockSize bc - 2) <*> B.drop (blockSize bc)+ (==)+ <$> B.take 2 . B.drop (blockSize bc - 2)+ <*> B.drop (blockSize bc) -encryptNoNonce ::- SymmetricAlgorithm- -> S2K- -> IV- -> B.ByteString- -> B.ByteString- -> Either CipherError B.ByteString+encryptNoNonce+ :: SymmetricAlgorithm+ -> S2K+ -> IV+ -> B.ByteString+ -> B.ByteString+ -> Either CipherError B.ByteString encryptNoNonce Plaintext _ _ payload _ = return payload-encryptNoNonce sa s2k iv payload keydata =- withSymmetricCipher sa keydata (encrypt' payload)+encryptNoNonce sa _s2k iv payload keydata =+ withSymmetricCipher sa keydata (encrypt' payload) where- encrypt' ::- HOBlockCipher cipher- => B.ByteString- -> cipher- -> Either String B.ByteString+ encrypt'+ :: HOBlockCipher cipher+ => B.ByteString+ -> cipher+ -> Either String B.ByteString encrypt' ct cipher = paddedCfbEncrypt cipher (unIV iv) ct -encryptOpenPGPCfbRaw ::- OpenPGPCFBModeW mode- -> SymmetricAlgorithm- -> IV- -> B.ByteString -- ^ plaintext (with MDC trailer already appended)- -> B.ByteString -- ^ raw session key bytes- -> Either CipherError B.ByteString+encryptOpenPGPCfbRaw+ :: OpenPGPCFBModeW mode+ -> SymmetricAlgorithm+ -> IV+ -> B.ByteString+ -- ^ plaintext (with MDC trailer already appended)+ -> B.ByteString+ -- ^ raw session key bytes+ -> Either CipherError B.ByteString encryptOpenPGPCfbRaw _ Plaintext _ cleartext _ = Right cleartext encryptOpenPGPCfbRaw mode sa iv cleartext keydata =- withSymmetricCipher sa keydata $ \cipher -> do- let initialVector = unIV iv- bs = blockSize cipher- if B.length initialVector /= bs- then Left- ("IV length mismatch for " ++- show sa ++- ": expected " ++ show bs ++ ", got " ++ show (B.length initialVector))- else do- let prefix = initialVector <> B.drop (bs - 2) initialVector- case mode of- OpenPGPCFBResyncW -> do- nonceAndCheck <- paddedCfbEncrypt cipher (B.replicate bs 0) prefix- encryptedPayload <-- paddedCfbEncrypt cipher (B.take bs (B.drop 2 nonceAndCheck)) cleartext- return (nonceAndCheck <> encryptedPayload)- OpenPGPCFBNoResyncW ->- paddedCfbEncrypt cipher (B.replicate bs 0) (prefix <> cleartext)---- | Compute the MDC trailer appended to SEIPDv1 plaintext before encryption.--- The trailer is: @0xd3 0x14 SHA1(nonce || plaintext || 0xd3 0x14)@.-mdcTrailerForSEIPDv1 :: IV -> B.ByteString -> B.ByteString-mdcTrailerForSEIPDv1 iv plaintext = mdcHeader <> digest- where- mdcHeader = B.pack [0xd3, 0x14]- nonce = seipdv1NonceFromIV iv- digest = BA.convert (CH.hash (nonce <> plaintext <> mdcHeader) :: CH.Digest CHA.SHA1)---- | The SEIPDv1 nonce: the IV bytes followed by its last two bytes (resync prefix).-seipdv1NonceFromIV :: IV -> B.ByteString-seipdv1NonceFromIV (IV ivBytes) = ivBytes <> B.drop (B.length ivBytes - 2) ivBytes--calculateMDC :: B.ByteString -> B.ByteString -> Maybe BL.ByteString-calculateMDC nonce garbage- | B.length garbage < 23 = Nothing- | otherwise =- let digest = CH.hash (nonce <> B.take (B.length garbage - 22) garbage <> B.pack [211, 20]) :: CH.Digest CHA.SHA1- in Just (BL.fromStrict (BA.convert digest :: B.ByteString))---- | Verify the MDC trailer of a decrypted SEIPDv1 payload.--- Takes the CFB nonce (blockSize+2 prefix bytes retained from decryption)--- and the full decrypted bytes (payload + MDC packet), and returns the--- payload without the MDC trailer on success.-validateSEIPD1MDC :: B.ByteString -> B.ByteString -> Either String B.ByteString-validateSEIPD1MDC nonce decrypted = do- when (B.length decrypted < 22) $- Left "SEIPD1 cleartext too short to contain MDC trailer"- let (payload, trailer) = B.splitAt (B.length decrypted - 22) decrypted- when (B.take 2 trailer /= B.pack [211, 20]) $- Left "SEIPD1 cleartext missing MDC packet trailer (tag 19)"- expectedMdc <-- case calculateMDC nonce decrypted of- Nothing -> Left "SEIPD1 cleartext too short for MDC calculation"- Just x -> Right x- let actualMdc = BL.fromStrict (B.drop 2 trailer)- when (expectedMdc /= actualMdc) $- Left "MDC indicates tampering"- Right payload+ withSymmetricCipher sa keydata $ \cipher -> do+ let initialVector = unIV iv+ bs = blockSize cipher+ if B.length initialVector /= bs+ then+ Left+ ( "IV length mismatch for "+ ++ show sa+ ++ ": expected "+ ++ show bs+ ++ ", got "+ ++ show (B.length initialVector)+ )+ else do+ let prefix = initialVector <> B.drop (bs - 2) initialVector+ case mode of+ OpenPGPCFBResyncW -> do+ nonceAndCheck <-+ paddedCfbEncrypt cipher (B.replicate bs 0) prefix+ encryptedPayload <-+ paddedCfbEncrypt+ cipher+ (B.take bs (B.drop 2 nonceAndCheck))+ cleartext+ return (nonceAndCheck <> encryptedPayload)+ OpenPGPCFBNoResyncW ->+ paddedCfbEncrypt cipher (B.replicate bs 0) (prefix <> cleartext)
Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -13,6 +13,7 @@ module Codec.Encryption.OpenPGP.Encrypt ( PKESKEncryptError (..)+ , renderPKESKEncryptError , RecipientCapabilityNegotiationMode (..) , RecipientCapabilityError (..) , renderRecipientCapabilityError@@ -23,13 +24,9 @@ , RecipientEncryptionTargetRejected (..) , RecipientEncryptionTargetsReport (..) , recipientEncryptionTargetsReportFromTKAtTimestamp- , recipientEncryptionTargetsReportFromTK- , recipientEncryptionTargetFromTKAtTimestamp , recipientEncryptionTargetFromTKAtTimestampWithPolicy , recipientEncryptionTargetsFromTKAtTimestamp- , recipientEncryptionTargetFromTK , recipientEncryptionTargetFromTKWithPolicy- , recipientEncryptionTargetsFromTK , RecipientTargetSelectionPolicy (..) , PassphraseSKESKVersionPolicy (..) , PassphraseEncryptRequest (..)@@ -45,10 +42,8 @@ , SomeEncryptCompatibilityProfileW (..) , RecipientEncryptionTarget (..) , recipientEncryptionTarget- , recipientEncryptionTargetWithStrategy , recipientEncryptionTargetWithCapabilities , recipientEncryptionTargetWithStrategyTyped- , recipientVersionStrategyForProfile , recipientVersionStrategyForProfileTyped , RecipientPayloadShape (..) , defaultRecipientPayloadShape@@ -77,7 +72,6 @@ , buildPKESKv3PktForRecipient , buildPKESKPayloadForRecipient , buildPKESKPktForRecipient- , buildPKESKPktsForRecipientTargetsWithSelector , buildPKESKPktsForRecipientTargetsWithSelectorTyped , encryptSEIPDv2Payload , encryptSEIPDv1Payload@@ -85,15 +79,25 @@ , encryptSEIPDv2WithSKESKBlock , encryptSEIPDv2LiteralDataWithSKESK , composeMessageWithSEIPDv2+ , buildOnePassSignature+ , OPSBuildError (..)+ , renderOPSBuildError+ , NestedFlag+ , aesKeyWrapRFC3394+ , deriveX25519Kek+ , deriveX448Kek ) where import Control.Applicative ((<|>))+import Control.Error.Util (note) import Control.Lens (ix, (.~)) import Control.Monad (when)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT (..), runExceptT) import qualified Crypto.Error as CE-import qualified Crypto.Hash.Algorithms as CHAlg+import qualified Crypto.Hash.Algorithms as CHA import Crypto.KDF.HKDF (expand, extract)-import Crypto.Number.Serialize (i2osp, os2ip)+import Crypto.Number.Serialize (os2ip) import qualified Crypto.PubKey.Curve25519 as C25519 import qualified Crypto.PubKey.Curve448 as C448 import qualified Crypto.PubKey.ECC.DH as ECCDH@@ -103,25 +107,25 @@ import Crypto.Random.Types (MonadRandom, getRandomBytes) import Data.Bifunctor (first) import Data.Binary (put)-import Data.Binary.Put (putWord64be, runPut)-import Data.Bits (shiftL, shiftR, xor, (.&.))+import Data.Binary.Put (runPut)+import Data.Bits (shiftL) import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Containers.ListUtils (nubOrd) import Data.Int (Int64)-import Data.List (find, foldl', maximumBy)+import Data.List (find, maximumBy) import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)+import Data.Maybe (fromMaybe, listToMaybe) import Data.Ord (comparing) import qualified Data.Set as Set import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Data.Word (Word16, Word64, Word8)+import Data.Word (Word64, Word8) import qualified "crypton" Crypto.Cipher.Types as CCT import Codec.Encryption.OpenPGP.BlockCipher- ( CipherError+ ( CipherError (..) , keySize , renderCipherError , withSymmetricCipher@@ -129,7 +133,6 @@ import Codec.Encryption.OpenPGP.CFB ( OpenPGPCFBModeW (..) , encryptOpenPGPCfbRaw- , mdcTrailerForSEIPDv1 ) import Codec.Encryption.OpenPGP.Expirations ( effectiveKeyPreferencesAtTimestamp@@ -142,7 +145,15 @@ ( eightOctetKeyID , fingerprint )-import Codec.Encryption.OpenPGP.Internal (leftPadTo, point2MBS)+import Codec.Encryption.OpenPGP.Internal+ ( checksum16Bytes+ , chunksOf8+ , edPointBytes+ , encodeWord64be+ , leftPadTo+ , point2MBS+ , xorBS+ ) import Codec.Encryption.OpenPGP.Internal.CryptoAES ( withAESCipher )@@ -151,12 +162,6 @@ , deriveECDHKek , normalizeMontgomeryPublic )-import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2- ( aeadModeAndNonceSizeForSEIPDv2- , deriveSKESK6KEK- , encryptSKESK6SessionKey- , seipdv2SymmetricKeySize- ) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher ( HOBlockCipher (..) )@@ -171,7 +176,6 @@ ( MessageEncryptionPolicy , OpenPGPRFC (..) , PKESKVersionPolicy (..)- , defaultPKESKVersionPolicy , messageDefaultAEADAlgorithm , messageDefaultChunkSize , messageDefaultSymmetricAlgorithm@@ -180,7 +184,18 @@ , policyForRFC , policyMessageEncryption )-import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key)+import Codec.Encryption.OpenPGP.S2K+ ( string2Key+ )+import Codec.Encryption.OpenPGP.SEIPDv1 (mdcTrailerForSEIPDv1)+import Codec.Encryption.OpenPGP.SEIPDv2+ ( SEIPDv2Failure (..)+ , aeadModeAndNonceSizeForSEIPDv2+ , deriveSKESK6KEK+ , encryptSKESK6SessionKey+ , renderSEIPDv2Failure+ , seipdv2SymmetricKeySize+ ) import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.SignatureQualities ( sigCT@@ -218,8 +233,10 @@ | InvalidRecipientKeyMaterial PubKeyAlgorithm String | RecipientKdfFailure PubKeyAlgorithm String | RecipientKeyWrapFailure PubKeyAlgorithm String+ | RecipientKeyWrapFailureCipher PubKeyAlgorithm CipherError | RecipientCapabilitySelectionFailure RecipientCapabilityError | PayloadBuildFailure String+ | PayloadBuildFailureCipher CipherError | NoRecipientsProvided deriving (Eq, Show) @@ -255,10 +272,17 @@ ++ show algo ++ ": " ++ reason+renderPKESKEncryptError (RecipientKeyWrapFailureCipher algo err) =+ "key wrap failure for recipient algorithm "+ ++ show algo+ ++ ": "+ ++ renderCipherError err renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) = renderRecipientCapabilityError err renderPKESKEncryptError (PayloadBuildFailure reason) = "payload build failure: " ++ reason+renderPKESKEncryptError (PayloadBuildFailureCipher err) =+ "payload build failure: " ++ renderCipherError err renderPKESKEncryptError NoRecipientsProvided = "no recipients provided" @@ -433,20 +457,6 @@ recipientCapabilityAdvertisesSEIPDv1Support caps && Set.member FeatureSEIPDv2 (recipientCapabilityFeatures caps) -{-# DEPRECATED- recipientEncryptionTargetFromTKAtTimestamp- "Use recipientEncryptionTargetFromTKAtTimestampWithPolicy instead"- #-}-recipientEncryptionTargetFromTKAtTimestamp- :: ThirtyTwoBitTimeStamp- -> TK 'PublicTK- -> Either RecipientCapabilityError RecipientEncryptionTarget-recipientEncryptionTargetFromTKAtTimestamp timestamp tk =- recipientEncryptionTargetFromTKAtTimestampWithPolicy- RecipientTargetSelectionFirstValid- timestamp- tk- data RecipientTargetSelectionPolicy = RecipientTargetSelectionFirstValid | RecipientTargetSelectionPreferPrimary@@ -460,27 +470,14 @@ -> TK 'PublicTK -> Either RecipientCapabilityError RecipientEncryptionTarget recipientEncryptionTargetFromTKAtTimestampWithPolicy policy timestamp tk =- case chooseRecipientTarget policy tk acceptedTargets of- Just target -> Right target- Nothing -> Left RecipientCapabilityNoEncryptableKeyMaterialInTK+ note+ RecipientCapabilityNoEncryptableKeyMaterialInTK+ (chooseRecipientTarget policy tk acceptedTargets) where acceptedTargets = recipientEncryptionTargetsAccepted (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) -{-# DEPRECATED- recipientEncryptionTargetFromTK- "Use recipientEncryptionTargetFromTKWithPolicy instead"- #-}-recipientEncryptionTargetFromTK- :: TK 'PublicTK- -> Either RecipientCapabilityError RecipientEncryptionTarget-recipientEncryptionTargetFromTK tk =- recipientEncryptionTargetFromTKAtTimestampWithPolicy- RecipientTargetSelectionFirstValid- (_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))- tk- recipientEncryptionTargetFromTKWithPolicy :: RecipientTargetSelectionPolicy -> TK 'PublicTK@@ -569,24 +566,6 @@ : recipientEncryptionTargetsRejected report } -{-# DEPRECATED- recipientEncryptionTargetsFromTK- "Use recipientEncryptionTargetsFromTKAtTimestamp instead"- #-}-recipientEncryptionTargetsFromTK- :: TK 'PublicTK -> [RecipientEncryptionTarget]-recipientEncryptionTargetsFromTK tk =- recipientEncryptionTargetsFromTKAtTimestamp- (_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))- tk--recipientEncryptionTargetsReportFromTK- :: TK 'PublicTK -> RecipientEncryptionTargetsReport-recipientEncryptionTargetsReportFromTK tk =- recipientEncryptionTargetsReportFromTKAtTimestamp- (_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))- tk- subkeyBindingCapabilityPayloads :: ThirtyTwoBitTimeStamp -> TK 'PublicTK@@ -892,13 +871,6 @@ deriving (Eq, Show) type family- PayloadVersionForProfile (profile :: EncryptCompatibilityProfile)- :: SEIPDVersion- where- PayloadVersionForProfile 'EncryptStrictDefault = 'SEIPDv2- PayloadVersionForProfile 'EncryptInteropLegacy = 'SEIPDv1--type family ProfileForPayloadVersion (version :: SEIPDVersion) :: EncryptCompatibilityProfile where@@ -927,17 +899,6 @@ recipientEncryptionTarget recipient = RecipientEncryptionTarget recipient Nothing Nothing -{-# DEPRECATED- recipientEncryptionTargetWithStrategy- "Use recipientEncryptionTargetWithStrategyTyped instead"- #-}-recipientEncryptionTargetWithStrategy- :: SomePKPayload- -> RecipientPKESKVersionStrategy- -> RecipientEncryptionTarget-recipientEncryptionTargetWithStrategy recipient strategy =- RecipientEncryptionTarget recipient (Just strategy) Nothing- recipientEncryptionTargetWithCapabilities :: SomePKPayload -> RecipientCapabilities@@ -950,23 +911,10 @@ -> RecipientPKESKVersionStrategyW strategy -> RecipientEncryptionTarget recipientEncryptionTargetWithStrategyTyped recipient strategyW =- recipientEncryptionTargetWithStrategy+ RecipientEncryptionTarget recipient- (demoteRecipientStrategy strategyW)--{-# DEPRECATED- recipientVersionStrategyForProfile- "Use recipientVersionStrategyForProfileTyped instead"- #-}-recipientVersionStrategyForProfile- :: EncryptCompatibilityProfile- -> RecipientEncryptionTarget- -> Either PKESKEncryptError RecipientPKESKVersionStrategy-recipientVersionStrategyForProfile profile target =- case promoteEncryptCompatibilityProfile profile of- SomeEncryptCompatibilityProfileW profileW ->- demoteSomeRecipientStrategy- <$> recipientVersionStrategyForProfileTyped profileW target+ (Just (demoteRecipientStrategy strategyW))+ Nothing recipientVersionStrategyForProfileTyped :: EncryptCompatibilityProfileW profile@@ -1036,7 +984,7 @@ encryptPassphraseWithPolicy :: MonadRandom m => PassphraseEncryptRequest- -> m (Either String [Pkt])+ -> m (Either SEIPDv2Failure [Pkt]) encryptPassphraseWithPolicy request = case passphraseEncryptVersionPolicy request of PassphraseSKESKForceV4Interop ->@@ -1272,27 +1220,6 @@ (fmap PKESKPkt) (buildPKESKv3PayloadForRecipient recipient material) --- | Build PKESK packets for all recipients with a single shared session key.-{-# DEPRECATED- buildPKESKPktsForRecipientTargetsWithSelector- "Use buildPKESKPktsForRecipientTargetsWithSelectorTyped instead"- #-}-buildPKESKPktsForRecipientTargetsWithSelector- :: MonadRandom m- => ( RecipientEncryptionTarget- -> Either PKESKEncryptError RecipientPKESKVersionStrategy- )- -> [RecipientEncryptionTarget]- -> PKESKSessionMaterial- -> m (Either PKESKEncryptError [Pkt])-buildPKESKPktsForRecipientTargetsWithSelector selector targets material =- buildPKESKPktsForRecipientTargetsWithSelectorTyped- ( \target ->- promoteRecipientStrategy <$> selector target- )- targets- material- buildPKESKPktsForRecipientTargetsWithSelectorTyped :: MonadRandom m => ( RecipientEncryptionTarget@@ -1363,9 +1290,13 @@ -> RecipientPKESKRequestPayload strategy -> m (Either PKESKEncryptError Pkt) buildPKESKPktForRecipientWithPreparedPayload strategy recipient payload =- fmap fmapPKESKPkt payloadResult+ fmap (fmap PKESKPkt) payloadResult where- fmapPKESKPkt = fmap PKESKPkt+ packetizeV6+ :: Functor m+ => m (Either PKESKEncryptError PKESKPayloadV6)+ -> m (Either PKESKEncryptError PKESKPayload)+ packetizeV6 = fmap (fmap PKESKPayloadV6Packet) payloadResult = case (strategy, payload) of (RecipientForceV3InteropW, RecipientForceV3Payload v3Material) ->@@ -1374,22 +1305,10 @@ , RecipientPreferV6Payload material v6RawMaterial ) -> case _pkalgo recipient of- RSA ->- fmap- (fmap PKESKPayloadV6Packet)- (buildRsaPKESKv6 recipient material)- ECDH ->- fmap- (fmap PKESKPayloadV6Packet)- (buildECDHPKESKv6 recipient material)- X25519 ->- fmap- (fmap PKESKPayloadV6Packet)- (buildX25519PKESKv6 recipient v6RawMaterial)- X448 ->- fmap- (fmap PKESKPayloadV6Packet)- (buildX448PKESKv6 recipient v6RawMaterial)+ 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)) @@ -1433,98 +1352,27 @@ -> m (Either PKESKEncryptError RecipientEncryptResult) encryptForRecipientsWithCapabilityNegotiation negotiationMode request | null targets = pure (Left NoRecipientsProvided)- | otherwise =- case selectSymmetricAlgorithm- negotiationMode+ | otherwise = runExceptT $ do+ symalgo <-+ ExceptT . pure $+ selectSymmetricAlgorithm+ negotiationMode+ request+ messagePolicy+ targets+ sessionMaterial <- ExceptT $ generateSessionKeyMaterial symalgo+ pkeskPkts <-+ ExceptT $+ buildPKESKPktsForRecipientTargetsWithSelectorTyped+ (recipientVersionStrategyForProfileTyped profileW)+ targets+ sessionMaterial+ buildEncryptedPayload request- messagePolicy- targets of- Left err -> pure (Left err)- Right symalgo -> do- sessionMaterialResult <- generateSessionKeyMaterial symalgo- case sessionMaterialResult of- Left err -> pure (Left err)- Right sessionMaterial -> do- pkeskResult <-- buildPKESKPktsForRecipientTargetsWithSelectorTyped- (recipientVersionStrategyForProfileTyped profileW)- targets- sessionMaterial- case pkeskResult of- Left err -> pure (Left err)- Right pkeskPkts -> do- payloadResult <- case recipientEncryptRequestOverrides request of- RecipientEncryptRequestSEIPDv2Overrides- { recipientEncryptRequestAEADOverride = aeadOverride- , recipientEncryptRequestChunkSizeOverride = chunkSizeOverride- , recipientEncryptRequestSaltOverride = saltOverride- } ->- case recipientsMissingSEIPDv2Support targets of- [] -> do- case selectAEADAlgorithm- negotiationMode- messagePolicy- targets- aeadOverride of- Left err -> pure (Left err)- Right aead -> do- salt <- maybe (Salt <$> getRandomBytes 32) pure saltOverride- let chunkSize =- maybe- (messageDefaultChunkSize messagePolicy)- id- chunkSizeOverride- pure $- buildEncryptedPacketSequenceWithShape- symalgo- aead- chunkSize- (recipientEncryptRequestPayloadShape request)- salt- (pkeskSessionKey sessionMaterial)- pkeskPkts- (recipientEncryptRequestPayload request)- _missingSEIPDv2 ->- case recipientsMissingSEIPDv1Support targets of- [] ->- buildSEIPDv1PayloadWithIV- symalgo- sessionMaterial- pkeskPkts- Nothing- missingSEIPDv1 ->- pure- ( Left- ( RecipientCapabilitySelectionFailure- (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1)- )- )- RecipientEncryptRequestSEIPDv1Overrides- { recipientEncryptRequestIVOverride = ivOverride- } ->- case recipientsMissingSEIPDv1Support targets of- [] ->- buildSEIPDv1PayloadWithIV- symalgo- sessionMaterial- pkeskPkts- ivOverride- missingSEIPDv1 ->- pure- ( Left- ( RecipientCapabilitySelectionFailure- (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1)- )- )- pure $- fmap- ( \pkts ->- RecipientEncryptResult- { recipientEncryptPackets = pkts- , recipientEncryptSessionMaterial = sessionMaterial- }- )- payloadResult+ targets+ symalgo+ sessionMaterial+ pkeskPkts where targets = recipientEncryptRequestTargets request profileW =@@ -1536,6 +1384,99 @@ policyMessageEncryption (policyForRFC RFC9580) EncryptInteropLegacyW -> policyMessageEncryption (policyForRFC RFC4880)+ buildEncryptedPayload+ :: MonadRandom m+ => RecipientEncryptRequest v+ -> [RecipientEncryptionTarget]+ -> SymmetricAlgorithm+ -> PKESKSessionMaterial+ -> [Pkt]+ -> ExceptT PKESKEncryptError m RecipientEncryptResult+ buildEncryptedPayload request targets symalgo sessionMaterial pkeskPkts =+ case recipientEncryptRequestOverrides request of+ RecipientEncryptRequestSEIPDv2Overrides+ { recipientEncryptRequestAEADOverride = aeadOverride+ , 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)+ )+ _missingSEIPDv2 ->+ case recipientsMissingSEIPDv1Support targets of+ [] -> do+ pkts <-+ ExceptT $+ buildSEIPDv1PayloadWithIV+ symalgo+ sessionMaterial+ pkeskPkts+ Nothing+ pure $+ RecipientEncryptResult+ { recipientEncryptPackets = pkts+ , recipientEncryptSessionMaterial = sessionMaterial+ }+ missingSEIPDv1 ->+ ExceptT . pure $+ Left+ ( RecipientCapabilitySelectionFailure+ (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1)+ )+ RecipientEncryptRequestSEIPDv1Overrides+ { recipientEncryptRequestIVOverride = ivOverride+ } ->+ case recipientsMissingSEIPDv1Support targets of+ [] -> do+ pkts <-+ ExceptT $+ buildSEIPDv1PayloadWithIV+ symalgo+ sessionMaterial+ pkeskPkts+ ivOverride+ pure $+ RecipientEncryptResult+ { recipientEncryptPackets = pkts+ , recipientEncryptSessionMaterial = sessionMaterial+ }+ missingSEIPDv1 ->+ ExceptT . pure $+ Left+ ( RecipientCapabilitySelectionFailure+ (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1)+ ) buildSEIPDv1PayloadWithIV :: MonadRandom m@@ -1544,18 +1485,9 @@ -> [Pkt] -> Maybe IV -> m (Either PKESKEncryptError [Pkt])- buildSEIPDv1PayloadWithIV symalgo sessionMaterial pkeskPkts ivOverride = do- ivResult <-- case ivOverride of- Just iv -> pure (Right iv)- Nothing ->- let keyBytes = unSessionKey (pkeskSessionKey sessionMaterial)- in case withSymmetricCipher symalgo keyBytes (\c -> Right (blockSize c)) of- Left err -> pure (Left (PayloadBuildFailure (renderCipherError err)))- Right n -> fmap (Right . IV) (getRandomBytes n)- case ivResult of- Left err -> pure (Left err)- Right iv ->+ buildSEIPDv1PayloadWithIV symalgo sessionMaterial pkeskPkts ivOverride =+ case ivOverride of+ Just iv -> pure $ buildEncryptedPacketSequenceWithShapeSEIPDv1 symalgo@@ -1564,6 +1496,20 @@ (pkeskSessionKey sessionMaterial) pkeskPkts (recipientEncryptRequestPayload request)+ Nothing ->+ let keyBytes = unSessionKey (pkeskSessionKey sessionMaterial)+ in case withSymmetricCipher symalgo keyBytes (\c -> Right (blockSize c)) of+ Left err -> pure (Left (PayloadBuildFailure (renderCipherError err)))+ Right n ->+ getRandomBytes n >>= \bytes ->+ pure $+ buildEncryptedPacketSequenceWithShapeSEIPDv1+ symalgo+ (IV bytes)+ (recipientEncryptRequestPayloadShape request)+ (pkeskSessionKey sessionMaterial)+ pkeskPkts+ (recipientEncryptRequestPayload request) recipientsMissingSEIPDv1Support :: [RecipientEncryptionTarget] -> [SomePKPayload]@@ -1644,7 +1590,8 @@ case recipientEncryptionTargetCapabilities target of Just caps -> let preferred = recipientCapabilityPreferredSymmetricAlgorithms caps- allowed = [alg | alg <- policyOrder, alg `elem` preferred]+ preferredSet = Set.fromList preferred+ allowed = [alg | alg <- policyOrder, alg `Set.member` preferredSet] in if null allowed then policyOrder else allowed@@ -1670,14 +1617,15 @@ case recipientEncryptionTargetCapabilities target of Just caps -> let preferred = recipientCapabilityPreferredAEADAlgorithms caps- allowed = [alg | alg <- policyOrder, alg `elem` preferred]+ preferredSet = Set.fromList preferred+ allowed = [alg | alg <- policyOrder, alg `Set.member` preferredSet] in if null allowed then policyOrder else allowed Nothing -> policyOrder chooseCommonAlgorithm- :: Eq a+ :: (Eq a, Ord a) => [a] -> [[a]] -> RecipientCapabilityError@@ -1687,12 +1635,13 @@ [] -> Left (RecipientCapabilitySelectionFailure err) (firstChoices : restChoices) -> let common = foldl' intersectOrdered firstChoices restChoices- orderedCommon = [alg | alg <- policyOrder, alg `elem` common]+ commonSet = Set.fromList common+ orderedCommon = [alg | alg <- policyOrder, alg `Set.member` commonSet] in case orderedCommon of (selected : _) -> Right selected [] -> Left (RecipientCapabilitySelectionFailure err) where- intersectOrdered as bs = [a | a <- as, a `elem` bs]+ intersectOrdered as bs = [a | a <- as, a `Set.member` Set.fromList bs] promoteRecipientStrategy :: RecipientPKESKVersionStrategy@@ -1708,49 +1657,6 @@ demoteRecipientStrategy RecipientPreferV6W = RecipientPreferV6 demoteRecipientStrategy RecipientForceV3InteropW = RecipientForceV3Interop -demoteSomeRecipientStrategy- :: SomeRecipientPKESKVersionStrategyW- -> RecipientPKESKVersionStrategy-demoteSomeRecipientStrategy (SomeRecipientPKESKVersionStrategyW strategyW) =- demoteRecipientStrategy strategyW--promoteEncryptCompatibilityProfile- :: EncryptCompatibilityProfile- -> SomeEncryptCompatibilityProfileW-promoteEncryptCompatibilityProfile EncryptStrictDefault =- SomeEncryptCompatibilityProfileW EncryptStrictDefaultW-promoteEncryptCompatibilityProfile EncryptInteropLegacy =- SomeEncryptCompatibilityProfileW EncryptInteropLegacyW--{- | High-level encrypt-side helper for public-key recipient encryption.--Returns a complete packet sequence:-@[PKESK ..., SEIPD2 ...]@.--}-buildEncryptedPacketSequence- :: SymmetricAlgorithm- -> AEADAlgorithm- -> Word8- -> RecipientPayloadShape- -> Salt- -> SessionKey- -> [Pkt]- -> B.ByteString- -> Either String [Pkt]-buildEncryptedPacketSequence symalgo aead chunkSize payloadShape salt sessionKey pkesks payload =- first- renderPKESKEncryptError- ( buildEncryptedPacketSequenceWithShape- symalgo- aead- chunkSize- payloadShape- salt- sessionKey- pkesks- payload- )- buildEncryptedPacketSequenceWithShape :: SymmetricAlgorithm -> AEADAlgorithm@@ -1779,7 +1685,7 @@ ++ map SignaturePkt signatures ) ciphertext <-- first PayloadBuildFailure $+ first (PayloadBuildFailure . renderSEIPDv2Failure) $ encryptSEIPDv2Payload symalgo aead@@ -1801,18 +1707,15 @@ -> SessionKey -> B.ByteString -- ^ inner packet block plaintext- -> Either String B.ByteString+ -> Either CipherError B.ByteString encryptSEIPDv1Payload symalgo iv (SessionKey keyBytes) plaintext = let cleartextWithMDC = plaintext <> mdcTrailerForSEIPDv1 iv plaintext- in first- renderCipherError- ( encryptOpenPGPCfbRaw- OpenPGPCFBNoResyncW- symalgo- iv- cleartextWithMDC- keyBytes- )+ in encryptOpenPGPCfbRaw+ OpenPGPCFBNoResyncW+ symalgo+ iv+ cleartextWithMDC+ keyBytes -- | Build a complete RFC 4880-conformant packet sequence using SEIPDv1 (CFB + MDC). buildEncryptedPacketSequenceWithShapeSEIPDv1@@ -1841,7 +1744,7 @@ ++ map SignaturePkt signatures ) ciphertext <-- first PayloadBuildFailure $+ first PayloadBuildFailureCipher $ encryptSEIPDv1Payload symalgo iv@@ -2325,7 +2228,7 @@ sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString kek = deriveX25519Kek ephPublicBytes recipientPublic sharedSecret wrapped <-- first (RecipientKeyWrapFailure X25519)+ first (RecipientKeyWrapFailureCipher X25519) . aesKeyWrapRFC3394 AES128 kek $ unPKESKV6RawSessionMaterial material esk <- encodeV6X25519Esk ephPublicBytes wrapped@@ -2358,7 +2261,7 @@ sharedSecret = BA.convert (C448.dh recipientPub ephSecret) :: B.ByteString kek = deriveX448Kek ephPublicBytes recipientPublic sharedSecret wrapped <-- first (RecipientKeyWrapFailure X448)+ first (RecipientKeyWrapFailureCipher X448) . aesKeyWrapRFC3394 AES256 kek $ unPKESKV6RawSessionMaterial material esk <- encodeV6X448Esk ephPublicBytes wrapped@@ -2387,7 +2290,7 @@ first (RecipientKdfFailure pka) $ deriveECDHKek kdfHA kdfSA sharedSecret kdfParam wrapped <-- first (RecipientKeyWrapFailure pka)+ first (RecipientKeyWrapFailureCipher pka) . aesKeyWrapRFC3394 kdfSA kek $ padToMultipleOf8 (pkeskEncodedSessionMaterial material) esk <- encodeV6EcdhEsk ephemeralBytes wrapped@@ -2417,7 +2320,7 @@ first (RecipientKdfFailure pka) $ deriveECDHKek kdfHA kdfSA sharedSecret kdfParam wrapped <-- first (RecipientKeyWrapFailure pka)+ first (RecipientKeyWrapFailureCipher pka) . aesKeyWrapRFC3394 kdfSA kek $ padToMultipleOf8 (unPKESKV3SessionMaterial material) Right@@ -2541,25 +2444,21 @@ 56 "invalid X448 public key length/prefix: " -edPointBytes :: EdPoint -> B.ByteString-edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x-edPointBytes (NativeEPoint (EPoint x)) = i2osp x- deriveX25519Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString deriveX25519Kek ephemeralPublic recipientPublic sharedSecret = let ikm = ephemeralPublic <> recipientPublic <> sharedSecret- prk = extract @CHAlg.SHA256 B.empty ikm+ prk = extract @CHA.SHA256 B.empty ikm info = "OpenPGP X25519" :: B.ByteString- in expand @CHAlg.SHA256 prk info 16+ in expand @CHA.SHA256 prk info 16 deriveX448Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString deriveX448Kek ephemeralPublic recipientPublic sharedSecret = let ikm = ephemeralPublic <> recipientPublic <> sharedSecret- prk = extract @CHAlg.SHA512 B.empty ikm+ prk = extract @CHA.SHA512 B.empty ikm info = "OpenPGP X448" :: B.ByteString- in expand @CHAlg.SHA512 prk info 32+ in expand @CHA.SHA512 prk info 32 padToMultipleOf8 :: B.ByteString -> B.ByteString padToMultipleOf8 bs@@ -2569,47 +2468,37 @@ rem8 = B.length bs `mod` 8 padLen = if rem8 == 0 then 0 else 8 - rem8 -checksum16 :: B.ByteString -> Word16-checksum16 =- fromIntegral- . B.foldl'- (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer))- 0--checksum16Bytes :: B.ByteString -> B.ByteString-checksum16Bytes bs =- B.pack- [ fromIntegral ((chk `shiftR` 8) .&. 0xff)- , fromIntegral (chk .&. 0xff)- ]- where- chk = checksum16 bs- aesKeyWrapRFC3394 :: SymmetricAlgorithm -> B.ByteString -> B.ByteString- -> Either String B.ByteString+ -> Either CipherError B.ByteString aesKeyWrapRFC3394 sa kek plain = withAESCipher- "ECDH PKESK currently supports AES KEK algorithms only"+ (\err -> CipherInitFailed sa (show err))+ (UnsupportedAlgorithm sa) sa kek wrapWithCipher where wrapWithCipher- :: CCT.BlockCipher cipher => cipher -> Either String B.ByteString+ :: CCT.BlockCipher cipher+ => cipher -> Either CipherError B.ByteString wrapWithCipher cipher = do if B.length plain < 16 || B.length plain `mod` 8 /= 0 then Left- "ECDH key wrap input must be at least 16 octets and a multiple of 8"+ ( CipherOperationFailed+ "ECDH key wrap input must be at least 16 octets and a multiple of 8"+ ) else Right () let rs = chunksOf8 plain if length rs < 2 then Left- "ECDH key wrap input must contain at least two 64-bit blocks"+ ( CipherOperationFailed+ "ECDH key wrap input must contain at least two 64-bit blocks"+ ) else Right () (aFinal, rFinal) <- wrapRounds cipher (B.replicate 8 0xA6) rs Right (aFinal <> B.concat rFinal)@@ -2618,7 +2507,7 @@ => cipher -> B.ByteString -> [B.ByteString]- -> Either String (B.ByteString, [B.ByteString])+ -> Either CipherError (B.ByteString, [B.ByteString]) wrapRounds cipher aInit rsInit = goJ 0 aInit rsInit where n = length rsInit@@ -2639,16 +2528,6 @@ rsNext = (ix (i - 1) .~ lsb) curRs goI (i + 1) aNext rsNext -chunksOf8 :: B.ByteString -> [B.ByteString]-chunksOf8 bs- | B.null bs = []- | otherwise =- let (h, t) = B.splitAt 8 bs- in h : chunksOf8 t--xorBS :: B.ByteString -> B.ByteString -> B.ByteString-xorBS a b = B.pack (B.zipWith xor a b)- encryptSEIPDv1WithSKESK :: MonadRandom m => SymmetricAlgorithm@@ -2656,16 +2535,16 @@ -> Maybe IV -> BL.ByteString -> B.ByteString- -> m (Either String [Pkt])+ -> m (Either SEIPDv2Failure [Pkt]) encryptSEIPDv1WithSKESK symalgo s2k ivOverride passphrase literalPayload = do let eSessionKey = do keyLen <- symKeySize symalgo- first renderS2KError (string2Key s2k keyLen passphrase)+ first SEIPDv2SessionKeyError (string2Key s2k keyLen passphrase) case eSessionKey of Left err -> pure (Left err) Right sessionKeyMaterial -> case first- renderCipherError+ SEIPDv2CipherFailed (withSymmetricCipher symalgo sessionKeyMaterial (pure . blockSize)) of Left err -> pure (Left err) Right ivLength -> do@@ -2677,7 +2556,7 @@ let iv = IV ivBytes let sessionKey = SessionKey sessionKeyMaterial case encryptSEIPDv1Payload symalgo iv sessionKey literalPayload of- Left err -> pure (Left err)+ Left err -> pure (Left (SEIPDv2CipherFailed err)) Right encrypted -> pure ( Right@@ -2698,17 +2577,14 @@ -> S2K -> BL.ByteString -> B.ByteString- -> Either String [Pkt]+ -> Either SEIPDv2Failure [Pkt] encryptSEIPDv2WithSKESK symalgo aead chunkSize salt s2k passphrase literalPayload = do keyLen <- symKeySize symalgo sessionKeyMaterial <-- first renderS2KError (string2Key s2k keyLen passphrase)- (_, nonceSize) <-- aeadModeAndNonceSizeForSEIPDv2- "unsupported AEAD algorithm for SKESK v6 encrypt"- aead+ first SEIPDv2SessionKeyError (string2Key s2k keyLen passphrase)+ (_, nonceSize) <- aeadModeAndNonceSize aead when (B.length (unSalt salt) < nonceSize) $- Left "SEIPD v2 salt is too short to derive the SKESK v6 IV"+ Left SEIPDv2InvalidSaltLength let skeskIV = B.take nonceSize (unSalt salt) kek <- deriveSKESK6KEK symalgo aead sessionKeyMaterial (wrappedSessionKey, skeskTag) <-@@ -2751,7 +2627,7 @@ -> S2K -> BL.ByteString -> Block Pkt- -> Either String [Pkt]+ -> Either SEIPDv2Failure [Pkt] encryptSEIPDv2WithSKESKBlock symalgo aead chunkSize salt s2k passphrase packetBlock = encryptSEIPDv2WithSKESK symalgo@@ -2770,7 +2646,7 @@ -> S2K -> BL.ByteString -> B.ByteString- -> Either String [Pkt]+ -> Either SEIPDv2Failure [Pkt] encryptSEIPDv2LiteralDataWithSKESK symalgo aead chunkSize salt s2k passphrase payload = encryptSEIPDv2WithSKESKBlock symalgo@@ -2795,32 +2671,34 @@ -> Salt -> SessionKey -> B.ByteString- -> Either String B.ByteString+ -> Either SEIPDv2Failure B.ByteString encryptSEIPDv2Payload symalgo aead chunkSize salt (SessionKey sessionKey) plaintext = do (mode, nonceSize) <- aeadModeAndNonceSize aead keyLen <- symKeySize symalgo let outputLen = keyLen + nonceSize - 8 info = B.pack [0xd2, 2, fromFVal symalgo, fromFVal aead, chunkSize]- prk = extract @CHAlg.SHA256 (unSalt salt) sessionKey- okm = expand @CHAlg.SHA256 prk info outputLen :: B.ByteString+ prk = extract @CHA.SHA256 (unSalt salt) sessionKey+ okm = expand @CHA.SHA256 prk info outputLen :: B.ByteString messageKey = B.take keyLen okm noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm) withAESCipher- "SEIPD v2 encrypt currently supports AES-128/192/256 only"+ SEIPDv2CipherInitFailed+ (SEIPDv2UnsupportedSymmetricAlgorithm symalgo) symalgo messageKey- (encryptChunks mode info chunkSize noncePrefix plaintext)+ (encryptChunks aead mode info chunkSize noncePrefix plaintext) encryptChunks :: CCT.BlockCipher cipher- => CCT.AEADMode+ => AEADAlgorithm+ -> CCT.AEADMode -> B.ByteString -> Word8 -> B.ByteString -> B.ByteString -> cipher- -> Either String B.ByteString-encryptChunks mode info chunkSize noncePrefix plaintext cipher = go 0 plaintext [] 0+ -> Either SEIPDv2Failure B.ByteString+encryptChunks aead mode info chunkSize noncePrefix plaintext cipher = go 0 plaintext [] 0 where chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6) go idx remaining acc totalPlain@@ -2828,11 +2706,12 @@ (finalTag, finalCipher) <- if mode == CCT.AEAD_OCB then- encryptWithOCBRFC7253- cipher- (noncePrefix <> encodeWord64be idx)- (info <> encodeWord64be (fromIntegral totalPlain))- B.empty+ first SEIPDv2CipherInitFailed $+ encryptWithOCBRFC7253+ cipher+ (noncePrefix <> encodeWord64be idx)+ (info <> encodeWord64be (fromIntegral totalPlain))+ B.empty else do aead <- initAEAD idx let (tag, out) =@@ -2844,17 +2723,24 @@ Right (tag, out) if B.null finalCipher then return (B.concat (reverse acc) <> authTagToBS finalTag)- else Left "expected empty ciphertext for final SEIPD v2 tag"+ else+ Left+ ( SEIPDv2CipherFailed+ ( CipherOperationFailed+ "expected empty ciphertext for final SEIPD v2 tag"+ )+ ) | otherwise = do let (chunkPlain, rest) = B.splitAt chunkLen remaining (tag, chunkCipher) <- if mode == CCT.AEAD_OCB then- encryptWithOCBRFC7253- cipher- (noncePrefix <> encodeWord64be idx)- info- chunkPlain+ first SEIPDv2CipherInitFailed $+ encryptWithOCBRFC7253+ cipher+ (noncePrefix <> encodeWord64be idx)+ info+ chunkPlain else do aead <- initAEAD idx pure (CCT.aeadSimpleEncrypt aead info chunkPlain 16)@@ -2866,26 +2752,20 @@ (totalPlain + B.length chunkPlain) initAEAD idx =- first show . CE.eitherCryptoError $- CCT.aeadInit mode cipher (noncePrefix <> encodeWord64be idx)+ first SEIPDv2CipherInitFailed+ . CE.eitherCryptoError+ $ CCT.aeadInit mode cipher (noncePrefix <> encodeWord64be idx) aeadModeAndNonceSize- :: AEADAlgorithm -> Either String (CCT.AEADMode, Int)-aeadModeAndNonceSize =- aeadModeAndNonceSizeForSEIPDv2- "unsupported AEAD algorithm for SEIPD v2 encrypt"+ :: AEADAlgorithm -> Either SEIPDv2Failure (CCT.AEADMode, Int)+aeadModeAndNonceSize = aeadModeAndNonceSizeForSEIPDv2 -symKeySize :: SymmetricAlgorithm -> Either String Int-symKeySize =- seipdv2SymmetricKeySize- "unsupported symmetric algorithm for SEIPD v2 encrypt"+symKeySize :: SymmetricAlgorithm -> Either SEIPDv2Failure Int+symKeySize = seipdv2SymmetricKeySize authTagToBS :: CCT.AuthTag -> B.ByteString authTagToBS = BA.convert . CCT.unAuthTag -encodeWord64be :: Word64 -> B.ByteString-encodeWord64be = BL.toStrict . runPut . putWord64be- {- | Compose a complete AEAD-encrypted message with optional literal data and signature. Returns a packet list (SKESK, SEIPD v2, optional signature) ready for serialization. @@ -2904,7 +2784,7 @@ -> BL.ByteString -> B.ByteString -> Maybe [Pkt]- -> Either String [Pkt]+ -> Either SEIPDv2Failure [Pkt] composeMessageWithSEIPDv2 symalgo aead chunkSize salt s2k passphrase payload mSigs = do let packets = case mSigs of Nothing ->
Codec/Encryption/OpenPGP/Expirations.hs view
@@ -25,7 +25,7 @@ ) where import Control.Error.Util (hush)-import Control.Lens ((&), (^.), _1)+import Control.Lens ((&), (^.)) import Data.List (maximumBy) import Data.Maybe (listToMaybe, mapMaybe) import Data.Ord (comparing)@@ -45,9 +45,6 @@ , signatureHashedSubpacketsKnown ) import Codec.Encryption.OpenPGP.Types-import Codec.Encryption.OpenPGP.Types.Internal.Pkt- ( keyPktPKPayload- ) data KeyState = KeyState@@ -75,16 +72,20 @@ (keyPktPKPayload (tk ^. tkPrimaryKey)) relevantSelfSignatures relevantSelfSignatures =- filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkRevs)- ++ filter+ concat+ [ filter (isDirectKeySelfSigFor primaryKey) (tk ^. tkRevs)+ , filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkUIDs))- ++ filter+ , filter (isSelfCertificationFor primaryKey) (concatMap snd (tk ^. tkUAts))+ ] selfCertificationGroups =- map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkUIDs)- ++ map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkUAts)+ concat+ [ map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkUIDs)+ , map (filter (isSelfSignatureFor primaryKey) . snd) (tk ^. tkUAts)+ ] hasAnySelfCertification = any (any isCertificationSig) selfCertificationGroups hasAnyActiveSelfCertification = any (selfCertificationGroupActiveAt ct) selfCertificationGroups
Codec/Encryption/OpenPGP/Internal.hs view
@@ -13,6 +13,11 @@ , issuerFP , emptyPSC , leftPadTo+ , checksum16+ , checksum16Bytes+ , edPointBytes+ , encodeWord64be+ , chunksOf8 , pubkeyToMPIs , multiplicativeInverse , curveoidBSToCurve@@ -22,6 +27,7 @@ , edSigningCurveToCurveoidBS , curve2Curve , curveFromCurve+ , xorBS ) where import Crypto.Number.Serialize (i2osp, os2ip)@@ -29,16 +35,16 @@ import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Types as ECCT import qualified Crypto.PubKey.RSA as RSA-import Data.Bits (testBit)+import Data.Binary.Put (putWord64be, runPut)+import Data.Bits (shiftR, testBit, xor, (.&.)) import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.List (find)-import Data.Word (Word16, Word8)+import Data.Word (Word16, Word64, Word8) import Codec.Encryption.OpenPGP.Ontology ( isIssuerSSP- , isSigCreationTime ) import Codec.Encryption.OpenPGP.Types @@ -79,6 +85,34 @@ | B.length bs >= targetLen = bs | otherwise = B.replicate (targetLen - B.length bs) 0 <> bs +checksum16 :: B.ByteString -> Word16+checksum16 =+ fromIntegral+ . B.foldl'+ (\acc octet -> (acc + fromIntegral octet) .&. (0xffff :: Int))+ (0 :: Int)++checksum16Bytes :: B.ByteString -> B.ByteString+checksum16Bytes bs = B.cons hi (B.singleton lo)+ where+ chk = checksum16 bs+ hi = fromIntegral (chk `shiftR` 8)+ lo = fromIntegral chk++edPointBytes :: EdPoint -> B.ByteString+edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x+edPointBytes (NativeEPoint (EPoint x)) = i2osp x++encodeWord64be :: Word64 -> B.ByteString+encodeWord64be = BL.toStrict . runPut . putWord64be++chunksOf8 :: B.ByteString -> [B.ByteString]+chunksOf8 bs+ | B.null bs = []+ | otherwise =+ let (h, t) = B.splitAt 8 bs+ in h : chunksOf8 t+ issuer :: Pkt -> Maybe EightOctetKeyId issuer pkt = case fromPktIssuerExtractionCase pkt of@@ -256,3 +290,6 @@ | c == ECCT.getCurveByName ECCT.SEC_p256r1 = NISTP256 | c == ECCT.getCurveByName ECCT.SEC_p384r1 = NISTP384 | c == ECCT.getCurveByName ECCT.SEC_p521r1 = NISTP521++xorBS :: B.ByteString -> B.ByteString -> B.ByteString+xorBS a b = B.pack (B.zipWith xor a b)
Codec/Encryption/OpenPGP/Internal/CryptoAES.hs view
@@ -2,36 +2,49 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE PackageImports #-} {-# LANGUAGE RankNTypes #-} module Codec.Encryption.OpenPGP.Internal.CryptoAES- ( withAESCipher- ) where+ ( withAESCipher+ ) where -import Codec.Encryption.OpenPGP.Types-import qualified "crypton" Crypto.Cipher.AES as AES-import qualified "crypton" Crypto.Cipher.Types as CCT import qualified Crypto.Error as CE import Data.Bifunctor (first) import qualified Data.ByteString as B+import qualified "crypton" Crypto.Cipher.AES as AES+import qualified "crypton" Crypto.Cipher.Types as CCT -withAESCipher ::- String- -> SymmetricAlgorithm- -> B.ByteString- -> (forall cipher. CCT.BlockCipher cipher => cipher -> Either String a)- -> Either String a-withAESCipher unsupportedSymmetricError symalgo keyBytes f =- case symalgo of- AES128 ->- first show (CE.eitherCryptoError (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES128)) >>=- f- AES192 ->- first show (CE.eitherCryptoError (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES192)) >>=- f- AES256 ->- first show (CE.eitherCryptoError (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES256)) >>=- f- _ -> Left unsupportedSymmetricError+import Codec.Encryption.OpenPGP.Types++withAESCipher+ :: (CE.CryptoError -> e)+ -> e+ -> SymmetricAlgorithm+ -> B.ByteString+ -> (forall cipher. CCT.BlockCipher cipher => cipher -> Either e a)+ -> Either e a+withAESCipher mkCryptoError unsupportedSymmetricError symalgo keyBytes f =+ case symalgo of+ AES128 ->+ first+ mkCryptoError+ ( CE.eitherCryptoError+ (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES128)+ )+ >>= f+ AES192 ->+ first+ mkCryptoError+ ( CE.eitherCryptoError+ (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES192)+ )+ >>= f+ AES256 ->+ first+ mkCryptoError+ ( CE.eitherCryptoError+ (CCT.cipherInit keyBytes :: CE.CryptoFailable AES.AES256)+ )+ >>= f+ _ -> Left unsupportedSymmetricError
− Codec/Encryption/OpenPGP/Internal/CryptoSEIPDv2.hs
@@ -1,135 +0,0 @@--- CryptoSEIPDv2.hs: OpenPGP (RFC9580) SEIPD-v2 and SKESK-v6 crypto helpers--- Copyright © 2012-2026 Clint Adams--- This software is released under the terms of the Expat license.--- (See the LICENSE file).--{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PackageImports #-}-{-# LANGUAGE TypeApplications #-}--module Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2- ( aeadModeAndNonceSizeForSEIPDv2- , seipdv2SymmetricKeySize- , deriveSKESK6KEK- , encryptSKESK6SessionKey- , decryptSKESK6SessionKey- ) where--import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher)-import Codec.Encryption.OpenPGP.Internal.RFC7253OCB- ( decryptWithOCBRFC7253With- , encryptWithOCBRFC7253- )-import Codec.Encryption.OpenPGP.Types-import qualified "crypton" Crypto.Cipher.Types as CCT-import qualified Crypto.Error as CE-import qualified Crypto.Hash.Algorithms as CHA-import Crypto.KDF.HKDF (expand, extract)-import Data.Bifunctor (first)-import qualified Data.ByteArray as BA-import qualified Data.ByteString as B--aeadModeAndNonceSizeForSEIPDv2 ::- String -> AEADAlgorithm -> Either String (CCT.AEADMode, Int)-aeadModeAndNonceSizeForSEIPDv2 otherAeadError EAX =- Left "EAX is currently unsupported by the crypton AEAD backend"-aeadModeAndNonceSizeForSEIPDv2 otherAeadError OCB = Right (CCT.AEAD_OCB, 15)-aeadModeAndNonceSizeForSEIPDv2 otherAeadError GCM = Right (CCT.AEAD_GCM, 12)-aeadModeAndNonceSizeForSEIPDv2 otherAeadError (OtherAEADAlgo _) = Left otherAeadError--seipdv2SymmetricKeySize :: String -> SymmetricAlgorithm -> Either String Int-seipdv2SymmetricKeySize unsupportedSymmetricError symalgo =- case symalgo of- AES128 -> Right 16- AES192 -> Right 24- AES256 -> Right 32- _ -> Left unsupportedSymmetricError--skeskV6Info :: SymmetricAlgorithm -> AEADAlgorithm -> B.ByteString-skeskV6Info symalgo aead = B.pack [0xc3, 6, fromFVal symalgo, fromFVal aead]--deriveSKESK6KEK ::- SymmetricAlgorithm- -> AEADAlgorithm- -> B.ByteString- -> Either String B.ByteString-deriveSKESK6KEK symalgo aead ikm = do- keyLen <-- seipdv2SymmetricKeySize- "SKESK v6 currently supports AES-128/192/256 only"- symalgo- let prk = extract @CHA.SHA256 B.empty ikm- pure (expand @CHA.SHA256 prk (skeskV6Info symalgo aead) keyLen)--encryptSKESK6SessionKey ::- SymmetricAlgorithm- -> AEADAlgorithm- -> B.ByteString- -> B.ByteString- -> B.ByteString- -> Either String (B.ByteString, B.ByteString)-encryptSKESK6SessionKey symalgo aead kek iv sessionKey = do- (mode, nonceSize) <-- aeadModeAndNonceSizeForSEIPDv2- "unsupported AEAD algorithm for SKESK v6 encrypt"- aead- if B.length iv /= nonceSize- then Left "SKESK v6 IV length does not match AEAD algorithm"- else- withAESCipher- "SKESK v6 encrypt currently supports AES-128/192/256 only"- symalgo- kek- (\cipher ->- if mode == CCT.AEAD_OCB- then do- (tag, ciphertext) <-- encryptWithOCBRFC7253 cipher iv (skeskV6Info symalgo aead) sessionKey- pure (ciphertext, authTagToBS tag)- else do- aeadCtx <- first show . CE.eitherCryptoError $ CCT.aeadInit mode cipher iv- let (tag, ciphertext) =- CCT.aeadSimpleEncrypt aeadCtx (skeskV6Info symalgo aead) sessionKey 16- pure (ciphertext, authTagToBS tag))--decryptSKESK6SessionKey ::- SymmetricAlgorithm- -> AEADAlgorithm- -> B.ByteString- -> B.ByteString- -> B.ByteString- -> B.ByteString- -> Either String B.ByteString-decryptSKESK6SessionKey symalgo aead kek iv ciphertext tag = do- (mode, nonceSize) <-- aeadModeAndNonceSizeForSEIPDv2- "unsupported AEAD algorithm for SKESK v6 decrypt"- aead- if B.length iv /= nonceSize- then Left "SKESK v6 IV length does not match AEAD algorithm"- else- withAESCipher- "SKESK v6 decrypt currently supports AES-128/192/256 only"- symalgo- kek- (\cipher ->- if mode == CCT.AEAD_OCB- then- decryptWithOCBRFC7253With- (\_ _ _ _ _ _ -> "SKESK v6 authentication failed")- cipher- iv- (skeskV6Info symalgo aead)- ciphertext- (mkAuthTag tag)- else do- aeadCtx <- first show . CE.eitherCryptoError $ CCT.aeadInit mode cipher iv- case CCT.aeadSimpleDecrypt aeadCtx (skeskV6Info symalgo aead) ciphertext (mkAuthTag tag) of- Nothing -> Left "SKESK v6 authentication failed"- Just plain -> Right plain)--authTagToBS :: CCT.AuthTag -> B.ByteString-authTagToBS = BA.convert . CCT.unAuthTag--mkAuthTag :: B.ByteString -> CCT.AuthTag-mkAuthTag = CCT.AuthTag . BA.convert
Codec/Encryption/OpenPGP/Internal/RFC7253OCB.hs view
@@ -23,20 +23,21 @@ ) import qualified Data.ByteArray as BA import qualified Data.ByteString as B-import Data.List (foldl') import Data.Word (Word8) import qualified "crypton" Crypto.Cipher.Types as CCT +import Codec.Encryption.OpenPGP.Internal (xorBS)+ encryptWithOCBRFC7253 :: CCT.BlockCipher c => c -> B.ByteString -> B.ByteString -> B.ByteString- -> Either String (CCT.AuthTag, B.ByteString)+ -> Either e (CCT.AuthTag, B.ByteString) encryptWithOCBRFC7253 cipher nonce ad plaintext = do when (B.length nonce > 15 || B.null nonce) $- Left "invalid nonce size for OCB"+ error "invalid nonce size for OCB" offset0 <- ocbOffset0 cipher nonce let zeroBlock = B.replicate 16 0 lStar = CCT.ecbEncrypt cipher zeroBlock@@ -93,19 +94,19 @@ -> B.ByteString -> B.ByteString -> B.ByteString- -> String+ -> e ) -> c -> B.ByteString -> B.ByteString -> B.ByteString -> CCT.AuthTag- -> Either String B.ByteString+ -> Either e B.ByteString decryptWithOCBRFC7253With onAuthFailure cipher nonce ad ciphertext authTag = do when (B.length nonce > 15 || B.null nonce) $- Left "invalid nonce size for OCB"+ error "invalid nonce size for OCB" when (B.length tagBytes /= 16) $- Left "invalid auth tag size for OCB"+ error "invalid auth tag size for OCB" offset0 <- ocbOffset0 cipher nonce let zeroBlock = B.replicate 16 0 lStar = CCT.ecbEncrypt cipher zeroBlock@@ -154,12 +155,12 @@ ocbOffset0 :: CCT.BlockCipher c- => c -> B.ByteString -> Either String B.ByteString+ => c -> B.ByteString -> Either e B.ByteString ocbOffset0 cipher nonce = do let nonceLen = B.length nonce prefixLen = 16 - nonceLen when (prefixLen <= 0) $- Left "invalid nonce size for OCB"+ error "invalid nonce size for OCB" let prefix = B.pack (replicate (prefixLen - 1) 0 <> [1 :: Word8]) nonceBlock = prefix <> nonce bottom = fromIntegral (B.last nonceBlock .&. 0x3f) :: Int@@ -216,9 +217,6 @@ ) ([], 0) (reverse (B.unpack bs))--xorBS :: B.ByteString -> B.ByteString -> B.ByteString-xorBS a b = B.pack (B.zipWith xor a b) ocbBitSlice128 :: B.ByteString -> Int -> B.ByteString ocbBitSlice128 stretch startBit =
Codec/Encryption/OpenPGP/Internal/Whitespace.hs view
@@ -17,23 +17,19 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL-import Data.Foldable (foldl')+import Data.List (mapAccumL) import Data.Word (Word8) canonicalizeLineEndings :: BL.ByteString -> BL.ByteString-canonicalizeLineEndings bs = BL.fromStrict (B.unfoldr step (Nothing, BL.toStrict bs))+canonicalizeLineEndings bs =+ BL.fromChunks $ chunks ++ [flush] where- step (Nothing, rest)- | B.null rest = Nothing- | otherwise =- case B.uncons rest of- Just (0x0d, tail') ->- case B.uncons tail' of- Just (0x0a, tail'') -> Just (0x0d, (Just 0x0a, tail''))- _ -> Just (0x0d, (Just 0x0a, tail'))- Just (0x0a, tail') -> Just (0x0d, (Just 0x0a, tail'))- Just (w, tail') -> Just (w, (Nothing, tail'))- step (Just w, rest) = Just (w, (Nothing, rest))+ (state, chunks) =+ mapAccumL+ canonicalizeLineEndingsChunk+ (CRState False)+ (BL.toChunks bs)+ flush = canonicalizeLineEndingsFlush state -- | State carried between chunks when canonicalizing line endings. data CRState = CRState@@ -43,7 +39,8 @@ {- | Process one strict chunk and return updated state plus emitted bytes. The returned bytes may end with a standalone @\\r@ if the chunk boundary-falls mid-pair; feed it to 'canonicalizeLineEndingsFlush' at the end.+falls mid-pair; feed it to 'canonicalizeLineEndingsFlush' at the end to+preserve it as-is. -} canonicalizeLineEndingsChunk :: CRState@@ -52,28 +49,29 @@ canonicalizeLineEndingsChunk (CRState prevWasCR) chunk | B.null chunk = (CRState False, B.empty) | otherwise =- ( CRState newPrevCR+ ( CRState isPrevCR , BL.toStrict $ BB.toLazyByteString bldr ) where- newPrevCR = B.last chunk == 0x0d+ isPrevCR = B.last chunk == 0x0d bldr = snd $ B.foldl' step (prevWasCR, mempty) chunk- step (prevCR, b) w- | prevCR && w == 0x0a =+ step (hadPrevCR, b) w+ | hadPrevCR && w == 0x0a = (False, b <> BB.word8 0x0d <> BB.word8 0x0a)- | prevCR && w == 0x0d =- (True, b <> BB.word8 0x0d <> BB.word8 0x0a)- | prevCR = (False, b <> BB.word8 0x0d <> BB.word8 w)+ | hadPrevCR && w == 0x0d =+ (True, b <> BB.word8 0x0d)+ | hadPrevCR =+ (False, b <> BB.word8 0x0d <> BB.word8 w) | w == 0x0d = (True, b) | w == 0x0a = (False, b <> BB.word8 0x0d <> BB.word8 0x0a) | otherwise = (False, b <> BB.word8 w) {- | Emit any pending state as final bytes (a trailing standalone @\\r@-becomes @\\r\\n@).+is preserved as-is). -} canonicalizeLineEndingsFlush :: CRState -> B.ByteString-canonicalizeLineEndingsFlush (CRState prevCR)- | prevCR = B.pack [0x0d, 0x0a]+canonicalizeLineEndingsFlush (CRState hadPrevCR)+ | hadPrevCR = B.pack [0x0d] | otherwise = B.empty {- | Strip trailing spaces (0x20) and tabs (0x09) from each line.@@ -132,15 +130,15 @@ crlf :: BB.Builder crlf = BB.word8 0x0d <> BB.word8 0x0a - stepByte (StripWSState prevCR line, bldr) w- | prevCR && w == 0x0a =- (StripWSState False B.empty, bldr <> trimmedLine <> crlf)- | prevCR =+ stepByte (StripWSState pcr line, acc) w+ | pcr && w == 0x0a =+ (StripWSState False B.empty, acc <> trimmedLine <> crlf)+ | pcr = ( StripWSState False (B.singleton w)- , bldr <> trimmedLine <> BB.word8 0x0d+ , acc <> trimmedLine <> BB.word8 0x0d )- | w == 0x0d = (StripWSState True line, bldr)- | otherwise = (StripWSState False (line <> B.singleton w), bldr)+ | w == 0x0d = (StripWSState True line, acc)+ | otherwise = (StripWSState False (line <> B.singleton w), acc) where trimmedLine = BB.byteString $ B.dropWhileEnd isTrailingWhitespace line @@ -149,8 +147,8 @@ -} stripTrailingWhitespacePerLineFlush :: StripWSState -> B.ByteString-stripTrailingWhitespacePerLineFlush (StripWSState prevCR line) =- if prevCR+stripTrailingWhitespacePerLineFlush (StripWSState pcr line) =+ if pcr then BL.toStrict $ BB.toLazyByteString $
Codec/Encryption/OpenPGP/KeyInfo.hs view
@@ -59,7 +59,7 @@ pkalgoAbbrev ECDSA = "ecd" pkalgoAbbrev ForbiddenElgamal = "-eg" pkalgoAbbrev DH = "dh"-pkalgoAbbrev EdDSA = "edd"+pkalgoAbbrev EdDSALegacy = "edd" pkalgoAbbrev BaseTypes.X25519 = "x25" pkalgoAbbrev BaseTypes.X448 = "x448" pkalgoAbbrev BaseTypes.Ed25519 = "e25"
Codec/Encryption/OpenPGP/KeyringParser.hs view
@@ -44,7 +44,6 @@ , brokenWithWireRep -- * Utilities- , parseUnknownTKs , parseTKsEither , parseTKs , parsePublicTKs@@ -398,22 +397,18 @@ isBroken [BrokenPacketPkt _ a _] = t == fromIntegral a isBroken _ = False -{-# DEPRECATED parseUnknownTKs "Use parsePublicTKs or parseSecretTKs instead" #-}---- | parse TKs from packets-parseUnknownTKs :: Bool -> [Pkt] -> [TKUnknown]-parseUnknownTKs intolerant ps =- catMaybes $- runIncrementalParser- (anyTK intolerant)- (map (: []) (filter notTrustPacket ps))- where- notTrustPacket = not . isTrustPkt- parseTKsEither :: Bool -> [Pkt] -> [Either TKConversionError SomeTK]-parseTKsEither intolerant =- map fromUnknownToTKEither . parseUnknownTKs intolerant+parseTKsEither intolerant ps =+ map+ fromUnknownToTKEither+ ( catMaybes $+ runIncrementalParser+ (anyTK intolerant)+ (map (: []) (filter notTrustPacket ps))+ )+ where+ notTrustPacket = not . isTrustPkt parseTKs :: Bool -> [Pkt] -> [SomeTK] parseTKs intolerant packets = rights (parseTKsEither intolerant packets)
Codec/Encryption/OpenPGP/Message.hs view
@@ -34,8 +34,18 @@ , mkEd448SignerV4 , mkEd448SignerV6 , MessageParseFailure (..)+ , renderMessageParseFailure+ , MDCFailure (..)+ , AEADFailure (..)+ , renderAEADFailure+ , PayloadDecryptFailure (..)+ , renderPayloadDecryptFailure , MessageDecryptFailure (..)+ , renderMessageDecryptFailure+ , MessageEncryptFailure (..)+ , renderMessageEncryptFailure , MessageError (..)+ , renderMessageError , SessionMaterialExposure (..) , EncryptMessageProfile , EncryptMessageOptions (..)@@ -52,18 +62,17 @@ import Control.Monad (foldM) import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)-import qualified Crypto.Hash as CH+import Control.Monad.Trans.Except (ExceptT (..), runExceptT) 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.Bifunctor (bimap, first) import Data.Binary (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 Data.Functor.Identity (Identity (..), runIdentity) import Data.Kind (Type) import Data.Word (Word8) @@ -71,31 +80,22 @@ ( CipherError , keySize , renderCipherError- , withSymmetricCipher ) import Codec.Encryption.OpenPGP.CFB ( OpenPGPCFBModeW (..) , decryptOpenPGPCfb , decryptPreservingNonce , encryptOpenPGPCfbRaw- , mdcTrailerForSEIPDv1- , seipdv1NonceFromIV- , validateSEIPD1MDC ) import Codec.Encryption.OpenPGP.Encrypt- ( encryptSEIPDv2WithSKESKBlock+ ( buildOnePassSignature+ , encryptSEIPDv2WithSKESKBlock+ , renderOPSBuildError ) import Codec.Encryption.OpenPGP.Fingerprint ( eightOctetKeyID , fingerprint )-import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2- ( decryptSKESK6SessionKey- , deriveSKESK6KEK- )-import Codec.Encryption.OpenPGP.Internal.HOBlockCipher- ( HOBlockCipher (..)- ) import Codec.Encryption.OpenPGP.Policy ( HashAlgorithmW (..) , OpenPGPPolicy@@ -115,10 +115,23 @@ , skesk2SessionKey , string2Key )+import Codec.Encryption.OpenPGP.SEIPDv1+ ( MDCFailure (..)+ , mdcTrailerForSEIPDv1+ , renderMDCFailure+ , validateSEIPD1MDC+ )+import Codec.Encryption.OpenPGP.SEIPDv2+ ( SEIPDv2Failure (..)+ , decryptSKESK6SessionKey+ , deriveSKESK6KEK+ , renderSEIPDv2Failure+ ) import Codec.Encryption.OpenPGP.Serialize (parsePkts) import Codec.Encryption.OpenPGP.Signatures ( SignError (..) , VerificationError+ , renderSignError , signDataWithEd25519Builder , signDataWithEd25519V6Builder , signDataWithEd448Builder@@ -135,9 +148,6 @@ , sigBuilderInitV6Typed ) import Codec.Encryption.OpenPGP.Types-import Codec.Encryption.OpenPGP.Types.Internal.Base- ( Passphrase (..)- ) import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA import Data.Conduit.OpenPGP.Decrypt (decryptSEIPDv2Payload) import qualified Data.Conduit.OpenPGP.Message as ConduitMessage@@ -238,7 +248,7 @@ mkEd448SignerV6 = Ed448Signer data MessageError- = MessageEncryptError String+ = MessageEncryptFailureError MessageEncryptFailure | MessageDecryptError String | MessageSignError SignError | MessageParseError String@@ -246,38 +256,37 @@ | MessageDecryptFailureError MessageDecryptFailure deriving (Eq, Show) -newtype MessageFlow a- = MessageFlow- { runMessageFlow :: Either MessageError a- }--instance Functor MessageFlow where- fmap f (MessageFlow result) = MessageFlow (fmap f result)--instance Applicative MessageFlow where- pure = MessageFlow . Right- MessageFlow ff <*> MessageFlow fa = MessageFlow (ff <*> fa)--instance Monad MessageFlow where- MessageFlow result >>= f =- case result of- Left err -> MessageFlow (Left err)- Right x -> f x+messageStep+ :: Monad m => Either MessageError a -> ExceptT MessageError m a+messageStep = ExceptT . pure -messageStep :: Either MessageError a -> MessageFlow a-messageStep = MessageFlow+runMessageFlow+ :: ExceptT MessageError Identity a -> Either MessageError a+runMessageFlow = runIdentity . runExceptT type MessageFlowT m = ExceptT MessageError m runMessageFlowT :: MessageFlowT m a -> m (Either MessageError a) runMessageFlowT = runExceptT -liftMessageFlowT :: Monad m => MessageFlow a -> MessageFlowT m a-liftMessageFlowT (MessageFlow result) =- case result of- Left err -> throwE err- Right x -> pure x+signStepT :: Monad m => Either SignError a -> MessageFlowT m a+signStepT = ExceptT . pure . first MessageSignError +parseStep+ :: Monad m+ => Either MessageParseFailure a -> ExceptT MessageError m a+parseStep = messageStep . first MessageParseFailureError++decryptStep+ :: Monad m+ => Either MessageDecryptFailure a -> ExceptT MessageError m a+decryptStep = messageStep . first MessageDecryptFailureError++encryptStep+ :: Monad m+ => Either MessageEncryptFailure a -> ExceptT MessageError m a+encryptStep = messageStep . first MessageEncryptFailureError+ data MessageParseFailure = MissingEncryptedMessage | ExpectedSKESKThenEncryptedData@@ -288,11 +297,33 @@ | BrokenCriticalPacketType Word8 String deriving (Eq, Show) +data AEADFailure+ = AEADChunkAuthFailed AEADAlgorithm Int+ | AEADFinalTagFailed AEADAlgorithm+ | AEADInitFailed CipherError+ deriving (Eq, Show)++data PayloadDecryptFailure+ = PayloadDecryptCipherFailed CipherError+ | PayloadDecryptMDCFailed MDCFailure+ | PayloadDecryptAEADFailed AEADFailure+ | PayloadDecryptSEIPDv2Failed SEIPDv2Failure+ | PayloadDecryptGeneric String+ deriving (Eq, Show)+ data MessageDecryptFailure = SessionMaterialDerivationFailed S2KError- | PayloadDecryptFailed String+ | PayloadDecryptFailed PayloadDecryptFailure deriving (Eq, Show) +data MessageEncryptFailure+ = MessageEncryptSEIPDv2Failed SEIPDv2Failure+ | MessageEncryptCipherFailed CipherError+ | MessageEncryptS2KFailed S2KError+ | MessageEncryptDeprecatedS2KHash HashAlgorithm+ | MessageEncryptUnsupportedSymmetricAlgorithm SymmetricAlgorithm+ deriving (Eq, Show)+ data ParsedEncryptedPayloadKind = LegacySEDPayloadKind | LegacySEIPDv1PayloadKind@@ -355,8 +386,45 @@ renderMessageDecryptFailure :: MessageDecryptFailure -> String renderMessageDecryptFailure (SessionMaterialDerivationFailed err) = renderS2KError err-renderMessageDecryptFailure (PayloadDecryptFailed err) = err+renderMessageDecryptFailure (PayloadDecryptFailed err) = renderPayloadDecryptFailure err +renderMessageEncryptFailure :: MessageEncryptFailure -> String+renderMessageEncryptFailure (MessageEncryptSEIPDv2Failed err) = renderSEIPDv2Failure err+renderMessageEncryptFailure (MessageEncryptCipherFailed err) = renderCipherError err+renderMessageEncryptFailure (MessageEncryptS2KFailed err) = renderS2KError err+renderMessageEncryptFailure (MessageEncryptDeprecatedS2KHash ha) =+ "deprecated hash algorithm disallowed for modern message generation: "+ ++ show ha+renderMessageEncryptFailure (MessageEncryptUnsupportedSymmetricAlgorithm sa) =+ "symmetric algorithm disallowed for RFC9580 message generation: "+ ++ show sa++renderAEADFailure :: AEADFailure -> String+renderAEADFailure (AEADChunkAuthFailed algo chunk) =+ "AEAD chunk authentication failed for "+ ++ show algo+ ++ " at chunk "+ ++ show chunk+renderAEADFailure (AEADFinalTagFailed algo) =+ "AEAD final tag verification failed for " ++ show algo+renderAEADFailure (AEADInitFailed err) =+ "AEAD initialization failed: " ++ renderCipherError err++renderPayloadDecryptFailure :: PayloadDecryptFailure -> String+renderPayloadDecryptFailure (PayloadDecryptCipherFailed err) = renderCipherError err+renderPayloadDecryptFailure (PayloadDecryptMDCFailed err) = renderMDCFailure err+renderPayloadDecryptFailure (PayloadDecryptAEADFailed err) = renderAEADFailure err+renderPayloadDecryptFailure (PayloadDecryptSEIPDv2Failed err) = renderSEIPDv2Failure err+renderPayloadDecryptFailure (PayloadDecryptGeneric err) = err++renderMessageError :: MessageError -> String+renderMessageError (MessageEncryptFailureError err) = renderMessageEncryptFailure err+renderMessageError (MessageDecryptError err) = err+renderMessageError (MessageSignError err) = renderSignError err+renderMessageError (MessageParseError err) = err+renderMessageError (MessageParseFailureError err) = renderMessageParseFailure err+renderMessageError (MessageDecryptFailureError err) = renderMessageDecryptFailure err+ mkEncryptedPayload :: BL.ByteString -> EncryptedPayload mkEncryptedPayload = EncryptedPayload @@ -369,49 +437,31 @@ encryptedPayloadBytes :: EncryptedPayload -> BL.ByteString encryptedPayloadBytes = unEncryptedPayload -firstLeft :: (e -> e') -> Either e a -> Either e' a-firstLeft f = either (Left . f) Right---- | Lift a parse failure step into the unified MessageError channel-parseStep :: Either MessageParseFailure a -> MessageFlow a-parseStep = messageStep . firstLeft MessageParseFailureError---- | Lift a decrypt failure step into the unified MessageError channel-decryptStep :: Either MessageDecryptFailure a -> MessageFlow a-decryptStep = messageStep . firstLeft MessageDecryptFailureError---- | Lift a string encrypt error step into the unified MessageError channel-encryptStep :: Either String a -> MessageFlow a-encryptStep = messageStep . firstLeft MessageEncryptError---- | Lift a sign error step into the unified MessageError channel-signStep :: Either SignError a -> MessageFlow a-signStep = messageStep . firstLeft MessageSignError--signStepT :: Monad m => Either SignError a -> MessageFlowT m a-signStepT = liftMessageFlowT . signStep- signBackendStep :: Either String a -> Either SignError a-signBackendStep = firstLeft SignBackendError+signBackendStep = first SignBackendError decryptSessionStep :: Either S2KError a -> Either MessageDecryptFailure a-decryptSessionStep = firstLeft SessionMaterialDerivationFailed+decryptSessionStep = first SessionMaterialDerivationFailed decryptSessionKeySizeStep :: Either CipherError a -> Either MessageDecryptFailure a decryptSessionKeySizeStep =- firstLeft+ first (SessionMaterialDerivationFailed . S2KUnsupportedAlgorithm) decryptCipherStep :: Either CipherError a -> Either MessageDecryptFailure a-decryptCipherStep = firstLeft (PayloadDecryptFailed . renderCipherError)+decryptCipherStep = first (PayloadDecryptFailed . PayloadDecryptCipherFailed) -decryptPayloadStep- :: Either String a -> Either MessageDecryptFailure a-decryptPayloadStep = firstLeft PayloadDecryptFailed+decryptMDCStep+ :: Either MDCFailure a -> Either MessageDecryptFailure a+decryptMDCStep = first (PayloadDecryptFailed . PayloadDecryptMDCFailed) +decryptSEIPDv2Step+ :: Either SEIPDv2Failure a -> Either MessageDecryptFailure a+decryptSEIPDv2Step = first (PayloadDecryptFailed . PayloadDecryptSEIPDv2Failed)+ encryptMessage :: EncryptMessageOptions p -> Passphrase@@ -433,7 +483,7 @@ encryptStep $ validateRFC9580MessageSymmetric defaultPolicy sa encryptStep $ validateModernMessageS2K defaultPolicy s2k encrypted <-- encryptStep $+ encryptStep . first MessageEncryptSEIPDv2Failed $ encryptSEIPDv2WithSKESKBlock sa (messageDefaultAEADAlgorithm messagePolicy)@@ -464,17 +514,18 @@ | otherwise = ivBytes encryptMessageWithRFC4880Fallback- :: SymmetricAlgorithm+ :: Monad m+ => SymmetricAlgorithm -> S2K -> IV -> Passphrase -> ClearPayload- -> MessageFlow EncryptedPayload+ -> ExceptT MessageError m EncryptedPayload encryptMessageWithRFC4880Fallback sa s2k iv passphrase payload = do keyLen <-- encryptStep . first renderCipherError $ keySize sa+ encryptStep . first MessageEncryptCipherFailed $ keySize sa sessionMaterial <-- encryptStep . first renderS2KError $+ encryptStep . first MessageEncryptS2KFailed $ WrappedSessionMaterial <$> string2Key s2k keyLen (unPassphrase passphrase) let literal =@@ -482,7 +533,7 @@ cleartext = BL.toStrict (runPut (put (Block [literal]))) cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext encrypted <-- encryptStep . first renderCipherError $+ encryptStep . first MessageEncryptCipherFailed $ encryptOpenPGPCfbRaw OpenPGPCFBNoResyncW sa@@ -497,13 +548,15 @@ ] deriveSessionMaterial- :: SymmetricAlgorithm+ :: Monad m+ => SymmetricAlgorithm -> S2K -> Passphrase- -> MessageFlow B.ByteString+ -> ExceptT MessageError m B.ByteString deriveSessionMaterial sa s2k passphrase = do- keyLen <- encryptStep . first renderCipherError $ keySize sa- encryptStep . first renderS2KError $+ keyLen <-+ encryptStep . first MessageEncryptCipherFailed $ keySize sa+ encryptStep . first MessageEncryptS2KFailed $ string2Key s2k keyLen (unPassphrase passphrase) exposedSessionMaterial@@ -532,7 +585,7 @@ payload <- parseStep $ extractEncryptedPayload encryptedPackets cleartext <-- decryptStep $ decryptPayloadTyped passphrase payload+ decryptStep $ decryptPayload passphrase payload clearPackets <- parseStep $ rejectUnknownCriticalPacketsTyped@@ -544,84 +597,108 @@ => Signer alg v -> ClearPayload -> m (Either MessageError BL.ByteString)-signMessageWith signer payload = runMessageFlowT $- case signer of- RSASigner signerPK signingKey ->- case signerPK of- VersionedPKPayloadV4 pk ->- signV4Message- pk- ( \hashed unhashed clear ->- let builder =- sigBuilderInitTyped @'PKA.RSA RFC9580W BinarySig SHA512W- withHashed = addHashedSubs (listToHashedSubs hashed) builder- withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed- in signDataWithRSABuilder withUnhashed signingKey clear- )- payload- VersionedPKPayloadV6 pk ->- signV6Message- pk- ( \salt hashed unhashed clear ->- let builder =- sigBuilderInitV6Typed @'PKA.RSA RFC9580W BinarySig SHA512W salt- withHashed = addHashedSubs (listToHashedSubs hashed) builder- withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed- in signDataWithRSAV6Builder withUnhashed signingKey clear- )- payload- Ed25519Signer signerPK signingKey ->- case signerPK of- VersionedPKPayloadV4 pk ->- signV4Message- pk- ( \hashed unhashed clear ->- let builder =- sigBuilderInitTyped @'PKA.Ed25519 RFC9580W BinarySig SHA512W- withHashed = addHashedSubs (listToHashedSubs hashed) builder- withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed- in signDataWithEd25519Builder withUnhashed signingKey clear- )- payload- VersionedPKPayloadV6 pk ->- signV6Message- pk- ( \salt hashed unhashed clear ->- let builder =- sigBuilderInitV6Typed @'PKA.Ed25519- RFC9580W- BinarySig- SHA512W- salt- withHashed = addHashedSubs (listToHashedSubs hashed) builder- withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed- in signDataWithEd25519V6Builder withUnhashed signingKey clear- )- payload- Ed448Signer signerPK signingKey ->- case signerPK of- VersionedPKPayloadV4 pk ->- signV4Message- pk- ( \hashed unhashed clear ->- let builder =- sigBuilderInitTyped @'PKA.Ed448 RFC9580W BinarySig SHA512W- withHashed = addHashedSubs (listToHashedSubs hashed) builder- withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed- in signDataWithEd448Builder withUnhashed signingKey clear- )- payload- VersionedPKPayloadV6 pk ->- signV6Message- pk- ( \salt hashed unhashed clear ->- let builder =- sigBuilderInitV6Typed @'PKA.Ed448 RFC9580W BinarySig SHA512W salt- withHashed = addHashedSubs (listToHashedSubs hashed) builder- withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed- in signDataWithEd448V6Builder withUnhashed signingKey clear- )- payload+signMessageWith signer payload =+ runMessageFlowT $+ let applySubs builder hashed unhashed =+ addUnhashedSubs+ (listToUnhashedSubs unhashed)+ (addHashedSubs (listToHashedSubs hashed) builder)+ in case signer of+ RSASigner signerPK signingKey ->+ case signerPK of+ VersionedPKPayloadV4 pk ->+ signV4Message+ pk+ ( \hashed unhashed clear ->+ signDataWithRSABuilder+ ( applySubs+ (sigBuilderInitTyped @'PKA.RSA RFC9580W BinarySig SHA512W)+ hashed+ unhashed+ )+ signingKey+ clear+ )+ payload+ VersionedPKPayloadV6 pk ->+ signV6Message+ pk+ ( \salt hashed unhashed clear ->+ signDataWithRSAV6Builder+ ( applySubs+ (sigBuilderInitV6Typed @'PKA.RSA RFC9580W BinarySig SHA512W salt)+ hashed+ unhashed+ )+ signingKey+ clear+ )+ payload+ Ed25519Signer signerPK signingKey ->+ case signerPK of+ VersionedPKPayloadV4 pk ->+ signV4Message+ pk+ ( \hashed unhashed clear ->+ signDataWithEd25519Builder+ ( applySubs+ (sigBuilderInitTyped @'PKA.Ed25519 RFC9580W BinarySig SHA512W)+ hashed+ unhashed+ )+ signingKey+ clear+ )+ payload+ VersionedPKPayloadV6 pk ->+ signV6Message+ pk+ ( \salt hashed unhashed clear ->+ signDataWithEd25519V6Builder+ ( applySubs+ ( sigBuilderInitV6Typed @'PKA.Ed25519+ RFC9580W+ BinarySig+ SHA512W+ salt+ )+ hashed+ unhashed+ )+ signingKey+ clear+ )+ payload+ Ed448Signer signerPK signingKey ->+ case signerPK of+ VersionedPKPayloadV4 pk ->+ signV4Message+ pk+ ( \hashed unhashed clear ->+ signDataWithEd448Builder+ ( applySubs+ (sigBuilderInitTyped @'PKA.Ed448 RFC9580W BinarySig SHA512W)+ hashed+ unhashed+ )+ signingKey+ clear+ )+ payload+ VersionedPKPayloadV6 pk ->+ signV6Message+ pk+ ( \salt hashed unhashed clear ->+ signDataWithEd448V6Builder+ ( applySubs+ (sigBuilderInitV6Typed @'PKA.Ed448 RFC9580W BinarySig SHA512W salt)+ hashed+ unhashed+ )+ signingKey+ clear+ )+ payload signMessage :: (MonadRandom m, SigningCapability alg v)@@ -630,10 +707,6 @@ -> m (Either MessageError BL.ByteString) signMessage signer = signMessageWith signer . mkClearPayload -versionedPKPayload :: VersionedPKPayload v -> PKPayload v-versionedPKPayload (VersionedPKPayloadV4 pk) = pk-versionedPKPayload (VersionedPKPayloadV6 pk) = pk- verifySignedMessage :: ConduitMessage.VerificationOptions -> PublicKeyring@@ -732,16 +805,13 @@ let clear = unClearPayload payload literal = LiteralDataPkt BinaryData BL.empty 0 clear signature <- signingFn hashed unhashed clear- return . runPut . put $ Block [literal, SignaturePkt signature]--encryptOpenPGPCfb- :: SymmetricAlgorithm- -> IV- -> B.ByteString- -> WrappedSessionMaterial- -> Either CipherError B.ByteString-encryptOpenPGPCfb sa iv cleartext (WrappedSessionMaterial keydata) =- encryptOpenPGPCfbRaw OpenPGPCFBResyncW sa iv cleartext keydata+ let sigPkt = SignaturePkt signature+ bimap+ (SignBackendError . renderOPSBuildError)+ ( \ops ->+ runPut . put $ Block [OnePassSignaturePkt ops, literal, sigPkt]+ )+ (buildOnePassSignature False signature) extractEncryptedPayload :: [Pkt] -> Either MessageParseFailure SomeParsedEncryptedPayload@@ -840,7 +910,7 @@ (BL.toStrict payload) ) )-toSEIPDv2Prelude (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) payloadSA aead chunkSize salt payload+toSEIPDv2Prelude (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) payloadSA _aead chunkSize salt payload | sa /= payloadSA = Left SKESKSEIPDAlgorithmMismatch | otherwise = Right@@ -926,16 +996,8 @@ decryptPayload :: Passphrase -> SomeParsedEncryptedPayload- -> Either String ClearPayload-decryptPayload passphrase =- first renderMessageDecryptFailure- . decryptPayloadTyped passphrase--decryptPayloadTyped- :: Passphrase- -> SomeParsedEncryptedPayload -> Either MessageDecryptFailure ClearPayload-decryptPayloadTyped passphrase (SomeParsedEncryptedPayload payload) =+decryptPayload passphrase (SomeParsedEncryptedPayload payload) = case payload of LegacySEDPayload skesk encryptedPayload -> decryptLegacySEDPayloadTyped passphrase skesk encryptedPayload@@ -983,7 +1045,7 @@ decryptCipherStep $ decryptPreservingNonce sessionAlgorithm payload sessionKeyBytes cleartext <-- decryptPayloadStep $ validateSEIPD1MDC nonce decrypted+ decryptMDCStep $ validateSEIPD1MDC nonce decrypted Right (ClearPayload (BL.fromStrict cleartext)) decryptSEIPDv2PayloadTyped@@ -998,7 +1060,7 @@ decryptSEIPDv2PayloadTyped passphrase sa aead chunkSize salt skeskInfo payload = do sessionKey <- SessionKey <$> deriveSEIPDv2SessionKeyBytes passphrase skeskInfo- decryptPayloadStep $+ decryptSEIPDv2Step $ ClearPayload . BL.fromStrict <$> decryptSEIPDv2Payload sa aead chunkSize salt payload sessionKey @@ -1010,8 +1072,8 @@ deriveSessionKeyBytes passphrase sa s2k deriveSEIPDv2SessionKeyBytes passphrase (SEIPDv2SKESK6 sa aead s2k iv esk tag) = do ikm <- deriveSessionKeyBytes passphrase sa s2k- kek <- decryptPayloadStep $ deriveSKESK6KEK sa aead ikm- decryptPayloadStep $+ kek <- decryptSEIPDv2Step $ deriveSKESK6KEK sa aead ikm+ decryptSEIPDv2Step $ decryptSKESK6SessionKey sa aead@@ -1049,27 +1111,24 @@ _ -> Right (pkt : acc) validateModernMessageS2K- :: OpenPGPPolicy -> S2K -> Either String ()+ :: OpenPGPPolicy -> S2K -> Either MessageEncryptFailure () validateModernMessageS2K policy s2k = case s2kHashAlgorithm s2k of Just ha | ha `elem` deprecatedHashAlgorithms (policyGenerationDeprecations policy) ->- Left- ( "deprecated hash algorithm disallowed for modern message generation: "- ++ show ha- )+ Left (MessageEncryptDeprecatedS2KHash ha) _ -> Right () validateRFC9580MessageSymmetric- :: OpenPGPPolicy -> SymmetricAlgorithm -> Either String ()+ :: OpenPGPPolicy+ -> SymmetricAlgorithm+ -> Either MessageEncryptFailure () validateRFC9580MessageSymmetric policy sa | supportsSEIPDv2Symmetric policy sa = Right () | otherwise = Left- ( "symmetric algorithm disallowed for RFC9580 message generation: "- ++ show sa- )+ (MessageEncryptUnsupportedSymmetricAlgorithm sa) s2kHashAlgorithm :: S2K -> Maybe HashAlgorithm s2kHashAlgorithm (Simple ha) = Just ha
Codec/Encryption/OpenPGP/Policy.hs view
@@ -64,13 +64,12 @@ ) where import qualified Crypto.Hash as CH-import qualified Crypto.Hash.Algorithms as CHAlg+import qualified Crypto.Hash.Algorithms as CHA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Types as ECCT import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.Kind (Constraint)-import Data.List (elem) import Data.Word (Word8) import GHC.TypeLits (ErrorMessage (..), TypeError) @@ -535,12 +534,12 @@ ecdhKdfHashDigest :: HashAlgorithm -> B.ByteString -> Either String B.ByteString ecdhKdfHashDigest SHA1 _ = Left "ECDH KDF hash algorithm SHA1 is disallowed by policy"-ecdhKdfHashDigest SHA224 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA224))-ecdhKdfHashDigest SHA256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA256))-ecdhKdfHashDigest SHA384 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA384))-ecdhKdfHashDigest SHA512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA512))-ecdhKdfHashDigest SHA3_256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA3_256))-ecdhKdfHashDigest SHA3_512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA3_512))+ecdhKdfHashDigest SHA224 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA224))+ecdhKdfHashDigest SHA256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA256))+ecdhKdfHashDigest SHA384 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA384))+ecdhKdfHashDigest SHA512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA512))+ecdhKdfHashDigest SHA3_256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA3_256))+ecdhKdfHashDigest SHA3_512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHA.SHA3_512)) ecdhKdfHashDigest _ _ = Left "ECDH KDF hash algorithm is unsupported" validateTable30PolicyForRecipient
+ Codec/Encryption/OpenPGP/SEIPDv1.hs view
@@ -0,0 +1,87 @@+-- SEIPDv1.hs: OpenPGP (RFC9580) legacy MDC/SEIPDv1+-- Copyright © 2026 Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}++module Codec.Encryption.OpenPGP.SEIPDv1+ ( MDCFailure (..)+ , mdcTrailerForSEIPDv1+ , renderMDCFailure+ , seipdv1NonceFromIV+ , validateSEIPD1MDC+ , calculateMDC+ ) where++import Control.Error.Util (note)+import Control.Monad (when)+import qualified Crypto.Hash as CH+import qualified Crypto.Hash.Algorithms as CHA+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++import Codec.Encryption.OpenPGP.Types++{- | Compute the MDC trailer appended to SEIPDv1 plaintext before encryption.+The trailer is: @0xd3 0x14 SHA1(nonce || plaintext || 0xd3 0x14)@.+-}+mdcTrailerForSEIPDv1 :: IV -> B.ByteString -> B.ByteString+mdcTrailerForSEIPDv1 iv plaintext = mdcHeader <> digest+ where+ mdcHeader = B.pack [0xd3, 0x14]+ nonce = seipdv1NonceFromIV iv+ digest =+ BA.convert+ (CH.hash (nonce <> plaintext <> mdcHeader) :: CH.Digest CHA.SHA1)++-- | The SEIPDv1 nonce: the IV bytes followed by its last two bytes (resync prefix).+seipdv1NonceFromIV :: IV -> B.ByteString+seipdv1NonceFromIV (IV ivBytes) = ivBytes <> B.drop (B.length ivBytes - 2) ivBytes++calculateMDC+ :: B.ByteString -> B.ByteString -> Maybe BL.ByteString+calculateMDC nonce garbage+ | B.length garbage < 23 = Nothing+ | otherwise =+ let digest =+ CH.hash+ ( nonce+ <> B.take (B.length garbage - 22) garbage+ <> B.pack [211, 20]+ )+ :: CH.Digest CHA.SHA1+ in Just (BL.fromStrict (BA.convert digest :: B.ByteString))++data MDCFailure+ = MDCTrailerMissing+ | MDCTrailerCorrupted+ | MDCDigestMismatch+ deriving (Eq, Show)++renderMDCFailure :: MDCFailure -> String+renderMDCFailure MDCTrailerMissing = "MDC trailer missing"+renderMDCFailure MDCTrailerCorrupted = "MDC trailer corrupted"+renderMDCFailure MDCDigestMismatch = "MDC digest mismatch"++{- | Verify the MDC trailer of a decrypted SEIPDv1 payload.+Takes the CFB nonce (blockSize+2 prefix bytes retained from decryption)+and the full decrypted bytes (payload + MDC packet), and returns the+payload without the MDC trailer on success.+-}+validateSEIPD1MDC+ :: B.ByteString -> B.ByteString -> Either MDCFailure B.ByteString+validateSEIPD1MDC nonce decrypted = do+ when (B.length decrypted < 22) $+ Left MDCTrailerMissing+ let (payload, trailer) = B.splitAt (B.length decrypted - 22) decrypted+ when (B.take 2 trailer /= B.pack [211, 20]) $+ Left MDCTrailerCorrupted+ expectedMdc <-+ note MDCTrailerMissing (calculateMDC nonce decrypted)+ let actualMdc = BL.fromStrict (B.drop 2 trailer)+ when (expectedMdc /= actualMdc) $+ Left MDCDigestMismatch+ Right payload
+ Codec/Encryption/OpenPGP/SEIPDv2.hs view
@@ -0,0 +1,212 @@+-- SEIPDv2.hs: OpenPGP (RFC9580) SEIPDv2 and SKESK v6 crypto helpers+-- Copyright © 2012-2026 Clint Adams+-- This software is released under the terms of the Expat license.+-- (See the LICENSE file).+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeApplications #-}++module Codec.Encryption.OpenPGP.SEIPDv2+ ( SEIPDv2Failure (..)+ , aeadModeAndNonceSizeForSEIPDv2+ , seipdv2SymmetricKeySize+ , deriveSKESK6KEK+ , encryptSKESK6SessionKey+ , decryptSKESK6SessionKey+ , renderSEIPDv2Failure+ ) where++import Control.Error.Util (note)+import qualified Crypto.Error as CE+import qualified Crypto.Hash.Algorithms as CHA+import Crypto.KDF.HKDF (expand, extract)+import Data.Bifunctor (first)+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified "crypton" Crypto.Cipher.Types as CCT++import Codec.Encryption.OpenPGP.BlockCipher+ ( CipherError (..)+ , renderCipherError+ )+import Codec.Encryption.OpenPGP.Internal.CryptoAES+ ( withAESCipher+ )+import Codec.Encryption.OpenPGP.Internal.RFC7253OCB+ ( decryptWithOCBRFC7253With+ , encryptWithOCBRFC7253+ )+import Codec.Encryption.OpenPGP.S2K (S2KError, renderS2KError)+import Codec.Encryption.OpenPGP.Types++data SEIPDv2Failure+ = SEIPDv2UnsupportedAEADAlgorithm AEADAlgorithm+ | SEIPDv2UnsupportedSymmetricAlgorithm SymmetricAlgorithm+ | SEIPDv2InvalidSaltLength+ | SEIPDv2InvalidIVLength+ | SEIPDv2InvalidChunkSize+ | SEIPDv2CiphertextTooShort+ | SEIPDv2MalformedChunkLengths+ | SEIPDv2MissingFinalTag+ | SEIPDv2ChunkAuthFailed AEADAlgorithm Int+ | SEIPDv2FinalTagFailed AEADAlgorithm+ | SEIPDv2AuthFailed+ | SEIPDv2CipherInitFailed CE.CryptoError+ | SEIPDv2CipherFailed CipherError+ | SEIPDv2SessionKeyError S2KError+ deriving (Eq, Show)++renderSEIPDv2Failure :: SEIPDv2Failure -> String+renderSEIPDv2Failure (SEIPDv2UnsupportedAEADAlgorithm EAX) =+ "EAX is currently unsupported by the crypton AEAD backend"+renderSEIPDv2Failure (SEIPDv2UnsupportedAEADAlgorithm alg) =+ "unsupported AEAD algorithm: " ++ show alg+renderSEIPDv2Failure (SEIPDv2UnsupportedSymmetricAlgorithm _) =+ "SEIPD v2 encrypt currently supports AES-128/192/256 only"+renderSEIPDv2Failure SEIPDv2InvalidSaltLength =+ "SEIPD v2 salt must be exactly 32 octets"+renderSEIPDv2Failure SEIPDv2InvalidIVLength =+ "SKESK v6 IV length does not match AEAD algorithm"+renderSEIPDv2Failure SEIPDv2InvalidChunkSize =+ "SEIPD v2 chunk size octet must be between 0 and 16"+renderSEIPDv2Failure SEIPDv2CiphertextTooShort =+ "SEIPD v2 ciphertext must include at least one chunk tag and a final tag"+renderSEIPDv2Failure SEIPDv2MalformedChunkLengths =+ "SEIPD v2 malformed chunk lengths"+renderSEIPDv2Failure SEIPDv2MissingFinalTag =+ "SEIPD v2 missing final authentication tag"+renderSEIPDv2Failure (SEIPDv2ChunkAuthFailed algo chunk) =+ "AEAD chunk authentication failed for "+ ++ show algo+ ++ " at chunk "+ ++ show chunk+renderSEIPDv2Failure (SEIPDv2FinalTagFailed algo) =+ "AEAD final tag verification failed for " ++ show algo+renderSEIPDv2Failure SEIPDv2AuthFailed =+ "SKESK v6 authentication failed"+renderSEIPDv2Failure (SEIPDv2CipherInitFailed err) =+ "AEAD initialization failed: " ++ show err+renderSEIPDv2Failure (SEIPDv2CipherFailed err) =+ "AEAD/cipher operation failed: " ++ renderCipherError err+renderSEIPDv2Failure (SEIPDv2SessionKeyError err) =+ renderS2KError err++aeadModeAndNonceSizeForSEIPDv2+ :: AEADAlgorithm -> Either SEIPDv2Failure (CCT.AEADMode, Int)+aeadModeAndNonceSizeForSEIPDv2 EAX =+ Left $ SEIPDv2UnsupportedAEADAlgorithm EAX+aeadModeAndNonceSizeForSEIPDv2 OCB = Right (CCT.AEAD_OCB, 15)+aeadModeAndNonceSizeForSEIPDv2 GCM = Right (CCT.AEAD_GCM, 12)+aeadModeAndNonceSizeForSEIPDv2 (OtherAEADAlgo _) =+ Left . SEIPDv2UnsupportedAEADAlgorithm $ OtherAEADAlgo 0++seipdv2SymmetricKeySize+ :: SymmetricAlgorithm -> Either SEIPDv2Failure Int+seipdv2SymmetricKeySize symalgo =+ case symalgo of+ AES128 -> Right 16+ AES192 -> Right 24+ AES256 -> Right 32+ _ -> Left $ SEIPDv2UnsupportedSymmetricAlgorithm symalgo++skeskV6Info+ :: SymmetricAlgorithm -> AEADAlgorithm -> B.ByteString+skeskV6Info symalgo aead = B.pack [0xc3, 6, fromFVal symalgo, fromFVal aead]++deriveSKESK6KEK+ :: SymmetricAlgorithm+ -> AEADAlgorithm+ -> B.ByteString+ -> Either SEIPDv2Failure B.ByteString+deriveSKESK6KEK symalgo aead ikm = do+ keyLen <- seipdv2SymmetricKeySize symalgo+ let prk = extract @CHA.SHA256 B.empty ikm+ pure (expand @CHA.SHA256 prk (skeskV6Info symalgo aead) keyLen)++encryptSKESK6SessionKey+ :: SymmetricAlgorithm+ -> AEADAlgorithm+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString+ -> Either SEIPDv2Failure (B.ByteString, B.ByteString)+encryptSKESK6SessionKey symalgo aead kek iv sessionKey = do+ (mode, nonceSize) <- aeadModeAndNonceSizeForSEIPDv2 aead+ if B.length iv /= nonceSize+ then Left SEIPDv2InvalidIVLength+ else+ withAESCipher+ SEIPDv2CipherInitFailed+ (SEIPDv2UnsupportedSymmetricAlgorithm symalgo)+ symalgo+ kek+ ( \cipher ->+ if mode == CCT.AEAD_OCB+ then do+ (tag, ciphertext) <-+ encryptWithOCBRFC7253+ cipher+ iv+ (skeskV6Info symalgo aead)+ sessionKey+ pure (ciphertext, authTagToBS tag)+ else do+ aeadCtx <-+ first SEIPDv2CipherInitFailed . CE.eitherCryptoError $+ CCT.aeadInit mode cipher iv+ let (tag, ciphertext) =+ CCT.aeadSimpleEncrypt+ aeadCtx+ (skeskV6Info symalgo aead)+ sessionKey+ 16+ pure (ciphertext, authTagToBS tag)+ )++decryptSKESK6SessionKey+ :: SymmetricAlgorithm+ -> AEADAlgorithm+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString+ -> B.ByteString+ -> Either SEIPDv2Failure B.ByteString+decryptSKESK6SessionKey symalgo aead kek iv ciphertext tag = do+ (mode, nonceSize) <- aeadModeAndNonceSizeForSEIPDv2 aead+ if B.length iv /= nonceSize+ then Left SEIPDv2InvalidIVLength+ else+ withAESCipher+ SEIPDv2CipherInitFailed+ (SEIPDv2UnsupportedSymmetricAlgorithm symalgo)+ symalgo+ kek+ ( \cipher ->+ if mode == CCT.AEAD_OCB+ then+ decryptWithOCBRFC7253With+ (\_ _ _ _ _ _ -> SEIPDv2AuthFailed)+ cipher+ iv+ (skeskV6Info symalgo aead)+ ciphertext+ (mkAuthTag tag)+ else do+ aeadCtx <-+ first SEIPDv2CipherInitFailed . CE.eitherCryptoError $+ CCT.aeadInit mode cipher iv+ note+ SEIPDv2AuthFailed+ ( CCT.aeadSimpleDecrypt+ aeadCtx+ (skeskV6Info symalgo aead)+ ciphertext+ (mkAuthTag tag)+ )+ )++authTagToBS :: CCT.AuthTag -> B.ByteString+authTagToBS = BA.convert . CCT.unAuthTag++mkAuthTag :: B.ByteString -> CCT.AuthTag+mkAuthTag = CCT.AuthTag . BA.convert
Codec/Encryption/OpenPGP/SecretKey.hs view
@@ -9,7 +9,6 @@ module Codec.Encryption.OpenPGP.SecretKey ( decryptPrivateKey- , reinterpretUnknownSKeyForPKPayload , mkUnencryptedSKAddendum , encryptPrivateKeyWithPolicyAndSaltAndIV , encryptPrivateKey@@ -18,6 +17,7 @@ , reencryptSecretKeyRandomEither , reencryptPrivateKeyTyped , SecretKeyError (..)+ , renderSecretKeyError , SecretKeyEncryptOptions (..) , decryptSecretKey , decryptSecretKeyAddendum@@ -28,11 +28,11 @@ , changeSecretKeyPassphrase ) where +import Control.Error.Util (note) import Control.Monad (when) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except- ( ExceptT- , except+ ( except , runExceptT , throwE )@@ -54,8 +54,7 @@ , runGetOrFail ) import Data.Binary.Put- ( Put- , putByteString+ ( putByteString , putLazyByteString , putWord16be , runPut@@ -65,7 +64,7 @@ import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL-import Data.List (nub)+import Data.Containers.ListUtils (nubOrd) import Data.Word (Word16, Word8) import qualified "crypton" Crypto.Cipher.Types as CCT @@ -107,9 +106,6 @@ , putSKeyForPKPayload ) import Codec.Encryption.OpenPGP.Types-import Codec.Encryption.OpenPGP.Types.Internal.Base- ( Passphrase (..)- ) data SecretKeyError = SecretKeyDecryptError String@@ -118,6 +114,13 @@ | SecretKeyUnsupportedLegacyProtection deriving (Eq, Show) +renderSecretKeyError :: SecretKeyError -> String+renderSecretKeyError (SecretKeyDecryptError err) = err+renderSecretKeyError (SecretKeyEncryptError err) = err+renderSecretKeyError (SecretKeyPolicyError err) = err+renderSecretKeyError SecretKeyUnsupportedLegacyProtection =+ "unsupported legacy secret key protection"+ data SecretKeyEncryptOptions = SecretKeyEncryptOptions { skeoPolicy :: OpenPGPPolicy , skeoGenerateSaltAndIV :: Bool@@ -141,8 +144,9 @@ decryptSecretKeyAddendum (_secretKeyPKPayload sk) (_secretKeySKAddendum sk)- pp >>= \(skey, _) ->- Right skey+ pp+ >>= \(skey, _) ->+ Right skey decryptSecretKeyAddendum :: SomePKPayload@@ -274,18 +278,19 @@ reencryptWithPolicyAndSaltAndIV pkp originalSka salt iv skey pp policy = first SecretKeyEncryptError- (fromSKAddendumForPKPayload pkp originalSka) >>= \case- SomeSKAddendumV skaV ->- first SecretKeyEncryptError $- toSKAddendum- <$> reencryptPrivateKeyTypedWithPolicy- policy- pkp- skaV- salt- iv- skey- pp+ (fromSKAddendumForPKPayload pkp originalSka)+ >>= \case+ SomeSKAddendumV skaV ->+ first SecretKeyEncryptError $+ toSKAddendum+ <$> reencryptPrivateKeyTypedWithPolicy+ policy+ pkp+ skaV+ salt+ iv+ skey+ pp reencryptSecretKeyRandom :: MonadRandom m@@ -399,26 +404,6 @@ decryptPrivateKeyTyped _ ska@(SKAUnencryptedLegacy {}) _ = Right ska decryptPrivateKeyTyped _ ska@(SKAUnencryptedV6 {}) _ = Right ska -reinterpretUnknownSKeyForPKPayload- :: SomePKPayload -> SKey -> Either String SKey-reinterpretUnknownSKeyForPKPayload _ sk@RSAPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@DSAPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@ElGamalPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@ECDHPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@ECDSAPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@EdDSAPrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@X25519PrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload _ sk@X448PrivateKey {} = Right sk-reinterpretUnknownSKeyForPKPayload pkp (UnknownSKey payload) =- case runGetOrFail- ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString)- payload of- Left (_, _, err) -> Left err- Right (_, _, (skey, trailing))- | BL.null trailing -> Right skey- | otherwise ->- Left "decoded secret key material has trailing bytes"- mkUnencryptedSKAddendum :: SomePKPayload -> SKey -> Either String SKAddendum mkUnencryptedSKAddendum pkp skey = do@@ -509,14 +494,14 @@ let keyCandidates = [keyMaterial] tagCandidates = [0xC5, 0xC7, 0x94, 0x95, 0x96, 0x97, 0x9C, 0x9D, 0x9E, 0x9F] infoCandidates =- nub+ nubOrd [ B.pack [tag, keyVersionByte (_keyVersion pkp), fromFVal sa, fromFVal aa] | tag <- tagCandidates ] pkpBytes = BL.toStrict (runPut (put pkp)) adCandidates =- nub+ nubOrd [B.cons tagByte pkpBytes | tagByte <- tagCandidates] aaCandidates = [aa] nonce = unIV iv@@ -529,7 +514,7 @@ authTag = CCT.AuthTag (BA.convert tagBytes) prk = extract @CHA.SHA256 B.empty candidateKeyMaterial kekCandidates =- nub+ nubOrd [ B.take keyLen candidateKeyMaterial , (expand @CHA.SHA256 prk info keyLen :: B.ByteString) , (expand @CHA.SHA256 prk B.empty keyLen :: B.ByteString)@@ -601,6 +586,7 @@ case aa of OCB -> withAESCipher+ show unsupportedSecretKeyAEADError sa kek@@ -618,14 +604,14 @@ expectedNonceLen <- aeadNonceSize aa when (B.length nonce /= expectedNonceLen) $ Left "invalid nonce size for v6 AEAD secret key payload"- withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher ->+ withAESCipher show unsupportedSecretKeyAEADError sa kek $ \cipher -> first show- (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead ->- maybe- (Left "failed to authenticate v6 AEAD secret key payload")- Right- (CCT.aeadSimpleDecrypt aead ad ciphertext authTag)+ (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))+ >>= \aead ->+ note+ "failed to authenticate v6 AEAD secret key payload"+ (CCT.aeadSimpleDecrypt aead ad ciphertext authTag) aeadMode :: AEADAlgorithm -> Either String CCT.AEADMode aeadMode EAX = Right CCT.AEAD_EAX@@ -775,6 +761,10 @@ Right (runPut (put (MPI d))) EdDSAPrivateKey _ bs -> Right (runPut (put (MPI (os2ip bs))))+ Ed25519PrivateKey bs ->+ Right (runPut (putByteString bs))+ Ed448PrivateKey bs ->+ Right (runPut (putByteString bs)) X25519PrivateKey bs -> Right (runPut (putByteString bs)) X448PrivateKey bs ->@@ -883,17 +873,19 @@ case aa of OCB -> withAESCipher+ show unsupportedSecretKeyAEADError sa kek (\cipher -> encryptWithOCBRFC7253 cipher nonce ad plaintext) _ -> do mode <- aeadMode aa- withAESCipher unsupportedSecretKeyAEADError sa kek $ \cipher ->+ withAESCipher show unsupportedSecretKeyAEADError sa kek $ \cipher -> first show- (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce)) >>= \aead ->- pure (CCT.aeadSimpleEncrypt aead ad plaintext 16)+ (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))+ >>= \aead ->+ pure (CCT.aeadSimpleEncrypt aead ad plaintext 16) {-# DEPRECATED reencryptSecretKeyRandomEither@@ -1014,11 +1006,9 @@ -> BL.ByteString -> Either String SKAddendum reencryptPrivateKeyWithSaltAndIV pkp originalSka salt iv skey pp =- case fromSKAddendumForPKPayload pkp originalSka of- Left err -> Left err- Right (SomeSKAddendumV skaV) ->- toSKAddendum- <$> reencryptPrivateKeyTyped pkp skaV salt iv skey pp+ fromSKAddendumForPKPayload pkp originalSka >>= \(SomeSKAddendumV skaV) ->+ toSKAddendum+ <$> reencryptPrivateKeyTyped pkp skaV salt iv skey pp reencryptS2KProtectedSecretKey :: SomePKPayload@@ -1043,70 +1033,6 @@ first renderS2KError (string2Key retargetedS2K keyLen pp) cleartext <- legacySecretKeyPayload pkp skey encryptFn sa retargetedS2K iv cleartext keyMaterial--encryptLegacyCFBSecretKey- :: SomePKPayload- -> SymmetricAlgorithm- -> IV- -> SKey- -> BL.ByteString- -> Either String SKAddendum-encryptLegacyCFBSecretKey pkp sa iv skey pp = do- keyLen <- first renderCipherError (keySize sa)- keyMaterial <-- first- renderS2KError- (string2Key (Simple DeprecatedMD5) keyLen pp)- cleartext <- legacySecretKeyPayload pkp skey- let clearWithChecksum =- BL.toStrict- ( cleartext- <> runPut (putWord16be (checksum16 (BL.toStrict cleartext)))- )- (\encrypted -> SUSym sa iv (BL.fromStrict encrypted))- <$> first- renderCipherError- ( encryptNoNonce- sa- (Simple DeprecatedMD5)- iv- clearWithChecksum- keyMaterial- )--encrypt16BitProtectedSecretKey- :: SymmetricAlgorithm- -> S2K- -> IV- -> BL.ByteString- -> B.ByteString- -> Either String SKAddendum-encrypt16BitProtectedSecretKey sa s2k iv cleartext keyMaterial =- encryptProtectedSecretKey- sa- s2k- iv- cleartext- keyMaterial- checksum16Trailer- (\payload -> SUS16bit sa s2k iv payload)--encryptSHA1ProtectedSecretKey- :: SymmetricAlgorithm- -> S2K- -> IV- -> BL.ByteString- -> B.ByteString- -> Either String SKAddendum-encryptSHA1ProtectedSecretKey sa s2k iv cleartext keyMaterial =- encryptProtectedSecretKey- sa- s2k- iv- cleartext- keyMaterial- sha1Trailer- (\payload -> SUSSHA1 sa s2k iv payload) encryptProtectedSecretKey :: SymmetricAlgorithm
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -1885,9 +1885,7 @@ Validates constraints before calling putPkt to ensure errors are caught early. -} putPktEither :: Pkt -> Either String Put-putPktEither pkt = case validatePkt pkt of- Left err -> Left err- Right () -> Right (putPkt pkt)+putPktEither pkt = (putPkt pkt) <$ validatePkt pkt putLengthThenPayload :: ByteString -> Put putLengthThenPayload bs = do@@ -1999,7 +1997,7 @@ kdfHA <- get kdfSA <- get return $ ECDHPubKey ed kdfHA kdfSA-getPubkey EdDSA = do+getPubkey EdDSALegacy = do curvelength <- getWord8 when (curvelength == 0 || curvelength == 0xff) $ fail "invalid EdDSA curve OID length octet (reserved value)"@@ -2027,7 +2025,7 @@ . os2ip . BL.toStrict )- (getPubkey EdDSA)+ (getPubkey EdDSALegacy) getPubkey pka | pka == BTypes.Ed448 = parseFixedLengthOrLegacyPubkey@@ -2038,7 +2036,7 @@ . os2ip . BL.toStrict )- (getPubkey EdDSA)+ (getPubkey EdDSALegacy) getPubkey X25519 = parseFixedLengthOrLegacyPubkey 32@@ -2315,94 +2313,142 @@ parseOPSNestedFlag other = fail ("invalid OPS nested flag octet: " ++ show other) -getSecretKey :: SomePKPayload -> Get SKey-getSecretKey pkp- | _pkalgo pkp- `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do- MPI d <- get- MPI p <- get- MPI q <- get- MPI _ <- get -- u- case inverse q p of- Nothing -> fail "invalid RSA secret key: q has no inverse modulo p"- Just qinv -> do- let dP = d `mod` (p - 1)- dQ = d `mod` (q - 1)- pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (_pubkey pkp)+getRSAPrivateKey :: SomePKPayload -> Get SKey+getRSAPrivateKey pkp = do+ MPI d <- get+ MPI p <- get+ MPI q <- get+ MPI _ <- get -- u+ case inverse q p of+ Nothing -> fail "invalid RSA secret key: q has no inverse modulo p"+ Just qinv -> do+ let dP = d `mod` (p - 1)+ dQ = d `mod` (q - 1)+ pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (_pubkey pkp)+ return $+ RSAPrivateKey+ (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv))++getDSAPrivateKey :: SomePKPayload -> Get SKey+getDSAPrivateKey pkp = do+ MPI x <- get+ return $+ DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x))++getElGamalPrivateKey :: SomePKPayload -> Get SKey+getElGamalPrivateKey pkp = do+ MPI x <- get+ return $ ElGamalPrivateKey x++getECDSAPrivateKey :: SomePKPayload -> Get SKey+getECDSAPrivateKey pkp = do+ let pubcurve =+ (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)+ (_pubkey pkp)+ getECDSAScalarPrivateKey pubcurve++getECDHPrivateKey :: SomePKPayload -> Get SKey+getECDHPrivateKey pkp = do+ pubcurve <- ecdhPrivateCurveFromPKPayload pkp+ getECDHScalarPrivateKey pubcurve++getX25519PrivateKey :: SomePKPayload -> Get SKey+getX25519PrivateKey pkp+ | _keyVersion pkp == V6 = do+ sk <- getByteString 32+ return $ X25519PrivateKey sk+ | otherwise = do+ pubcurve <- ecdhPrivateCurveFromPKPayload pkp+ getECDHScalarPrivateKey pubcurve++getX448PrivateKey :: SomePKPayload -> Get SKey+getX448PrivateKey pkp+ | _keyVersion pkp == V6 = do+ sk <- getByteString 56+ return $ X448PrivateKey sk+ | otherwise = UnknownSKey <$> getRemainingLazyByteString++getEdDSALegacyPrivateKey :: SomePKPayload -> Get SKey+getEdDSALegacyPrivateKey pkp+ | _keyVersion pkp == V6 =+ UnknownSKey <$> getRemainingLazyByteString+ | otherwise = do+ MPI x <- get+ case _pubkey pkp of+ EdDSAPubKey P.EdSigningCurve25519 _ -> return $- RSAPrivateKey- (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv))- | _pkalgo pkp == DSA = do+ EdDSAPrivateKey P.EdSigningCurve25519 (leftPadTo 32 (i2osp x))+ EdDSAPubKey P.EdSigningCurve448 _ ->+ return $+ EdDSAPrivateKey P.EdSigningCurve448 (leftPadTo 57 (i2osp x))+ _ -> return $ UnknownSKey (BL.fromStrict (i2osp x))++getMLKEMPrivateKey :: SomePKPayload -> Get SKey+getMLKEMPrivateKey pkp+ | _keyVersion pkp == V6 = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ MLKEMPrivateKey bs+ | otherwise = UnknownSKey <$> getRemainingLazyByteString++getMLDSAPrivateKey :: SomePKPayload -> Get SKey+getMLDSAPrivateKey pkp+ | _keyVersion pkp == V6 = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ MLDSAPrivateKey bs+ | otherwise = UnknownSKey <$> getRemainingLazyByteString++getSLHDSAPrivateKey :: SomePKPayload -> Get SKey+getSLHDSAPrivateKey pkp+ | _keyVersion pkp == V6 = do+ len <- getWord32be+ bs <- getByteString (fromIntegral len)+ return $ SLHDSAPrivateKey bs+ | otherwise = UnknownSKey <$> getRemainingLazyByteString++getEd25519PrivateKey :: SomePKPayload -> Get SKey+getEd25519PrivateKey pkp+ | _keyVersion pkp == V6 = do+ Ed25519PrivateKey <$> getByteString 32+ | otherwise = do MPI x <- get return $- DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x))- | _pkalgo pkp `elem` [ElgamalEncryptOnly, ForbiddenElgamal] = do- MPI x <- get- return $ ElGamalPrivateKey x- | _pkalgo pkp == ECDSA = do- let pubcurve =- (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)- (_pubkey pkp)- getECDSAScalarPrivateKey pubcurve- | _pkalgo pkp == ECDH =- do- pubcurve <- ecdhPrivateCurveFromPKPayload pkp- getECDHScalarPrivateKey pubcurve- | _pkalgo pkp == X25519 = do- if _keyVersion pkp == V6- then do- sk <- getByteString 32- return $ X25519PrivateKey sk- else do- pubcurve <- ecdhPrivateCurveFromPKPayload pkp- getECDHScalarPrivateKey pubcurve- | _pkalgo pkp == X448 = do- if _keyVersion pkp == V6- then do- sk <- getByteString 56- return $ X448PrivateKey sk- else UnknownSKey <$> getRemainingLazyByteString- | _pkalgo pkp == EdDSA = do- if _keyVersion pkp == V6- then do- case _pubkey pkp of- EdDSAPubKey P.EdSigningCurve25519 _ -> EdDSAPrivateKey P.EdSigningCurve25519 <$> getByteString 32- EdDSAPubKey P.EdSigningCurve448 _ -> EdDSAPrivateKey P.EdSigningCurve448 <$> getByteString 57- _ -> UnknownSKey <$> getRemainingLazyByteString- else do- MPI x <- get- case _pubkey pkp of- EdDSAPubKey P.EdSigningCurve25519 _ ->- return $- EdDSAPrivateKey P.EdSigningCurve25519 (leftPadTo 32 (i2osp x))- EdDSAPubKey P.EdSigningCurve448 _ ->- return $- EdDSAPrivateKey P.EdSigningCurve448 (leftPadTo 57 (i2osp x))- _ -> return $ UnknownSKey (BL.fromStrict (i2osp x))- | _pkalgo pkp `elem` [MLKEM768X25519, MLKEM1024X448] = do- if _keyVersion pkp == V6- then do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ MLKEMPrivateKey bs- else UnknownSKey <$> getRemainingLazyByteString- | _pkalgo pkp `elem` [MLDSA65Ed25519, MLDSA87Ed448] = do- if _keyVersion pkp == V6- then do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ MLDSAPrivateKey bs- else UnknownSKey <$> getRemainingLazyByteString- | _pkalgo pkp- `elem` [SLHDSASHAKE128s, SLHDSASHAKE128f, SLHDSASHAKE256s] = do- if _keyVersion pkp == V6- then do- len <- getWord32be- bs <- getByteString (fromIntegral len)- return $ SLHDSAPrivateKey bs- else UnknownSKey <$> getRemainingLazyByteString+ EdDSAPrivateKey P.EdSigningCurve25519 (leftPadTo 32 (i2osp x))++getEd448PrivateKey :: SomePKPayload -> Get SKey+getEd448PrivateKey pkp+ | _keyVersion pkp == V6 = do+ Ed448PrivateKey <$> getByteString 57 | otherwise = UnknownSKey <$> getRemainingLazyByteString +getSecretKey :: SomePKPayload -> Get SKey+getSecretKey pkp = case _pkalgo pkp of+ pka+ | pka `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] ->+ getRSAPrivateKey pkp+ DSA -> getDSAPrivateKey pkp+ pka+ | pka `elem` [ElgamalEncryptOnly, ForbiddenElgamal] ->+ getElGamalPrivateKey pkp+ ECDSA -> getECDSAPrivateKey pkp+ ECDH -> getECDHPrivateKey pkp+ X25519 -> getX25519PrivateKey pkp+ X448 -> getX448PrivateKey pkp+ EdDSALegacy -> getEdDSALegacyPrivateKey pkp+ Ed25519 -> getEd25519PrivateKey pkp+ Ed448 -> getEd448PrivateKey pkp+ pka+ | pka `elem` [MLKEM768X25519, MLKEM1024X448] ->+ getMLKEMPrivateKey pkp+ pka+ | pka `elem` [MLDSA65Ed25519, MLDSA87Ed448] ->+ getMLDSAPrivateKey pkp+ pka+ | pka `elem` [SLHDSASHAKE128s, SLHDSASHAKE128f, SLHDSASHAKE256s] ->+ getSLHDSAPrivateKey pkp+ _ -> UnknownSKey <$> getRemainingLazyByteString+ getECDSAScalarPrivateKey :: ECCT.Curve -> Get SKey getECDSAScalarPrivateKey curve = do MPI pn <- get@@ -2446,8 +2492,9 @@ Right (put (MPI d)) putSKey (ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) = Right (put (MPI d))-putSKey (EdDSAPrivateKey P.EdSigningCurve25519 sk) = Right (putByteString sk)-putSKey (EdDSAPrivateKey P.EdSigningCurve448 sk) = Right (putByteString sk)+putSKey (EdDSAPrivateKey _ bs) = Right (put (MPI (os2ip bs)))+putSKey (Ed25519PrivateKey sk) = Right (putByteString sk)+putSKey (Ed448PrivateKey sk) = Right (putByteString sk) putSKey (X25519PrivateKey sk) = Right (putByteString sk) putSKey (X448PrivateKey sk) = Right (putByteString sk) putSKey (MLKEMPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))@@ -2456,9 +2503,9 @@ putSKey (UnknownSKey bs) = Right (putLazyByteString bs) putSKeyForPKPayload :: SomePKPayload -> SKey -> Either String Put-putSKeyForPKPayload pkp sk@(EdDSAPrivateKey _ bs)- | _keyVersion pkp == V6 = putSKey sk- | otherwise = Right (put (MPI (os2ip bs)))+putSKeyForPKPayload _ sk@(EdDSAPrivateKey {}) = putSKey sk+putSKeyForPKPayload _ sk@(Ed25519PrivateKey {}) = putSKey sk+putSKeyForPKPayload _ sk@(Ed448PrivateKey {}) = putSKey sk putSKeyForPKPayload _ sk = putSKey sk putMPI :: MPI -> Put@@ -3610,10 +3657,7 @@ decodeSingleArmorPayload :: ByteString -> Either String ByteString-decodeSingleArmorPayload bs =- case AA.decodeLazy bs of- Left err -> Left err- Right armors -> singleArmorPayload armors+decodeSingleArmorPayload bs = singleArmorPayload =<< AA.decodeLazy bs decodeSingleArmorPayloadLenient :: ByteString -> Either String ByteString
Codec/Encryption/OpenPGP/SerializeForSigs.hs view
@@ -34,7 +34,6 @@ import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Text.Encoding (encodeUtf8)-import Data.Word (Word8) import Codec.Encryption.OpenPGP.Internal ( PktStreamContext (..)
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -27,7 +27,6 @@ , verifyAgainstPKPs , verifyAgainstPKPsWithPolicy , verifyTKWith- , verifyUnknownTKWith , signCertificationWithRSA , signDirectKeyWithRSA , signKeyRevocationWithRSA@@ -58,8 +57,8 @@ import Control.Applicative ((<|>)) import Control.Error.Util (hush)-import Control.Lens ((&), (^.), _1)-import Control.Monad (liftM2, when)+import Control.Lens ((^.))+import Control.Monad (liftM2) import Crypto.Error (eitherCryptoError) import Crypto.Hash (hashWith) import qualified Crypto.Hash.Algorithms as CHA@@ -76,15 +75,14 @@ import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL+import Data.Containers.ListUtils (nubOrd) import Data.Either (isRight, lefts, rights)-import Data.Function (on) import Data.IxSet.Typed ((@=)) import qualified Data.IxSet.Typed as IxSet-import Data.List (find, intercalate, nub)+import Data.List (find, intercalate) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE-import qualified Data.Map.Strict as Map-import Data.Maybe (isJust, mapMaybe)+import Data.Maybe (isJust) import qualified Data.Set as Set import Data.Text (Text) import Data.Time.Clock (UTCTime (..), addUTCTime, diffUTCTime)@@ -120,11 +118,8 @@ ) import Codec.Encryption.OpenPGP.Policy ( VerificationPolicy (..)- , VerificationPolicyAction (..) , applyVerificationPolicy , defaultVerificationPolicy- , isVerificationError- , isVerificationWarning , signatureV6SaltSizeForHashAlgorithm ) import Codec.Encryption.OpenPGP.SerializeForSigs@@ -156,9 +151,6 @@ import qualified Codec.Encryption.OpenPGP.Subpackets as SP import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA-import Codec.Encryption.OpenPGP.Types.Internal.Pkt- ( VerificationWarning (..)- ) import Data.Conduit.OpenPGP.Keyring.Instances () data VerificationError@@ -288,7 +280,7 @@ "verification failed: signature expired" renderVerificationError (CandidateKeyFailures errs) = "verification failed: no candidate key validated the signature ("- ++ intercalate "; " (nub (map renderVerificationError errs))+ ++ intercalate "; " (nubOrd $ map renderVerificationError errs) ++ ")" renderVerificationError (InvalidSubkeyBackSignature err) = "verification failed: embedded primary-key back-signature verification failed: "@@ -310,10 +302,6 @@ :: VerificationError -> Either VerificationError a verificationError = Left -renderVerificationResult- :: Either VerificationError a -> Either String a-renderVerificationResult = first renderVerificationError- data SignError = SignBackendError String | SignUnsupportedCertificationType SigType@@ -367,13 +355,6 @@ isVerifiableSignaturePayload :: SignaturePayload -> Bool isVerifiableSignaturePayload = isJust . fromSignaturePayloadVerifiableSignatureV -toSignaturePayloadFromVerifiable- :: VerifiableSignatureV -> SignaturePayload-toSignaturePayloadFromVerifiable (VerifiableSignatureV4 payload) =- toSignaturePayload payload-toSignaturePayloadFromVerifiable (VerifiableSignatureV6 payload) =- toSignaturePayload payload- fromPktEitherVerifiableSignatureV :: Pkt -> Either VerificationError VerifiableSignatureV fromPktEitherVerifiableSignatureV (SignaturePkt sigPayload) =@@ -656,20 +637,7 @@ -> Maybe UTCTime -> TK k -> Either VerificationError (TK k)-verifyTKWith vsf mt tk =- verifyUnknownTKWith vsf mt tk--{-# DEPRECATED verifyUnknownTKWith "Use verifyTKWith instead" #-}-verifyUnknownTKWith- :: ( Pkt- -> PktStreamContext- -> Maybe UTCTime- -> Either VerificationError Verification- )- -> Maybe UTCTime- -> TK k- -> Either VerificationError (TK k)-verifyUnknownTKWith vsf mt tk = do+verifyTKWith vsf mt tk = do revokers <- checkRevokers tk revs <- checkKeyRevocations revokers tk let uids = filter (not . null . snd) . checkUidSigs $ tk ^. tkUIDs@@ -1013,7 +981,7 @@ ([], filter matchesP (candidatePKPs tk)) resolveCandidateSignerPKPs allKeys _ (Just validationTime) matchesP tk = let rawMatches = filter matchesP (candidatePKPs tk)- in case verifyUnknownTKWith+ in case verifyTKWith ( verifySigWith defaultVerificationPolicy (verifyAgainstKeys allKeys)@@ -1025,12 +993,11 @@ let verifiedMatches = map ( \pkp ->- case historicallyValidSigner- validationTime- (timelineValidationTK pkp verifiedTK)- pkp of- Right () -> Right pkp- Left err -> Left err+ pkp+ <$ historicallyValidSigner+ validationTime+ (timelineValidationTK pkp verifiedTK)+ pkp ) rawMatches in (lefts verifiedMatches, rights verifiedMatches)@@ -1209,20 +1176,6 @@ subkeyPKPFromPkt (SecretSubkeyPkt p _) = Just p subkeyPKPFromPkt _ = Nothing -verifyAgainstKey'- :: SomePKPayload- -> Pkt- -> Maybe UTCTime- -> ByteString- -> Either VerificationError Verification-verifyAgainstKey' pkp sig mt payload =- verifyAgainstKeyWithPolicy- defaultVerificationPolicy- pkp- sig- mt- payload- {- | Verify a signature against a key with a custom verification policy. This allows callers to control whether certain signature features (deprecated hash algorithms, PKA mismatches, etc.) are treated as@@ -1309,12 +1262,12 @@ `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] pkaCompatible DeprecatedRSASignOnly keyPka = keyPka `elem` [RSA, DeprecatedRSASignOnly]- pkaCompatible PKA.EdDSA keyPka =- keyPka `elem` [PKA.EdDSA, PKA.Ed25519, PKA.Ed448]+ pkaCompatible PKA.EdDSALegacy keyPka =+ keyPka `elem` [PKA.EdDSALegacy, PKA.Ed25519, PKA.Ed448] pkaCompatible PKA.Ed25519 keyPka =- keyPka `elem` [PKA.EdDSA, PKA.Ed25519]+ keyPka `elem` [PKA.EdDSALegacy, PKA.Ed25519] pkaCompatible PKA.Ed448 keyPka =- keyPka `elem` [PKA.EdDSA, PKA.Ed448]+ keyPka `elem` [PKA.EdDSALegacy, PKA.Ed448] pkaCompatible sigPka keyPka = sigPka == keyPka verify' details pub@(PKPayload V4 _ _ _ pkey) ha pl = verifyByHash details pub pkey ha pl@@ -1355,10 +1308,10 @@ verifyNoRSA _ (pka, _) _ _ _ _ = verificationError (UnsupportedKeyType pka) edVerify sigPka pub mpis hd key bs = case key of EdDSAPubKey EdSigningCurve25519 pkey- | sigPka `elem` [EdDSA, PKA.Ed25519] ->+ | sigPka `elem` [EdDSALegacy, PKA.Ed25519] -> ed25519Verify sigPka pub mpis hd pkey bs EdDSAPubKey EdSigningCurve448 pkey- | sigPka `elem` [EdDSA, PKA.Ed448] ->+ | sigPka `elem` [EdDSALegacy, PKA.Ed448] -> ed448Verify sigPka pub mpis hd pkey bs _ -> verificationError (UnsupportedKeyType sigPka) dsaVerify pub (r :| [s]) hd pkey bs =@@ -2020,7 +1973,7 @@ , ed448Params :: (String, Int, Int, PubKeyAlgorithm) ed25519Params = ("Ed25519", 64, 32, PKA.Ed25519)-ed25519LegacyParams = ("Ed25519Legacy", 64, 32, PKA.EdDSA)+ed25519LegacyParams = ("Ed25519Legacy", 64, 32, PKA.EdDSALegacy) ed448Params = ("Ed448", 114, 57, PKA.Ed448) signDataWithEdDSAV4Generic
Codec/Encryption/OpenPGP/Subpackets.hs view
@@ -2,7 +2,6 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-}@@ -13,105 +12,104 @@ {-# LANGUAGE TypeFamilies #-} module Codec.Encryption.OpenPGP.Subpackets- ( -- * Safe subpacket construction- SafeSubpacket- , mkSafeSubpacket- , safePayload- , safeSubpacket-- -- * Critical subpacket handling- , CriticalSubpacket- , mkCritical- , canBeCritical+ ( -- * Safe subpacket construction+ SafeSubpacket+ , mkSafeSubpacket+ , safePayload+ , safeSubpacket - -- * Text normalization mode- , TextNormalizationMode(..)+ -- * Critical subpacket handling+ , CriticalSubpacket+ , mkCritical+ , canBeCritical - -- * Builder API for signature composition- , SigBuilder- , LegalSubpacket(..)- , legalSubpacket- , singleLegalSub- , consLegalSub- , listToLegalSubs- , sbSigType- , sbPubKeyAlgo- , sbHashAlgo- , sbHashedSubs- , sbUnhashedSubs- , sbSalt- , sbTextNormMode- , buildSigV4- , buildSigV6- , sigBuilderInit- , sigBuilderInitTyped- , sigBuilderInitRuntime- , sigBuilderInitV6- , sigBuilderInitV6Typed- , sigBuilderInitV6Runtime- , addHashedSubs- , addUnhashedSubs- , KnownPubKeyAlgorithm(..)+ -- * Text normalization mode+ , TextNormalizationMode (..) - -- * Private key wrapper (algorithm-specific)- , PrivateKeyFor(..)+ -- * Builder API for signature composition+ , SigBuilder+ , LegalSubpacket (..)+ , legalSubpacket+ , singleLegalSub+ , consLegalSub+ , listToLegalSubs+ , sbSigType+ , sbPubKeyAlgo+ , sbHashAlgo+ , sbHashedSubs+ , sbUnhashedSubs+ , sbSalt+ , sbTextNormMode+ , buildSigV4+ , buildSigV6+ , sigBuilderInit+ , sigBuilderInitTyped+ , sigBuilderInitRuntime+ , sigBuilderInitV6+ , sigBuilderInitV6Typed+ , sigBuilderInitV6Runtime+ , addHashedSubs+ , addUnhashedSubs+ , KnownPubKeyAlgorithm (..) - -- * Subpacket list utilities- , HashedSubpackets- , UnhashedSubpackets- , consHashedSub- , singleHashedSub- , singleUnhashedSub- , listToHashedSubs- , listToUnhashedSubs- ) where+ -- * Private key wrapper (algorithm-specific)+ , PrivateKeyFor (..) -import Data.Kind (Type)-import Data.List.NonEmpty (NonEmpty)-import Data.Proxy (Proxy(..))-import Data.Word (Word16)+ -- * Subpacket list utilities+ , HashedSubpackets+ , UnhashedSubpackets+ , consHashedSub+ , singleHashedSub+ , singleUnhashedSub+ , listToHashedSubs+ , listToUnhashedSubs+ ) where import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 import qualified Crypto.PubKey.RSA.Types as RSATypes+import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty)+import Data.Proxy (Proxy (..))+import Data.Word (Word16) +import Codec.Encryption.OpenPGP.Policy+ ( HashAlgoAllowedFor+ , HashAlgorithmW (..)+ , OpenPGPRFC+ , OpenPGPRFCW (..)+ , SomeHashAlgorithmW (..)+ , SomeOpenPGPRFCW (..)+ , demoteHashAlgorithmW+ , deprecatedHashAlgorithms+ , policyForRFC+ , policyGenerationDeprecations+ , promoteHashAlgorithm+ , promoteOpenPGPRFC+ ) import Codec.Encryption.OpenPGP.Types- ( Hashed- , Unhashed- , V4Sig- , V6Sig- , Fingerprint- , EightOctetKeyId- , ThirtyTwoBitTimeStamp- , MPI- , SigSubPacket(..)- , SigSubPacketPayload(..)- , SignaturePayload(..)- , SignatureSalt- , SigType- , HashAlgorithm- , SubpacketList(..)- )+ ( EightOctetKeyId+ , Fingerprint+ , HashAlgorithm+ , Hashed+ , MPI+ , SigSubPacket (..)+ , SigSubPacketPayload (..)+ , SigType+ , SignaturePayload (..)+ , SignatureSalt+ , SubpacketList (..)+ , ThirtyTwoBitTimeStamp+ , Unhashed+ , V4Sig+ , V6Sig+ ) import Codec.Encryption.OpenPGP.Types.Internal.Base- ( PubKeyAlgorithm(..)- , IssuerFingerprintVersion(..)- )-import Codec.Encryption.OpenPGP.Policy- ( HashAlgoAllowedFor- , OpenPGPRFC- , OpenPGPRFCW(..)- , SomeOpenPGPRFCW(..)- , HashAlgorithmW(..)- , SomeHashAlgorithmW(..)- , promoteOpenPGPRFC- , promoteHashAlgorithm- , demoteHashAlgorithmW- , policyForRFC- , policyGenerationDeprecations- , deprecatedHashAlgorithms- )+ ( IssuerFingerprintVersion (..)+ , PubKeyAlgorithm (..)+ ) -- | Type alias for readability: hashed subpacket list type HashedSubpackets v = SubpacketList Hashed v@@ -119,19 +117,24 @@ -- | Type alias for readability: unhashed subpacket list type UnhashedSubpackets v = SubpacketList Unhashed v --- | A subpacket that has passed basic safety checks--- (does not guarantee it's critical-safe; use CriticalSubpacket for that)+{- | A subpacket that has passed basic safety checks+(does not guarantee it's critical-safe; use CriticalSubpacket for that)+-} newtype SafeSubpacket = SafeSubpacket SigSubPacket- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show) --- | Create a safe subpacket from a payload and criticality flag--- Basic validation that the payload is well-formed-mkSafeSubpacket :: Bool -> SigSubPacketPayload -> Either String SafeSubpacket+{- | Create a safe subpacket from a payload and criticality flag+Basic validation that the payload is well-formed+-}+mkSafeSubpacket+ :: Bool -> SigSubPacketPayload -> Either String SafeSubpacket mkSafeSubpacket crit payload = do- -- Validate criticality constraints: some subpackets should never be critical- if crit && not (canBeCritical payload)- then Left $ "Subpacket type cannot be marked critical: " ++ show payload- else Right (SafeSubpacket (SigSubPacket crit payload))+ -- Validate criticality constraints: some subpackets should never be critical+ if crit && not (canBeCritical payload)+ then+ Left $+ "Subpacket type cannot be marked critical: " ++ show payload+ else Right (SafeSubpacket (SigSubPacket crit payload)) -- | Extract the payload from a safe subpacket safePayload :: SafeSubpacket -> SigSubPacketPayload@@ -141,17 +144,22 @@ safeSubpacket :: SafeSubpacket -> SigSubPacket safeSubpacket (SafeSubpacket ssp) = ssp --- | A subpacket that is guaranteed to be both well-formed AND can be safely marked critical--- Used to prevent accidentally marking non-critical-safe types as critical+{- | A subpacket that is guaranteed to be both well-formed AND can be safely marked critical+Used to prevent accidentally marking non-critical-safe types as critical+-} newtype CriticalSubpacket = CriticalSubpacket SigSubPacket- deriving (Eq, Ord, Show)+ deriving (Eq, Ord, Show) --- | Create a critical subpacket only if the payload type allows it--- RFC9580 section 5.2.3.5: only certain subpacket types can be marked critical-mkCritical :: SigSubPacketPayload -> Either String CriticalSubpacket+{- | Create a critical subpacket only if the payload type allows it+RFC9580 section 5.2.3.5: only certain subpacket types can be marked critical+-}+mkCritical+ :: SigSubPacketPayload -> Either String CriticalSubpacket mkCritical payload- | canBeCritical payload = Right $ CriticalSubpacket (SigSubPacket True payload)- | otherwise = Left $ "Cannot mark as critical: " ++ payloadType payload+ | canBeCritical payload =+ Right $ CriticalSubpacket (SigSubPacket True payload)+ | otherwise =+ Left $ "Cannot mark as critical: " ++ payloadType payload where payloadType (SigCreationTime _) = "SigCreationTime" payloadType (SigExpirationTime _) = "SigExpirationTime"@@ -192,47 +200,52 @@ canBeCritical OtherSigSub {} = True canBeCritical _ = False --- | Wrapper GADT for algorithm-specific private keys--- Encodes the algorithm at the type level to ensure type-safe key/builder matching+{- | Wrapper GADT for algorithm-specific private keys+Encodes the algorithm at the type level to ensure type-safe key/builder matching+-} data PrivateKeyFor (algo :: PubKeyAlgorithm) where- RSAPrivateKey :: RSATypes.PrivateKey -> PrivateKeyFor 'RSA- Ed25519PrivateKey :: Ed25519.SecretKey -> PrivateKeyFor 'Ed25519- Ed448PrivateKey :: Ed448.SecretKey -> PrivateKeyFor 'Ed448- DSAPrivateKey :: DSA.PrivateKey -> PrivateKeyFor 'DSA- ECDSAPrivateKey :: ECDSA.PrivateKey -> PrivateKeyFor 'ECDSA+ RSAPrivateKey :: RSATypes.PrivateKey -> PrivateKeyFor 'RSA+ Ed25519PrivateKey :: Ed25519.SecretKey -> PrivateKeyFor 'Ed25519+ Ed448PrivateKey :: Ed448.SecretKey -> PrivateKeyFor 'Ed448+ DSAPrivateKey :: DSA.PrivateKey -> PrivateKeyFor 'DSA+ ECDSAPrivateKey :: ECDSA.PrivateKey -> PrivateKeyFor 'ECDSA class KnownPubKeyAlgorithm (algo :: PubKeyAlgorithm) where- demotePubKeyAlgorithmT :: Proxy algo -> PubKeyAlgorithm+ demotePubKeyAlgorithmT :: Proxy algo -> PubKeyAlgorithm instance KnownPubKeyAlgorithm 'RSA where- demotePubKeyAlgorithmT _ = RSA+ demotePubKeyAlgorithmT _ = RSA instance KnownPubKeyAlgorithm 'DSA where- demotePubKeyAlgorithmT _ = DSA+ demotePubKeyAlgorithmT _ = DSA instance KnownPubKeyAlgorithm 'ECDSA where- demotePubKeyAlgorithmT _ = ECDSA+ demotePubKeyAlgorithmT _ = ECDSA -instance KnownPubKeyAlgorithm 'EdDSA where- demotePubKeyAlgorithmT _ = EdDSA+instance KnownPubKeyAlgorithm 'EdDSALegacy where+ demotePubKeyAlgorithmT _ = EdDSALegacy instance KnownPubKeyAlgorithm 'Ed25519 where- demotePubKeyAlgorithmT _ = Ed25519+ demotePubKeyAlgorithmT _ = Ed25519 instance KnownPubKeyAlgorithm 'Ed448 where- demotePubKeyAlgorithmT _ = Ed448+ demotePubKeyAlgorithmT _ = Ed448 --- | Legal subpackets encoded by placement and signature-version constraints.--- This expands compile-time legality beyond bare hashed/unhashed staging.+{- | Legal subpackets encoded by placement and signature-version constraints.+This expands compile-time legality beyond bare hashed/unhashed staging.+-} data LegalSubpacket (h :: Type) (v :: Type) where- -- RFC9580: signature creation time is a hashed subpacket.- LegalSigCreationTime :: ThirtyTwoBitTimeStamp -> LegalSubpacket Hashed v- -- v4 signatures use an issuer fingerprint subpacket with version marker 4 in hashed area.- LegalIssuerFingerprintV4 :: Fingerprint -> LegalSubpacket Hashed V4Sig- -- v6 signatures use an issuer fingerprint subpacket with version marker 6 in hashed area.- LegalIssuerFingerprintV6 :: Fingerprint -> LegalSubpacket Hashed V6Sig- -- Legacy issuer key ID subpacket is accepted only in v4 and only unhashed.- LegalIssuerV4 :: EightOctetKeyId -> LegalSubpacket Unhashed V4Sig+ -- RFC9580: signature creation time is a hashed subpacket.+ LegalSigCreationTime+ :: ThirtyTwoBitTimeStamp -> LegalSubpacket Hashed v+ -- v4 signatures use an issuer fingerprint subpacket with version marker 4 in hashed area.+ LegalIssuerFingerprintV4+ :: Fingerprint -> LegalSubpacket Hashed V4Sig+ -- v6 signatures use an issuer fingerprint subpacket with version marker 6 in hashed area.+ LegalIssuerFingerprintV6+ :: Fingerprint -> LegalSubpacket Hashed V6Sig+ -- Legacy issuer key ID subpacket is accepted only in v4 and only unhashed.+ LegalIssuerV4 :: EightOctetKeyId -> LegalSubpacket Unhashed V4Sig legalSubpacket :: LegalSubpacket h v -> SigSubPacket legalSubpacket (LegalSigCreationTime ts) = SigSubPacket False (SigCreationTime ts)@@ -243,7 +256,8 @@ singleLegalSub :: LegalSubpacket h v -> SubpacketList h v singleLegalSub = SubpacketList . (: []) . legalSubpacket -consLegalSub :: LegalSubpacket h v -> SubpacketList h v -> SubpacketList h v+consLegalSub+ :: LegalSubpacket h v -> SubpacketList h v -> SubpacketList h v consLegalSub legal (SubpacketList sps) = SubpacketList (legalSubpacket legal : sps) listToLegalSubs :: [LegalSubpacket h v] -> SubpacketList h v@@ -258,248 +272,288 @@ singleUnhashedSub sp = SubpacketList [sp] -- | Prepend a subpacket to a hashed subpacket list-consHashedSub :: SigSubPacket -> HashedSubpackets v -> HashedSubpackets v+consHashedSub+ :: SigSubPacket -> HashedSubpackets v -> HashedSubpackets v consHashedSub sp (SubpacketList sps) = SubpacketList (sp : sps) --- | Controls how text payload is normalized for CanonicalTextSig.------ RFC 9580 §5.2.1.2 requires only CRLF normalization for type 0x01--- signatures. Trailing-whitespace stripping is only mandated by--- §7 (Cleartext Signature Framework). Use 'CleartextCompat' for--- GnuPG-compatible behaviour when producing cleartext-armored--- signatures; use 'RFC9580Strict' for inline text signatures.+{- | Controls how text payload is normalized for CanonicalTextSig.++RFC 9580 §5.2.1.2 requires only CRLF normalization for type 0x01+signatures. Trailing-whitespace stripping is only mandated by+§7 (Cleartext Signature Framework). Use 'CleartextCompat' for+GnuPG-compatible behaviour when producing cleartext-armored+signatures; use 'RFC9580Strict' for inline text signatures.+-} data TextNormalizationMode- = RFC9580Strict- -- ^ CRLF normalization only; no trailing-whitespace stripping.- -- Correct for inline type 0x01 document signatures.- | CleartextCompat- -- ^ CRLF normalization *plus* per-line trailing-whitespace stripping.- -- Required by the Cleartext Signature Framework (RFC 9580 §7).- deriving (Eq, Show)+ = {- | CRLF normalization only; no trailing-whitespace stripping.+ Correct for inline type 0x01 document signatures.+ -}+ RFC9580Strict+ | {- | CRLF normalization *plus* per-line trailing-whitespace stripping.+ Required by the Cleartext Signature Framework (RFC 9580 §7).+ -}+ CleartextCompat+ deriving (Eq, Show) --- | Staged signature builder that enforces completion order--- --- Usage pattern:--- builder <- sigBuilderInit SigTypeBinary RSA SHA256--- builder' <- addHashedSubs hashedList builder--- finalPayload <- buildSigV4 sigMPIs (addUnhashedSubs unhashedList builder')-data SigBuilder (hashedness :: Type) (v :: Type) (algo :: PubKeyAlgorithm) = SigBuilder- { sbSigType :: SigType- , sbHashAlgo :: HashAlgorithm- , sbHashedSubs :: [SigSubPacket]- , sbUnhashedSubs :: [SigSubPacket]- , sbSalt :: BuilderSalt v- , sbTextNormMode :: TextNormalizationMode- -- ^ Normalization mode for CanonicalTextSig payloads.- -- Defaults to 'CleartextCompat' for backward compatibility.- }+{- | Staged signature builder that enforces completion order +Usage pattern:+ builder <- sigBuilderInit SigTypeBinary RSA SHA256+ builder' <- addHashedSubs hashedList builder+ finalPayload <- buildSigV4 sigMPIs (addUnhashedSubs unhashedList builder')+-}+data+ SigBuilder+ (hashedness :: Type)+ (v :: Type)+ (algo :: PubKeyAlgorithm)+ = SigBuilder+ { sbSigType :: SigType+ , sbHashAlgo :: HashAlgorithm+ , sbHashedSubs :: [SigSubPacket]+ , sbUnhashedSubs :: [SigSubPacket]+ , sbSalt :: BuilderSalt v+ , sbTextNormMode :: TextNormalizationMode+ {- ^ Normalization mode for CanonicalTextSig payloads.+ Defaults to 'CleartextCompat' for backward compatibility.+ -}+ }+ type family BuilderSalt (v :: Type) where- BuilderSalt V4Sig = ()- BuilderSalt V6Sig = SignatureSalt+ BuilderSalt V4Sig = ()+ BuilderSalt V6Sig = SignatureSalt -sbPubKeyAlgo :: forall hashedness v algo. KnownPubKeyAlgorithm algo => SigBuilder hashedness v algo -> PubKeyAlgorithm+sbPubKeyAlgo+ :: forall hashedness v algo+ . KnownPubKeyAlgorithm algo+ => SigBuilder hashedness v algo -> PubKeyAlgorithm sbPubKeyAlgo _ = demotePubKeyAlgorithmT (Proxy @algo) --- | Initialize a builder for a v4 signature--- Starts with no subpackets and must call addHashedSubs and addUnhashedSubs-sigBuilderInit ::- forall algo- . KnownPubKeyAlgorithm algo- => SigType- -> HashAlgorithm- -> SigBuilder Hashed V4Sig algo-sigBuilderInit st ha = SigBuilder- { sbSigType = st- , sbHashAlgo = ha- , sbHashedSubs = []- , sbUnhashedSubs = []- , sbSalt = ()- , sbTextNormMode = CleartextCompat- }+{- | Initialize a builder for a v4 signature+Starts with no subpackets and must call addHashedSubs and addUnhashedSubs+-}+sigBuilderInit+ :: forall algo+ . KnownPubKeyAlgorithm algo+ => SigType+ -> HashAlgorithm+ -> SigBuilder Hashed V4Sig algo+sigBuilderInit st ha =+ SigBuilder+ { sbSigType = st+ , sbHashAlgo = ha+ , sbHashedSubs = []+ , sbUnhashedSubs = []+ , sbSalt = ()+ , sbTextNormMode = CleartextCompat+ } -- | Initialize a builder for a v4 signature with compile-time RFC/hash policy enforcement.-sigBuilderInitTyped ::- forall algo rfc h- . (KnownPubKeyAlgorithm algo, HashAlgoAllowedFor rfc h)- => OpenPGPRFCW rfc- -> SigType- -> HashAlgorithmW h- -> SigBuilder Hashed V4Sig algo+sigBuilderInitTyped+ :: forall algo rfc h+ . (HashAlgoAllowedFor rfc h, KnownPubKeyAlgorithm algo)+ => OpenPGPRFCW rfc+ -> SigType+ -> HashAlgorithmW h+ -> SigBuilder Hashed V4Sig algo sigBuilderInitTyped _ st hashW =- sigBuilderInit @algo st (demoteHashAlgorithmW hashW)+ sigBuilderInit @algo st (demoteHashAlgorithmW hashW) --- | Initialize a v4 builder from runtime RFC/hash inputs with policy validation--- and witness promotion at the API boundary.-sigBuilderInitRuntime ::- forall algo- . KnownPubKeyAlgorithm algo- => OpenPGPRFC- -> SigType- -> HashAlgorithm- -> Either String (SigBuilder Hashed V4Sig algo)+{- | Initialize a v4 builder from runtime RFC/hash inputs with policy validation+and witness promotion at the API boundary.+-}+sigBuilderInitRuntime+ :: forall algo+ . KnownPubKeyAlgorithm algo+ => OpenPGPRFC+ -> SigType+ -> HashAlgorithm+ -> Either String (SigBuilder Hashed V4Sig algo) sigBuilderInitRuntime rfc st ha =- withGenerationHashWitness- rfc- ha- (\rfcW hashW -> sigBuilderInitTyped @algo rfcW st hashW)+ withGenerationHashWitness+ rfc+ ha+ (\rfcW hashW -> sigBuilderInitTyped @algo rfcW st hashW) -- | Initialize a builder for a v6 signature-sigBuilderInitV6 ::- forall algo- . KnownPubKeyAlgorithm algo- => SigType- -> HashAlgorithm- -> SignatureSalt- -> SigBuilder Hashed V6Sig algo-sigBuilderInitV6 st ha salt = SigBuilder- { sbSigType = st- , sbHashAlgo = ha- , sbHashedSubs = []- , sbUnhashedSubs = []- , sbSalt = salt- , sbTextNormMode = CleartextCompat- }+sigBuilderInitV6+ :: forall algo+ . KnownPubKeyAlgorithm algo+ => SigType+ -> HashAlgorithm+ -> SignatureSalt+ -> SigBuilder Hashed V6Sig algo+sigBuilderInitV6 st ha salt =+ SigBuilder+ { sbSigType = st+ , sbHashAlgo = ha+ , sbHashedSubs = []+ , sbUnhashedSubs = []+ , sbSalt = salt+ , sbTextNormMode = CleartextCompat+ } -- | Initialize a builder for a v6 signature with compile-time RFC/hash policy enforcement.-sigBuilderInitV6Typed ::- forall algo rfc h- . (KnownPubKeyAlgorithm algo, HashAlgoAllowedFor rfc h)- => OpenPGPRFCW rfc- -> SigType- -> HashAlgorithmW h- -> SignatureSalt- -> SigBuilder Hashed V6Sig algo+sigBuilderInitV6Typed+ :: forall algo rfc h+ . (HashAlgoAllowedFor rfc h, KnownPubKeyAlgorithm algo)+ => OpenPGPRFCW rfc+ -> SigType+ -> HashAlgorithmW h+ -> SignatureSalt+ -> SigBuilder Hashed V6Sig algo sigBuilderInitV6Typed _ st hashW salt =- sigBuilderInitV6 @algo st (demoteHashAlgorithmW hashW) salt+ sigBuilderInitV6 @algo st (demoteHashAlgorithmW hashW) salt --- | Initialize a v6 builder from runtime RFC/hash inputs with policy validation--- and witness promotion at the API boundary.-sigBuilderInitV6Runtime ::- forall algo- . KnownPubKeyAlgorithm algo- => OpenPGPRFC- -> SigType- -> HashAlgorithm- -> SignatureSalt- -> Either String (SigBuilder Hashed V6Sig algo)+{- | Initialize a v6 builder from runtime RFC/hash inputs with policy validation+and witness promotion at the API boundary.+-}+sigBuilderInitV6Runtime+ :: forall algo+ . KnownPubKeyAlgorithm algo+ => OpenPGPRFC+ -> SigType+ -> HashAlgorithm+ -> SignatureSalt+ -> Either String (SigBuilder Hashed V6Sig algo) sigBuilderInitV6Runtime rfc st ha salt =- withGenerationHashWitness- rfc- ha- (\rfcW hashW -> sigBuilderInitV6Typed @algo rfcW st hashW salt)+ withGenerationHashWitness+ rfc+ ha+ (\rfcW hashW -> sigBuilderInitV6Typed @algo rfcW st hashW salt) -withGenerationHashWitness ::- OpenPGPRFC- -> HashAlgorithm- -> (forall rfc h. HashAlgoAllowedFor rfc h => OpenPGPRFCW rfc -> HashAlgorithmW h -> a)- -> Either String a+withGenerationHashWitness+ :: OpenPGPRFC+ -> HashAlgorithm+ -> ( forall rfc h+ . HashAlgoAllowedFor rfc h+ => OpenPGPRFCW rfc -> HashAlgorithmW h -> a+ )+ -> Either String a withGenerationHashWitness rfc ha mk- | ha `elem` deprecatedHashAlgorithms (policyGenerationDeprecations (policyForRFC rfc)) =- Left (hashPolicyDisallowedMessage rfc ha)- | otherwise =- case promoteHashAlgorithm ha of- Nothing ->- Left (hashNotTypedBuilderMessage ha)- Just (SomeHashAlgorithmW hashW) ->- case promoteOpenPGPRFC rfc of- SomeOpenPGPRFCW RFC2440W ->- Right $- case hashW of- DeprecatedMD5W -> mk RFC2440W DeprecatedMD5W- SHA1W -> mk RFC2440W SHA1W- RIPEMD160W -> mk RFC2440W RIPEMD160W- SHA256W -> mk RFC2440W SHA256W- SHA384W -> mk RFC2440W SHA384W- SHA512W -> mk RFC2440W SHA512W- SHA224W -> mk RFC2440W SHA224W- SHA3_256W -> mk RFC2440W SHA3_256W- SHA3_512W -> mk RFC2440W SHA3_512W- SomeOpenPGPRFCW RFC4880W ->- case hashW of- SHA1W -> Right (mk RFC4880W SHA1W)- RIPEMD160W -> Right (mk RFC4880W RIPEMD160W)- SHA256W -> Right (mk RFC4880W SHA256W)- SHA384W -> Right (mk RFC4880W SHA384W)- SHA512W -> Right (mk RFC4880W SHA512W)- SHA224W -> Right (mk RFC4880W SHA224W)- SHA3_256W -> Right (mk RFC4880W SHA3_256W)- SHA3_512W -> Right (mk RFC4880W SHA3_512W)- DeprecatedMD5W ->- Left (hashPolicyDisallowedMessage rfc ha)- SomeOpenPGPRFCW RFC9580W ->- case hashW of- SHA256W -> Right (mk RFC9580W SHA256W)- SHA384W -> Right (mk RFC9580W SHA384W)- SHA512W -> Right (mk RFC9580W SHA512W)- SHA224W -> Right (mk RFC9580W SHA224W)- SHA3_256W -> Right (mk RFC9580W SHA3_256W)- SHA3_512W -> Right (mk RFC9580W SHA3_512W)- DeprecatedMD5W ->- Left (hashPolicyDisallowedMessage rfc ha)- SHA1W ->- Left (hashPolicyDisallowedMessage rfc ha)- RIPEMD160W ->- Left (hashPolicyDisallowedMessage rfc ha)+ | ha+ `elem` deprecatedHashAlgorithms+ (policyGenerationDeprecations (policyForRFC rfc)) =+ Left (hashPolicyDisallowedMessage rfc ha)+ | otherwise =+ case promoteHashAlgorithm ha of+ Nothing ->+ Left (hashNotTypedBuilderMessage ha)+ Just (SomeHashAlgorithmW hashW) ->+ case promoteOpenPGPRFC rfc of+ SomeOpenPGPRFCW RFC2440W ->+ Right $+ case hashW of+ DeprecatedMD5W -> mk RFC2440W DeprecatedMD5W+ SHA1W -> mk RFC2440W SHA1W+ RIPEMD160W -> mk RFC2440W RIPEMD160W+ SHA256W -> mk RFC2440W SHA256W+ SHA384W -> mk RFC2440W SHA384W+ SHA512W -> mk RFC2440W SHA512W+ SHA224W -> mk RFC2440W SHA224W+ SHA3_256W -> mk RFC2440W SHA3_256W+ SHA3_512W -> mk RFC2440W SHA3_512W+ SomeOpenPGPRFCW RFC4880W ->+ case hashW of+ SHA1W -> Right (mk RFC4880W SHA1W)+ RIPEMD160W -> Right (mk RFC4880W RIPEMD160W)+ SHA256W -> Right (mk RFC4880W SHA256W)+ SHA384W -> Right (mk RFC4880W SHA384W)+ SHA512W -> Right (mk RFC4880W SHA512W)+ SHA224W -> Right (mk RFC4880W SHA224W)+ SHA3_256W -> Right (mk RFC4880W SHA3_256W)+ SHA3_512W -> Right (mk RFC4880W SHA3_512W)+ DeprecatedMD5W ->+ Left (hashPolicyDisallowedMessage rfc ha)+ SomeOpenPGPRFCW RFC9580W ->+ case hashW of+ SHA256W -> Right (mk RFC9580W SHA256W)+ SHA384W -> Right (mk RFC9580W SHA384W)+ SHA512W -> Right (mk RFC9580W SHA512W)+ SHA224W -> Right (mk RFC9580W SHA224W)+ SHA3_256W -> Right (mk RFC9580W SHA3_256W)+ SHA3_512W -> Right (mk RFC9580W SHA3_512W)+ DeprecatedMD5W ->+ Left (hashPolicyDisallowedMessage rfc ha)+ SHA1W ->+ Left (hashPolicyDisallowedMessage rfc ha)+ RIPEMD160W ->+ Left (hashPolicyDisallowedMessage rfc ha) -hashPolicyDisallowedMessage :: OpenPGPRFC -> HashAlgorithm -> String+hashPolicyDisallowedMessage+ :: OpenPGPRFC -> HashAlgorithm -> String hashPolicyDisallowedMessage rfc ha =- "signature hash algorithm disallowed by RFC policy (" ++ show rfc ++ "): " ++ show ha+ "signature hash algorithm disallowed by RFC policy ("+ ++ show rfc+ ++ "): "+ ++ show ha hashNotTypedBuilderMessage :: HashAlgorithm -> String hashNotTypedBuilderMessage ha =- "signature hash algorithm is not supported by typed builder API: " ++ show ha+ "signature hash algorithm is not supported by typed builder API: "+ ++ show ha --- | Add hashed subpackets to a builder--- Must be called before addUnhashedSubs-addHashedSubs :: HashedSubpackets v -> SigBuilder Hashed v algo -> SigBuilder Unhashed v algo-addHashedSubs (SubpacketList sps) builder = builder { sbHashedSubs = sps }+{- | Add hashed subpackets to a builder+Must be called before addUnhashedSubs+-}+addHashedSubs+ :: HashedSubpackets v+ -> SigBuilder Hashed v algo+ -> SigBuilder Unhashed v algo+addHashedSubs (SubpacketList sps) builder = builder {sbHashedSubs = sps} --- | Add unhashed subpackets to a builder--- Must be called after addHashedSubs-addUnhashedSubs :: UnhashedSubpackets v -> SigBuilder Unhashed v algo -> SigBuilder Unhashed v algo-addUnhashedSubs (SubpacketList sps) builder = builder { sbUnhashedSubs = sps }+{- | Add unhashed subpackets to a builder+Must be called after addHashedSubs+-}+addUnhashedSubs+ :: UnhashedSubpackets v+ -> SigBuilder Unhashed v algo+ -> SigBuilder Unhashed v algo+addUnhashedSubs (SubpacketList sps) builder = builder {sbUnhashedSubs = sps} -- | Build a v4 signature from a completed builder and MPI values-buildSigV4 ::- KnownPubKeyAlgorithm algo- => SigBuilder Unhashed V4Sig algo- -> Word16- -> NonEmpty MPI- -> SignaturePayload-buildSigV4 builder hashLeft mpis = SigV4- (sbSigType builder)- (sbPubKeyAlgo builder)- (sbHashAlgo builder)- (sbHashedSubs builder)- (sbUnhashedSubs builder)- hashLeft- mpis+buildSigV4+ :: KnownPubKeyAlgorithm algo+ => SigBuilder Unhashed V4Sig algo+ -> Word16+ -> NonEmpty MPI+ -> SignaturePayload+buildSigV4 builder hashLeft mpis =+ SigV4+ (sbSigType builder)+ (sbPubKeyAlgo builder)+ (sbHashAlgo builder)+ (sbHashedSubs builder)+ (sbUnhashedSubs builder)+ hashLeft+ mpis -- | Build a v6 signature from a completed builder and MPI values-buildSigV6 ::- KnownPubKeyAlgorithm algo- => SigBuilder Unhashed V6Sig algo- -> Word16- -> NonEmpty MPI- -> SignaturePayload+buildSigV6+ :: KnownPubKeyAlgorithm algo+ => SigBuilder Unhashed V6Sig algo+ -> Word16+ -> NonEmpty MPI+ -> SignaturePayload buildSigV6 builder hashLeft mpis =- SigV6- (sbSigType builder)- (sbPubKeyAlgo builder)- (sbHashAlgo builder)- (sbSalt builder)- (sbHashedSubs builder)- (sbUnhashedSubs builder)- hashLeft- mpis+ SigV6+ (sbSigType builder)+ (sbPubKeyAlgo builder)+ (sbHashAlgo builder)+ (sbSalt builder)+ (sbHashedSubs builder)+ (sbUnhashedSubs builder)+ hashLeft+ mpis --- | Convert a list to a hashed subpacket list--- Used to bridge between list-based and phantom-typed APIs+{- | Convert a list to a hashed subpacket list+Used to bridge between list-based and phantom-typed APIs+-} listToHashedSubs :: [SigSubPacket] -> HashedSubpackets v listToHashedSubs sps = SubpacketList sps --- | Convert a list to an unhashed subpacket list--- Used to bridge between list-based and phantom-typed APIs+{- | Convert a list to an unhashed subpacket list+Used to bridge between list-based and phantom-typed APIs+-} listToUnhashedSubs :: [SigSubPacket] -> UnhashedSubpackets v listToUnhashedSubs sps = SubpacketList sps
Codec/Encryption/OpenPGP/Types/Internal/Base.hs view
@@ -45,8 +45,14 @@ , V4Sig , V6Sig , ByteRange (..)+ , rangeOffset+ , rangeLength , WireRepSourceId (..) , WireRepRef (..)+ , wireRepSourceId+ , wireRepLength+ , wireRepName+ , wireRepWasOriginallyArmored , WireRepRefs , wireRepRef , namedWireRepRef@@ -81,6 +87,8 @@ , asSignaturePayloadOther , FutureVal (..) , SigSubPacket (..)+ , sspCriticality+ , sspPayload , SigSubPacketPayload (..) , ECCCurve (..) , IssuerFingerprintVersion (..)@@ -512,7 +520,7 @@ | ECDSA | ForbiddenElgamal | DH- | EdDSA+ | EdDSALegacy | X25519 | X448 | Ed25519@@ -543,7 +551,7 @@ fromFVal ECDSA = 19 fromFVal ForbiddenElgamal = 20 fromFVal DH = 21- fromFVal EdDSA = 22+ fromFVal EdDSALegacy = 22 fromFVal X25519 = 25 fromFVal X448 = 26 fromFVal Ed25519 = 27@@ -565,7 +573,7 @@ toFVal 19 = ECDSA toFVal 20 = ForbiddenElgamal toFVal 21 = DH- toFVal 22 = EdDSA+ toFVal 22 = EdDSALegacy toFVal 25 = X25519 toFVal 26 = X448 toFVal 27 = Ed25519@@ -591,7 +599,7 @@ pretty ECDSA = pretty "ECDSA" pretty ForbiddenElgamal = pretty "(forbidden) Elgamal" pretty DH = pretty "DH"- pretty EdDSA = pretty "EdDSA"+ pretty EdDSALegacy = pretty "EdDSA (legacy)" pretty X25519 = pretty "X25519" pretty X448 = pretty "X448" pretty Ed25519 = pretty "Ed25519"@@ -1443,7 +1451,7 @@ instance A.FromJSON IssuerFingerprintVersion where parseJSON (A.Number n) =- case round n of+ case round n :: Integer of 4 -> pure IssuerFingerprintV4 6 -> pure IssuerFingerprintV6 _ -> mzero
Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs view
@@ -122,6 +122,8 @@ | ECDHPrivateKey ECDSA_PrivateKey | ECDSAPrivateKey ECDSA_PrivateKey | EdDSAPrivateKey EdSigningCurve B.ByteString+ | Ed25519PrivateKey B.ByteString+ | Ed448PrivateKey B.ByteString | X25519PrivateKey B.ByteString | X448PrivateKey B.ByteString | MLKEMPrivateKey B.ByteString@@ -140,6 +142,10 @@ pretty (ECDSAPrivateKey p) = pretty "ECDSA" <+> pretty p pretty (EdDSAPrivateKey c bs) = pretty c <+> pretty (bsToHexUpper (BL.fromStrict bs))+ pretty (Ed25519PrivateKey bs) =+ pretty "Ed25519" <+> pretty (bsToHexUpper (BL.fromStrict bs))+ pretty (Ed448PrivateKey bs) =+ pretty "Ed448" <+> pretty (bsToHexUpper (BL.fromStrict bs)) pretty (X25519PrivateKey bs) = pretty "X25519" <+> pretty (bsToHexUpper (BL.fromStrict bs)) pretty (X448PrivateKey bs) = pretty "X448" <+> pretty (bsToHexUpper (BL.fromStrict bs)) pretty (MLKEMPrivateKey bs) =@@ -158,6 +164,8 @@ toJSON (ECDHPrivateKey k) = A.toJSON k toJSON (ECDSAPrivateKey k) = A.toJSON k toJSON (EdDSAPrivateKey c bs) = A.toJSON (c, B.unpack bs)+ toJSON (Ed25519PrivateKey bs) = A.toJSON (B.unpack bs)+ toJSON (Ed448PrivateKey bs) = A.toJSON (B.unpack bs) toJSON (X25519PrivateKey bs) = A.toJSON (B.unpack bs) toJSON (X448PrivateKey bs) = A.toJSON (B.unpack bs) toJSON (MLKEMPrivateKey bs) = A.toJSON (B.unpack bs)
Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs view
@@ -15,6 +15,7 @@ module Codec.Encryption.OpenPGP.Types.Internal.PacketClass where +import Control.Error.Util (hush) import Control.Lens (makeLenses) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL@@ -39,7 +40,7 @@ fromPktMaybe :: Pkt -> Maybe a fromPktEither :: Pkt -> Either String a - fromPktMaybe = either (const Nothing) Just . fromPktEither+ fromPktMaybe = hush . fromPktEither dynamicPacketCode = packetCode . packetType coercionError :: String -> Pkt -> Either String a
Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs view
@@ -16,6 +16,7 @@ module Codec.Encryption.OpenPGP.Types.Internal.Pkt where +import Control.Error.Util (hush) import Control.Lens (makeLenses) import Data.Aeson (object, (.=)) import qualified Data.Aeson as A@@ -666,7 +667,7 @@ pktToSomeKeyPktEither pkt = Left (NotAKeyPacket pkt) pktToSomeKeyPkt :: Pkt -> Maybe SomeKeyPkt-pktToSomeKeyPkt = either (const Nothing) Just . pktToSomeKeyPktEither+pktToSomeKeyPkt = hush . pktToSomeKeyPktEither pktToPublicKeyPktEither :: Pkt -> Either KeyPktCoercionError (KeyPkt 'PublicPkt)@@ -675,7 +676,7 @@ pktToPublicKeyPktEither pkt = Left (ExpectedPublicKeyPacket pkt) pktToPublicKeyPkt :: Pkt -> Maybe (KeyPkt 'PublicPkt)-pktToPublicKeyPkt = either (const Nothing) Just . pktToPublicKeyPktEither+pktToPublicKeyPkt = hush . pktToPublicKeyPktEither pktToSecretKeyPktEither :: Pkt -> Either KeyPktCoercionError (KeyPkt 'SecretPkt)@@ -684,7 +685,7 @@ pktToSecretKeyPktEither pkt = Left (ExpectedSecretKeyPacket pkt) pktToSecretKeyPkt :: Pkt -> Maybe (KeyPkt 'SecretPkt)-pktToSecretKeyPkt = either (const Nothing) Just . pktToSecretKeyPktEither+pktToSecretKeyPkt = hush . pktToSecretKeyPktEither {- | Convert secret key/subkey packets to their public-key packet forms. Non-secret packets are returned unchanged.
Codec/Encryption/OpenPGP/Types/Internal/TK.hs view
@@ -18,6 +18,7 @@ import Control.Arrow ((&&&)) import Control.Comonad (Comonad (..))+import Control.Error.Util (note) import Control.Lens ( folded , makeLenses@@ -34,13 +35,12 @@ import Data.Function (on) import qualified Data.HashMap.Lazy as HashMap import Data.IxSet.Typed (IxSet)-import qualified Data.IxSet.Typed as IxSet import Data.Kind (Type)-import Data.List (find, nub, sort, sortOn)+import Data.List (find, sortOn) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import Data.Ord (comparing)-import Data.Semigroup (Semigroup (..))+import qualified Data.Set as Set import Data.Text (Text) import Data.Typeable (Typeable) import Data.Word (Word8)@@ -92,7 +92,7 @@ -- | Move to the next packet in the sequence zMoveNext :: PacketZipper a -> Maybe (PacketZipper a)-zMoveNext (PacketZipper before current []) = Nothing+zMoveNext (PacketZipper _before _current []) = Nothing zMoveNext (PacketZipper before current (x : xs)) = Just (PacketZipper (before ++ [current]) x xs) @@ -311,7 +311,9 @@ a <> b = TKUnknown (_tkuKey a)- (nub . sort $ _tkuRevs a ++ _tkuRevs b)+ ( Set.toList $+ Set.union (Set.fromList (_tkuRevs a)) (Set.fromList (_tkuRevs b))+ ) ((kvmerge `on` _tkuUIDs) a b) ((kvmerge `on` _tkuUAts) a b) ((ukvmerge `on` _tkuSubs) a b)@@ -321,13 +323,15 @@ ukvmerge x y = HashMap.toList (HashMap.unionWith nsa (HashMap.fromList x) (HashMap.fromList y))- nsa x y = nub . sort $ x ++ y+ nsa x y = Set.toList $ Set.union (Set.fromList x) (Set.fromList y) instance Semigroup (TK k) where a <> b = TK (_tkPrimaryKey a)- (nub . sort $ _tkRevs a ++ _tkRevs b)+ ( Set.toList $+ Set.union (Set.fromList (_tkRevs a)) (Set.fromList (_tkRevs b))+ ) ((kvmerge `on` _tkUIDs) a b) ((kvmerge `on` _tkUAts) a b) ((ukvmerge `on` _tkSubs) a b)@@ -337,7 +341,7 @@ ukvmerge x y = HashMap.toList (HashMap.unionWith nsa (HashMap.fromList x) (HashMap.fromList y))- nsa x y = nub . sort $ x ++ y+ nsa x y = Set.toList $ Set.union (Set.fromList x) (Set.fromList y) instance Semigroup SomeTK where SomePublicTK a <> SomePublicTK b = SomePublicTK (a <> b)@@ -653,10 +657,10 @@ refs = _tkPackets tkWithRefs (pkp, mska) = _tkuKey tk primaryPkt = someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)- zipper <- case zFromList refs of- Just z -> Right z- Nothing ->- Left "no packet references available for TKUnknown structuring"+ zipper <-+ note+ "no packet references available for TKUnknown structuring"+ (zFromList refs) (primaryRef, z1') <- consumePktZ "primary key packet" primaryPkt zipper -- Move past the primary key to process its signatures and following packets
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -18,6 +18,7 @@ , PKESKRecipientKey (..) , PKESKAttemptFailureKind (..) , PKESKAttemptFailure (..)+ , DecryptStructureError (..) , DecryptOutcome (..) , DecryptReport (..) , DecryptSessionKeyResolutionReport (..)@@ -25,6 +26,10 @@ , PKESKResolverAttempt (..) , PKESKResolverAttemptAction (..) , decryptSEIPDv2Payload+ , renderDecryptStructureError+ , renderDecryptOutcome+ , renderDecryptSessionKeyResolutionReport+ , renderDecryptReport ) where import Control.Applicative ((<|>))@@ -37,7 +42,6 @@ import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Control.Monad.Trans.Resource (MonadResource, MonadThrow) import qualified Crypto.Error as CE-import qualified Crypto.Hash as CH import qualified Crypto.Hash.Algorithms as CHA import Crypto.KDF.HKDF (expand, extract) import Crypto.Number.Serialize (i2osp, os2ip)@@ -50,8 +54,7 @@ import qualified Crypto.PubKey.RSA.Types as RSATypes import Data.Bifunctor (first) import Data.Binary (get)-import Data.Binary.Put (putWord64be, runPut)-import Data.Bits (countLeadingZeros, shiftL, shiftR, xor)+import Data.Bits (countLeadingZeros, shiftL) import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL@@ -70,21 +73,28 @@ import Data.List (intercalate, nub) import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (catMaybes, isNothing, mapMaybe)-import Data.Word (Word16, Word64, Word8)+import Data.Word (Word64, Word8) import qualified "crypton" Crypto.Cipher.Types as CCT import Codec.Encryption.OpenPGP.BlockCipher- ( keySize+ ( CipherError (..)+ , keySize , renderCipherError ) import Codec.Encryption.OpenPGP.CFB- ( calculateMDC- , decryptOpenPGPCfb+ ( decryptOpenPGPCfb , decryptPreservingNonce- , validateSEIPD1MDC ) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)-import Codec.Encryption.OpenPGP.Internal (leftPadTo)+import Codec.Encryption.OpenPGP.Internal+ ( checksum16+ , checksum16Bytes+ , chunksOf8+ , edPointBytes+ , encodeWord64be+ , leftPadTo+ , xorBS+ ) import Codec.Encryption.OpenPGP.Internal.CryptoAES ( withAESCipher )@@ -93,12 +103,6 @@ , deriveECDHKek , normalizeMontgomeryPublic )-import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2- ( aeadModeAndNonceSizeForSEIPDv2- , decryptSKESK6SessionKey- , deriveSKESK6KEK- , seipdv2SymmetricKeySize- ) import Codec.Encryption.OpenPGP.Internal.RFC7253OCB ( decryptWithOCBRFC7253With )@@ -116,6 +120,19 @@ , skesk2SessionKey , string2Key )+import Codec.Encryption.OpenPGP.SEIPDv1+ ( calculateMDC+ , renderMDCFailure+ , validateSEIPD1MDC+ )+import Codec.Encryption.OpenPGP.SEIPDv2+ ( SEIPDv2Failure (..)+ , aeadModeAndNonceSizeForSEIPDv2+ , decryptSKESK6SessionKey+ , deriveSKESK6KEK+ , renderSEIPDv2Failure+ , seipdv2SymmetricKeySize+ ) import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Compression (conduitDecompress)@@ -149,7 +166,7 @@ -> DecryptStreamState 'FinishedDecryptPhase MalformedDecryptState :: RecursorState- -> String+ -> DecryptStructureError -> DecryptStreamState 'MalformedDecryptPhase data SomeDecryptStreamState where@@ -206,6 +223,13 @@ | ResolverInvalidResponse String deriving (Eq, Show) +data PKESKX25519V3UnwrapError+ = PKESKX25519V3ParseError String+ | PKESKX25519V3UnwrapError CipherError+ | PKESKX25519V3KeySizeError CipherError+ | PKESKX25519V3KeyLengthMismatch SymmetricAlgorithm Int Int+ deriving (Eq, Show)+ data PKESKResolveRequest = PKESKResolveRequest { reqPKESK :: PKESKPayload@@ -282,6 +306,13 @@ (outcome, pkts) \<- runConduit $ source .| fuseBoth (conduitDecrypt opts) CL.consume @ -}+data DecryptStructureError+ = DecryptStructureESKSEIPDMismatch+ | DecryptStructureESKOrder+ | DecryptStructureTrailingData+ | DecryptStructureGeneric String+ deriving (Eq, Show)+ data DecryptOutcome = {- | The integrity-terminating marker (MDC or SEIPD v2 final AEAD tag) was seen and no further packets arrived. The message was@@ -298,23 +329,10 @@ packets were forwarded downstream unchanged. -} DecryptTrailingData- | {- | A structural packet-sequencing violation was detected. The- 'String' describes the specific violation:-- * PKESK version does not match the SEIPD version (e.g. a v6 PKESK- preceding a SEIPDv1 payload, or a v4 SKESK preceding a SEIPDv2- payload).-- * ESK packets arrived in the wrong order relative to the encrypted- data packet (e.g. a literal-data packet appeared between a PKESK- and the SEIPD it was intended to protect).-- * A packet arrived after the message integrity boundary (trailing- data). Under 'defaultDecryptPolicy' this is reported here; under- 'lenientDecryptPolicy' it is reported as 'DecryptTrailingData'- instead.+ | {- | A structural packet-sequencing violation was detected. Use+ 'renderDecryptStructureError' to obtain a human-readable description. -}- DecryptMalformedStructure String+ DecryptMalformedStructure DecryptStructureError deriving (Eq, Show) data DecryptSessionKeyResolutionPath@@ -341,8 +359,9 @@ data DecryptSessionKeyResolutionReport = DecryptSessionKeyResolutionReport { decryptSessionResolutionPath :: DecryptSessionKeyResolutionPath- , decryptSessionResolutionSKESKErrors :: [String]- , decryptSessionResolutionPKESKErrors :: [String]+ , decryptSessionResolutionSKESKErrors+ :: [SKESKSessionKeyResolutionError]+ , decryptSessionResolutionPKESKErrors :: [PKESKAttemptFailure] , decryptSessionResolutionResolverAttempts :: [PKESKResolverAttempt] }@@ -359,16 +378,16 @@ -- | AEAD decryption context (Reader monad eliminates parameter threading) data AEADDecryptContext cipher = AEADDecryptContext- { aeadMode :: CCT.AEADMode- , aeadInfo :: B.ByteString- , aeadChunkSize :: Word8- , aeadNoncePrefix :: B.ByteString- , aeadCipher :: cipher+ { _aeadMode :: CCT.AEADMode+ , _aeadInfo :: B.ByteString+ , _aeadChunkSize :: Word8+ , _aeadNoncePrefix :: B.ByteString+ , _aeadCipher :: cipher } -- | ReaderT wrapper for AEAD decryption computations type AEADDecrypt cipher =- ReaderT (AEADDecryptContext cipher) (Either String)+ ReaderT (AEADDecryptContext cipher) (Either SEIPDv2Failure) conduitDecrypt :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m)@@ -677,7 +696,7 @@ ( SomeDecryptStreamState ( MalformedDecryptState s- "Malformed encrypted packet sequence: ESK packets must immediately precede encrypted data"+ DecryptStructureESKOrder ) , [] )@@ -717,9 +736,7 @@ ( SomeDecryptStreamState ( MalformedDecryptState s- ( "ESK/payload version mismatch: ESK packets present but none are version-aligned with "- ++ "legacy SED payload"- )+ DecryptStructureESKSEIPDMismatch ) , [] )@@ -729,6 +746,8 @@ "Received unauthenticated SED (Symmetrically Encrypted Data) packet; \ \RFC9580 policy requires integrity-protected SEIPD. \ \Use lenientDecryptPolicy to permit legacy messages."+ when (_depth s > 0) $+ fail "recursive encrypted/compressed messages are not allowed" (symalgo, sessionKey) <- resolveSessionKey s@@ -757,9 +776,7 @@ ( SomeDecryptStreamState ( MalformedDecryptState s- ( "ESK/payload version mismatch: ESK packets present but none are version-aligned with "- ++ "SEIPDv1 payload"- )+ DecryptStructureESKSEIPDMismatch ) , [] )@@ -767,6 +784,8 @@ when (not (decryptAllowSEIPDv1 dp)) $ fail "Received SEIPDv1 packet; decrypt policy requires SEIPDv2 only."+ when (_depth s > 0) $+ fail "recursive encrypted/compressed messages are not allowed" (symalgo, sessionKey) <- resolveSessionKey s@@ -796,15 +815,15 @@ ( SomeDecryptStreamState ( MalformedDecryptState s- ( "ESK/payload version mismatch: ESK packets present but none are version-aligned with "- ++ "SEIPDv2 payload"- )+ DecryptStructureESKSEIPDMismatch ) , [] ) else do checkDecryptSymmetricAlgo dp sa checkDecryptAEADAlgo dp aa+ when (_depth s > 0) $+ fail "recursive encrypted/compressed messages are not allowed" (_, sessionKey) <- resolveSessionKey s@@ -862,14 +881,14 @@ return (SomeDecryptStreamState (ActiveDecryptState s), []) p -> return (SomeDecryptStreamState (ActiveDecryptState s), [p])- push i (FinishedDecryptState s hadTrailing) =+ push i (FinishedDecryptState s _hadTrailing) = if decryptRejectTrailingData (_decryptPolicy s) then return ( SomeDecryptStreamState ( MalformedDecryptState s- "packet received after message integrity boundary"+ DecryptStructureTrailingData ) , [] )@@ -932,9 +951,11 @@ checkInnerOutcome _ DecryptClean = pure () checkInnerOutcome _ DecryptTrailingData = pure () checkInnerOutcome NoIntegrityMarker DecryptTruncated = pure ()-checkInnerOutcome _ (DecryptMalformedStructure reason) =+checkInnerOutcome _ (DecryptMalformedStructure err) = fail- ("Inner encrypted payload had malformed structure: " ++ reason)+ ( "Inner encrypted payload had malformed structure: "+ ++ renderDecryptStructureError err+ ) decryptSEDP :: (MonadFail m, MonadIO m, MonadThrow m, MonadUnliftIO m)@@ -981,7 +1002,7 @@ Right x -> pure x decryptedWithoutMDC <- case validateSEIPD1MDC nonce decrypted of- Left err -> fail err+ Left err -> fail (renderMDCFailure err) Right x -> pure x (innerOutcome, pkts) <- decryptInnerPackets@@ -1018,7 +1039,7 @@ (BL.toStrict bs) sessionKey case decrypted of- Left e -> fail e+ Left e -> fail (renderSEIPDv2Failure e) Right cleartext -> do (innerOutcome, pkts) <- decryptInnerPackets@@ -1062,18 +1083,17 @@ -> Salt -> B.ByteString -> SessionKey- -> Either String B.ByteString+ -> Either SEIPDv2Failure B.ByteString decryptSEIPDv2Payload symalgo aeadalgo chunkSize salt encrypted (SessionKey sessionKey) = do when (chunkSize > 16) $- Left "SEIPD v2 chunk size octet must be between 0 and 16"+ Left SEIPDv2InvalidChunkSize (mode, nonceSize) <- aeadModeAndNonceSize aeadalgo keyLen <- symKeySize symalgo let outputLen = keyLen + nonceSize - 8 when (B.length (unSalt salt) /= 32) $- Left "SEIPD v2 salt must be exactly 32 octets"+ Left SEIPDv2InvalidSaltLength when (B.length encrypted < 32) $- Left- "SEIPD v2 ciphertext must include at least one chunk tag and a final tag"+ Left SEIPDv2CiphertextTooShort let info = B.pack [0xd2, 2, fromFVal symalgo, fromFVal aeadalgo, chunkSize]@@ -1083,6 +1103,7 @@ noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm) decryptSEIPDv2WithKey symalgo+ aeadalgo mode chunkSize info@@ -1092,30 +1113,33 @@ decryptSEIPDv2WithKey :: SymmetricAlgorithm+ -> AEADAlgorithm -> CCT.AEADMode -> Word8 -> B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString- -> Either String B.ByteString-decryptSEIPDv2WithKey symalgo mode chunkSize info noncePrefix sessionKey encrypted =+ -> Either SEIPDv2Failure B.ByteString+decryptSEIPDv2WithKey symalgo aeadalgo mode chunkSize info noncePrefix sessionKey encrypted = withAESCipher- "SEIPD v2 decrypt currently supports AES-128/192/256 only"+ SEIPDv2CipherInitFailed+ (SEIPDv2UnsupportedSymmetricAlgorithm symalgo) symalgo sessionKey- (decryptChunks mode info chunkSize noncePrefix encrypted)+ (decryptChunks aeadalgo mode info chunkSize noncePrefix encrypted) decryptChunks :: CCT.BlockCipher cipher- => CCT.AEADMode+ => AEADAlgorithm+ -> CCT.AEADMode -> B.ByteString -> Word8 -> B.ByteString -> B.ByteString -> cipher- -> Either String B.ByteString-decryptChunks mode info chunkSize noncePrefix encrypted cipher =+ -> Either SEIPDv2Failure B.ByteString+decryptChunks aeadalgo mode info chunkSize noncePrefix encrypted cipher = let ctx = AEADDecryptContext mode info chunkSize noncePrefix cipher in runReaderT decryptChunksWithReader ctx where@@ -1129,8 +1153,7 @@ go idx remaining acc totalPlain | B.length remaining < 2 * tagLen = lift $- Left- "SEIPD v2 ciphertext is too short for chunk and final authentication tags"+ Left SEIPDv2CiphertextTooShort | otherwise = do let hasMoreChunks = B.length remaining > chunkLen + 2 * tagLen currentChunkLen =@@ -1139,7 +1162,7 @@ else B.length remaining - 2 * tagLen when (currentChunkLen < 0) $ lift $- Left "SEIPD v2 malformed chunk lengths"+ Left SEIPDv2MalformedChunkLengths let (chunkCiphertext, r1) = B.splitAt currentChunkLen remaining (chunkTag, r2) = B.splitAt tagLen r1 plainChunk <-@@ -1154,9 +1177,9 @@ else do when (B.length r2 /= tagLen) $ lift $- Left "SEIPD v2 missing final authentication tag"+ Left SEIPDv2MissingFinalTag verifyFinalTagWithContext- (idx + 1)+ (fromIntegral (idx + 1)) (totalPlain + B.length plainChunk) r2 return (B.concat (reverse (plainChunk : acc)))@@ -1167,14 +1190,14 @@ then lift $ decryptWithOCBRFC7253With- (\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed")+ (\_ _ _ _ _ _ -> SEIPDv2ChunkAuthFailed aeadalgo idx) cipher'- (noncePrefix' <> encodeWord64be idx)+ (noncePrefix' <> encodeWord64be (fromIntegral idx)) info chunkCiphertext (mkAuthTag chunkTag) else do- aead <- initAEADWithContext idx+ aead <- initAEADWithContext (fromIntegral idx) let mPlain = CCT.aeadSimpleDecrypt aead@@ -1182,7 +1205,7 @@ chunkCiphertext (mkAuthTag chunkTag) case mPlain of- Nothing -> lift $ Left "SEIPD v2 chunk authentication failed"+ Nothing -> lift $ Left (SEIPDv2ChunkAuthFailed aeadalgo idx) Just p -> return p verifyFinalTagWithContext idx totalPlain finalTag = do@@ -1192,7 +1215,7 @@ plain <- lift $ decryptWithOCBRFC7253With- (\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed")+ (\_ _ _ _ _ _ -> SEIPDv2FinalTagFailed aeadalgo) cipher' (noncePrefix' <> encodeWord64be idx) (info <> encodeWord64be (fromIntegral totalPlain))@@ -1202,7 +1225,7 @@ then return () else lift $- Left "SEIPD v2 final authentication tag verification failed"+ Left (SEIPDv2FinalTagFailed aeadalgo) else do aead <- initAEADWithContext idx let mEmpty =@@ -1215,27 +1238,21 @@ Just p | B.null p -> return () _ -> lift $- Left "SEIPD v2 final authentication tag verification failed"+ Left (SEIPDv2FinalTagFailed aeadalgo) initAEADWithContext idx = do AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask- lift $- first show . CE.eitherCryptoError $- CCT.aeadInit mode' cipher' (noncePrefix' <> encodeWord64be idx)+ lift+ $ first SEIPDv2CipherInitFailed+ . CE.eitherCryptoError+ $ CCT.aeadInit mode' cipher' (noncePrefix' <> encodeWord64be idx) aeadModeAndNonceSize- :: AEADAlgorithm -> Either String (CCT.AEADMode, Int)-aeadModeAndNonceSize =- aeadModeAndNonceSizeForSEIPDv2- "Unknown AEAD algorithm for SEIPD v2 decrypt"--symKeySize :: SymmetricAlgorithm -> Either String Int-symKeySize =- seipdv2SymmetricKeySize- "SEIPD v2 decrypt currently supports AES-128/192/256 only"+ :: AEADAlgorithm -> Either SEIPDv2Failure (CCT.AEADMode, Int)+aeadModeAndNonceSize = aeadModeAndNonceSizeForSEIPDv2 -encodeWord64be :: Word64 -> B.ByteString-encodeWord64be = BL.toStrict . runPut . putWord64be+symKeySize :: SymmetricAlgorithm -> Either SEIPDv2Failure Int+symKeySize = seipdv2SymmetricKeySize mkAuthTag :: B.ByteString -> CCT.AuthTag mkAuthTag = CCT.AuthTag . BA.convert@@ -1287,14 +1304,6 @@ ClassifiedSKESKPayloadV4 _ -> Nothing ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ aa _ _ _ _) -> Just aa -resolveSKESKSessionKey- :: BL.ByteString -> SKESKPayload -> Either String B.ByteString-resolveSKESKSessionKey passphrase payload =- first renderSKESKSessionKeyResolutionError $- resolveSKESKSessionKeyTyped- passphrase- (classifySKESKPayload payload)- data SKESKSessionKeyResolutionError = SKESKSessionKeyS2KError S2KError | SKESKSessionKeyOtherError String@@ -1305,6 +1314,64 @@ renderSKESKSessionKeyResolutionError (SKESKSessionKeyS2KError err) = renderS2KError err renderSKESKSessionKeyResolutionError (SKESKSessionKeyOtherError err) = err +renderPKESKX25519V3UnwrapError+ :: PKESKX25519V3UnwrapError -> String+renderPKESKX25519V3UnwrapError (PKESKX25519V3ParseError err) = err+renderPKESKX25519V3UnwrapError (PKESKX25519V3UnwrapError err) = renderCipherError err+renderPKESKX25519V3UnwrapError (PKESKX25519V3KeySizeError err) = renderCipherError err+renderPKESKX25519V3UnwrapError (PKESKX25519V3KeyLengthMismatch algo expected actual) =+ "X25519 PKESKv3 unwrapped session key length mismatch for "+ ++ show algo+ ++ ": expected "+ ++ show expected+ ++ ", got "+ ++ show actual++renderDecryptStructureError :: DecryptStructureError -> String+renderDecryptStructureError DecryptStructureESKSEIPDMismatch =+ "ESK/payload version mismatch"+renderDecryptStructureError DecryptStructureESKOrder =+ "Malformed encrypted packet sequence: ESK packets must immediately precede encrypted data"+renderDecryptStructureError DecryptStructureTrailingData =+ "packet received after message integrity boundary"+renderDecryptStructureError (DecryptStructureGeneric msg) = msg++renderDecryptOutcome :: DecryptOutcome -> String+renderDecryptOutcome DecryptClean = "clean"+renderDecryptOutcome DecryptTruncated = "truncated"+renderDecryptOutcome DecryptTrailingData = "trailing data"+renderDecryptOutcome (DecryptMalformedStructure err) =+ "malformed structure: " ++ renderDecryptStructureError err++renderDecryptSessionKeyResolutionReport+ :: DecryptSessionKeyResolutionReport -> String+renderDecryptSessionKeyResolutionReport report =+ "session key resolution: "+ ++ show (decryptSessionResolutionPath report)+ ++ "; SKESK errors: "+ ++ unwords+ ( map+ renderSKESKSessionKeyResolutionError+ (decryptSessionResolutionSKESKErrors report)+ )+ ++ "; PKESK errors: "+ ++ unwords+ ( map+ pkeskAttemptFailureReason+ (decryptSessionResolutionPKESKErrors report)+ )++renderDecryptReport :: DecryptReport -> String+renderDecryptReport report =+ "outcome: "+ ++ renderDecryptOutcome (decryptReportOutcome report)+ ++ "; resolutions: "+ ++ unwords+ ( map+ renderDecryptSessionKeyResolutionReport+ (decryptReportSessionKeyResolutions report)+ )+ resolveSKESKSessionKeyTyped :: BL.ByteString -> ClassifiedSKESKPayload@@ -1327,9 +1394,11 @@ ikm <- first SKESKSessionKeyS2KError (string2Key s2k keyLen passphrase) kek <-- first SKESKSessionKeyOtherError (deriveSKESK6KEK sa aead ikm)+ first+ (SKESKSessionKeyOtherError . renderSEIPDv2Failure)+ (deriveSKESK6KEK sa aead ikm) first- SKESKSessionKeyOtherError+ (SKESKSessionKeyOtherError . renderSEIPDv2Failure) ( decryptSKESK6SessionKey sa aead@@ -1399,7 +1468,7 @@ => BL.ByteString -> [SKESKPayload] -> [PKESKPayload]- -> [String]+ -> [SKESKSessionKeyResolutionError] -> m (SymmetricAlgorithm, SessionKey) resolveSKESKCandidates _ [] pkesks skeskErrs = resolvePKESKCandidates pkesks skeskErrs [] []@@ -1410,7 +1479,10 @@ passphrase rest pkesks- ((skeskErrPrefix skesk ++ err) : skeskErrs)+ ( SKESKSessionKeyOtherError+ (skeskErrPrefix skesk ++ renderSKESKSessionKeyResolutionError err)+ : skeskErrs+ ) Right resolved -> do emitResolutionReport (mkResolutionReport DecryptResolvedViaSKESK skeskErrs [] [])@@ -1419,22 +1491,33 @@ resolveSKESKCandidate :: BL.ByteString -> SKESKPayload- -> Either String (SymmetricAlgorithm, SessionKey)+ -> Either+ SKESKSessionKeyResolutionError+ (SymmetricAlgorithm, SessionKey) resolveSKESKCandidate passphrase skesk = do let skeskSymAlgo = skeskPayloadSymmetricAlgorithm skesk expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor- sessionKeyBytes <- resolveSKESKSessionKey passphrase skesk+ sessionKeyBytes <-+ resolveSKESKSessionKeyTyped+ passphrase+ (classifySKESKPayload skesk) case expectedSymAlgo of Just expected | expected /= skeskSymAlgo ->- Left "SKESK/encrypted-payload symmetric algorithm mismatch"+ Left+ ( SKESKSessionKeyOtherError+ "SKESK/encrypted-payload symmetric algorithm mismatch"+ ) _ -> case ( payloadExpectedAEADAlgorithm payloadFlavor , skeskPayloadAEADAlgorithm skesk ) of (Just expectedAEAD, Just skeskAEAD) | expectedAEAD /= skeskAEAD ->- Left "SKESK/encrypted-payload AEAD algorithm mismatch"+ Left+ ( SKESKSessionKeyOtherError+ "SKESK/encrypted-payload AEAD algorithm mismatch"+ ) _ -> Right (skeskSymAlgo, SessionKey sessionKeyBytes) skeskErrPrefix skesk = "[" ++ describeSKESK skesk ++ "] "@@ -1442,24 +1525,17 @@ resolvePKESKCandidates :: (MonadFail m, MonadIO m) => [PKESKPayload]- -> [String]- -> [String]+ -> [SKESKSessionKeyResolutionError]+ -> [PKESKAttemptFailure] -> [PKESKResolverAttempt] -> m (SymmetricAlgorithm, SessionKey) resolvePKESKCandidates [] [] [] _ = fail "Encrypted data packet has no usable preceding SKESK or PKESK packet"- resolvePKESKCandidates [] skeskErrs [] _ =- fail- ( "Encrypted data packet has no usable preceding SKESK or PKESK packet; "- ++ "candidate errors: "- ++ unwords (reverse skeskErrs)- ) resolvePKESKCandidates [] skeskErrs pkeskErrs resolverAttempts = if allowManualPKESKPrompt then do let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor- errs = skeskErrs ++ pkeskErrs encodedSessionKey <- BL.toStrict <$> liftIO@@ -1471,7 +1547,12 @@ fail ( "Encrypted data packet has no usable preceding SKESK or PKESK packet; " ++ "candidate errors: "- ++ unwords (reverse errs)+ ++ unwords+ ( reverse+ ( map renderSKESKSessionKeyResolutionError skeskErrs+ ++ map pkeskAttemptFailureReason pkeskErrs+ )+ ) ++ "; manual input failed: " ++ manualErr )@@ -1488,7 +1569,12 @@ fail ( "Encrypted data packet has no usable preceding SKESK or PKESK packet; " ++ "candidate errors: "- ++ unwords (reverse (skeskErrs ++ pkeskErrs))+ ++ unwords+ ( reverse+ ( map renderSKESKSessionKeyResolutionError skeskErrs+ ++ map pkeskAttemptFailureReason pkeskErrs+ )+ ) ) resolvePKESKCandidates (pkesk : rest) skeskErrs pkeskErrs resolverAttempts = do let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor@@ -1513,12 +1599,24 @@ let resolverAttempts' = resolverAttemptsAcc ++ newAttempts terminalError = case reverse previousFailures of- (latestFailure : _) -> errPrefix ++ pkeskAttemptFailureReason latestFailure+ (latestFailure : _) ->+ PKESKAttemptFailure+ { pkeskAttemptFailureKeyContext =+ pkeskAttemptFailureKeyContext latestFailure+ , pkeskAttemptFailureKind = PKESKAttemptUnwrapFailed+ , pkeskAttemptFailureReason =+ errPrefix ++ pkeskAttemptFailureReason latestFailure+ } [] ->- errPrefix- ++ "no matching key context (callback probes: "- ++ callbackProbeSummary- ++ ")"+ PKESKAttemptFailure+ { pkeskAttemptFailureKeyContext = Nothing+ , pkeskAttemptFailureKind = PKESKAttemptUnwrapFailed+ , pkeskAttemptFailureReason =+ errPrefix+ ++ "no matching key context (callback probes: "+ ++ callbackProbeSummary+ ++ ")"+ } in resolvePKESKCandidates rest skeskErrs@@ -1529,10 +1627,23 @@ let resolverAttempts' = resolverAttemptsAcc ++ newAttempts terminalError = case reverse previousFailures of- (latestFailure : _) -> errPrefix ++ pkeskAttemptFailureReason latestFailure+ (latestFailure : _) ->+ PKESKAttemptFailure+ { pkeskAttemptFailureKeyContext =+ pkeskAttemptFailureKeyContext latestFailure+ , pkeskAttemptFailureKind = PKESKAttemptUnwrapFailed+ , pkeskAttemptFailureReason =+ errPrefix ++ pkeskAttemptFailureReason latestFailure+ } [] ->- errPrefix- ++ "key context callback repeated without yielding a usable key"+ PKESKAttemptFailure+ { pkeskAttemptFailureKeyContext =+ recipientKeyContext keyInfo+ , pkeskAttemptFailureKind = PKESKAttemptUnwrapFailed+ , pkeskAttemptFailureReason =+ errPrefix+ ++ "key context callback repeated without yielding a usable key"+ } in resolvePKESKCandidates rest skeskErrs@@ -1587,8 +1698,8 @@ mkResolutionReport :: DecryptSessionKeyResolutionPath- -> [String]- -> [String]+ -> [SKESKSessionKeyResolutionError]+ -> [PKESKAttemptFailure] -> [PKESKResolverAttempt] -> DecryptSessionKeyResolutionReport mkResolutionReport path skeskErrs pkeskErrs resolverAttempts =@@ -2146,7 +2257,7 @@ (material : _) -> pure (encodeLegacyECDHSessionMaterial material) [] -> case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of- Left err -> fail err+ Left err -> fail (renderCipherError err) Right _ -> fail "legacy ECDH wrapped session key decrypted but decoded session material is malformed"@@ -2191,7 +2302,7 @@ kek <- either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param) case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of- Left err -> fail err+ Left err -> fail (renderCipherError err) Right decoded -> pure decoded EdDSAPubKey EdSigningCurve25519 _ -> do recipientSecretRaw <-@@ -2214,9 +2325,13 @@ fail pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA)- let rfc6637Result =+ let rfc6637Result :: Either CipherError B.ByteString+ rfc6637Result = do- kek <- deriveECDHKek kdfHA kdfSA sharedSecret param+ kek <-+ first+ CipherOperationFailed+ (deriveECDHKek kdfHA kdfSA sharedSecret param) aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes case rfc6637Result of Right decoded -> pure decoded@@ -2229,9 +2344,9 @@ Left x25519Err -> fail ( "ECDH PKESKv6 Curve25519 unwrap failed (RFC6637: "- ++ rfc6637Err+ ++ renderCipherError rfc6637Err ++ ", X25519: "- ++ x25519Err+ ++ renderCipherError x25519Err ++ ")" ) EdDSAPubKey EdSigningCurve448 _ ->@@ -2281,7 +2396,7 @@ let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString kek = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret case aesKeyUnwrapRFC3394 AES128 kek wrappedSessionKeyBytes of- Left err -> fail err+ Left err -> fail (renderCipherError err) Right decoded -> pure decoded extractX25519RecipientPublic recipientPKP =@@ -2342,7 +2457,7 @@ let sharedSecret = BA.convert (C448.dh ephPub recipientSecret) :: B.ByteString kek = deriveX448Kek ephBytes recipientPublicRaw sharedSecret case aesKeyUnwrapRFC3394 AES256 kek wrappedSessionKeyBytes of- Left err -> fail err+ Left err -> fail (renderCipherError err) Right decoded -> pure decoded x25519UnwrapV3 recipientCtx mpis recipientSecretRaw = do@@ -2374,17 +2489,21 @@ -- RFC9580 interpretation: eskBytes = algo_byte || AES-KW(raw_session_key) rfc9580Result = do (sessionAlgorithm, wrappedKey) <-- parsePKESKv3X25519EskBytes eskBytes- rawKey <- aesKeyUnwrapRFC3394 AES128 kek9580 wrappedKey- expectedLen <- symmetricKeyLength sessionAlgorithm+ first+ PKESKX25519V3ParseError+ (parsePKESKv3X25519EskBytes eskBytes)+ rawKey <-+ first+ PKESKX25519V3UnwrapError+ (aesKeyUnwrapRFC3394 AES128 kek9580 wrappedKey)+ expectedLen <-+ first PKESKX25519V3KeySizeError (keySize sessionAlgorithm) when (B.length rawKey /= expectedLen) $ Left- ( "X25519 PKESKv3 unwrapped session key length mismatch for "- ++ show sessionAlgorithm- ++ ": expected "- ++ show expectedLen- ++ ", got "- ++ show (B.length rawKey)+ ( PKESKX25519V3KeyLengthMismatch+ sessionAlgorithm+ expectedLen+ (B.length rawKey) ) Right ( B.singleton (fromIntegral (fromFVal sessionAlgorithm))@@ -2393,7 +2512,7 @@ ) case rfc9580Result of Right result -> pure result- Left rfc9580Err ->+ Left err -> -- Fallback: legacy ECDH interpretation where the full eskBytes is -- AES-KW(algo || key || checksum || padding). Try with the RFC9580 -- X25519 KEK and, when available, the RFC6637 ECDH KEK derived from@@ -2420,7 +2539,7 @@ [] -> fail ( "X25519 PKESKv3 unwrap failed (RFC9580: "- ++ rfc9580Err+ ++ renderPKESKX25519V3UnwrapError err ++ "; legacy ECDH-style fallback also failed)" ) @@ -2454,10 +2573,6 @@ ) = sizeField -edPointBytes :: EdPoint -> B.ByteString-edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x-edPointBytes (NativeEPoint (EPoint x)) = i2osp x- parseECDHPKESKMPIs :: NonEmpty MPI -> Either String (B.ByteString, B.ByteString) parseECDHPKESKMPIs (ephemeralMPI :| [wrappedMPI]) =@@ -2472,17 +2587,15 @@ } deriving (Eq) -newtype LegacyECDHSessionKey = LegacyECDHSessionKey {unLegacyECDHSessionKey :: B.ByteString}+newtype LegacyECDHSessionKey = LegacyECDHSessionKey B.ByteString -newtype LegacyECDHSessionPadding = LegacyECDHSessionPadding- {unLegacyECDHSessionPadding :: B.ByteString}+newtype LegacyECDHSessionPadding = LegacyECDHSessionPadding B.ByteString data LegacyECDHDecodedSessionMaterial = LegacyECDHDecodedSessionMaterial- { legacyECDHSessionAlgorithm :: SymmetricAlgorithm- , legacyECDHSessionKey :: LegacyECDHSessionKey- , legacyECDHSessionPadding :: LegacyECDHSessionPadding- }+ SymmetricAlgorithm+ LegacyECDHSessionKey+ LegacyECDHSessionPadding candidateWrappedRFC3394CiphertextsForLegacyECDH :: LegacyECDHWrappedRFC3394Ciphertext@@ -2519,7 +2632,8 @@ when (B.length decoded < 3) $ Left "legacy ECDH decoded session material is too short" let sessionAlgorithm = toFVal (B.head decoded)- sessionKeyLen <- symmetricKeyLength sessionAlgorithm+ sessionKeyLen <-+ first renderCipherError (keySize sessionAlgorithm) let payload = B.tail decoded when (B.length payload < sessionKeyLen + 2) $ Left@@ -2732,10 +2846,11 @@ :: SymmetricAlgorithm -> B.ByteString -> B.ByteString- -> Either String B.ByteString+ -> Either CipherError B.ByteString aesKeyUnwrapRFC3394 sa kek wrapped = withAESCipher- "ECDH PKESK currently supports AES KEK algorithms only"+ (\err -> CipherInitFailed sa (show err))+ (UnsupportedAlgorithm sa) sa kek unwrapWithCipher@@ -2743,19 +2858,26 @@ unwrapWithCipher :: CCT.BlockCipher cipher => cipher- -> Either String B.ByteString+ -> Either CipherError B.ByteString unwrapWithCipher cipher = do when (B.length wrapped < 24 || B.length wrapped `mod` 8 /= 0) $ Left- "ECDH wrapped session key must be at least 24 octets and a multiple of 8"+ ( CipherOperationFailed+ "ECDH wrapped session key must be at least 24 octets and a multiple of 8"+ ) let (a0, rBytes) = B.splitAt 8 wrapped rs = chunksOf8 rBytes when (length rs < 2) $ Left- "ECDH wrapped session key must contain at least two 64-bit blocks"+ ( CipherOperationFailed+ "ECDH wrapped session key must contain at least two 64-bit blocks"+ ) (aFinal, rFinal) <- unwrapRounds cipher a0 rs when (aFinal /= B.replicate 8 0xA6) $- Left "ECDH wrapped session key integrity check failed"+ Left+ ( CipherOperationFailed+ "ECDH wrapped session key integrity check failed"+ ) Right (B.concat rFinal) unwrapRounds@@ -2763,7 +2885,7 @@ => cipher -> B.ByteString -> [B.ByteString]- -> Either String (B.ByteString, [B.ByteString])+ -> Either CipherError (B.ByteString, [B.ByteString]) unwrapRounds cipher aInit rsInit = goJ 5 aInit rsInit where n = length rsInit@@ -2784,16 +2906,6 @@ rsNext = (ix (i - 1) .~ rNext) rsCurrent goI (i - 1) aNext rsNext -chunksOf8 :: B.ByteString -> [B.ByteString]-chunksOf8 bs- | B.null bs = []- | otherwise =- let (h, t) = B.splitAt 8 bs- in h : chunksOf8 t--xorBS :: B.ByteString -> B.ByteString -> B.ByteString-xorBS a b = B.pack (B.zipWith xor a b)- decodePKESKSessionKey :: Maybe SymmetricAlgorithm -> B.ByteString@@ -2814,7 +2926,7 @@ ++ renderEncodedSessionKeyError decodeErr ) Just expected -> do- expectedLen <- symmetricKeyLength expected+ expectedLen <- first renderCipherError (keySize expected) case decodeExpectedRawOrPaddedSessionKey expected expectedLen@@ -2912,19 +3024,3 @@ when (B.any (/= fromIntegral padLen) padBytes) $ Left "v6 ECDH decoded session material has invalid PKCS#7-style padding bytes"--symmetricKeyLength :: SymmetricAlgorithm -> Either String Int-symmetricKeyLength = first renderCipherError . keySize--checksum16 :: B.ByteString -> Word16-checksum16 =- fromIntegral- . B.foldl'- (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer))- 0--checksum16Bytes :: B.ByteString -> B.ByteString-checksum16Bytes sessionKey =- B.pack [fromIntegral (chk `shiftR` 8), fromIntegral chk]- where- chk = checksum16 sessionKey
Data/Conduit/OpenPGP/Filter.hs view
@@ -9,7 +9,6 @@ module Data.Conduit.OpenPGP.Filter ( conduitPktFilter , conduitPktWithExtraFilter- , conduitTKFilter , FilterPredicates (..) , runPredicate ) where@@ -17,27 +16,21 @@ import Control.Monad.Trans.Reader (Reader, runReader) import Data.Conduit (ConduitT) import qualified Data.Conduit.List as CL-import Data.Typeable (Typeable, eqT, (:~:) (Refl))+import Data.Typeable (Typeable) import Data.Void (Void) import Codec.Encryption.OpenPGP.Types data FilterPredicates r a- = -- | fp for transferable keys- RTKFilterPredicate (Reader TKUnknown Bool)- | -- | fp for context-less packets+ = -- | fp for context-less packets RPFilterPredicate (Reader Pkt Bool) | -- | generic filter predicate RFilterPredicate (Reader a Bool) | -- | generic filter predicate with additional context RPairFilterPredicate (Reader (r, a) Bool)-{-# DEPRECATED RTKFilterPredicate "Use RFilterPredicate with SomeTK instead" #-} runPredicate :: forall r a. Typeable a => FilterPredicates r a -> a -> Bool-runPredicate (RTKFilterPredicate e) = case eqT @a @TKUnknown of- Just Refl -> runReader e- Nothing -> const False runPredicate (RFilterPredicate e) = runReader e runPredicate _ = const False @@ -49,21 +42,6 @@ superPredicate (RPFilterPredicate e) p = runReader e p superPredicate (RFilterPredicate e) p = runReader e p superPredicate _ _ = False -- do not match incorrect type of packet--{-# DEPRECATED- conduitTKFilter- "Use (CL.filter . runPredicate) with RFilterPredicate instead"- #-}-conduitTKFilter- :: Monad m- => FilterPredicates Void TKUnknown- -> ConduitT TKUnknown TKUnknown m ()-conduitTKFilter = CL.filter . superTKPredicate--superTKPredicate- :: FilterPredicates Void TKUnknown -> TKUnknown -> Bool-superTKPredicate (RTKFilterPredicate e) = runReader e-superTKPredicate (RFilterPredicate e) = runReader e conduitPktWithExtraFilter :: Monad m => r -> FilterPredicates r Pkt -> ConduitT Pkt Pkt m ()
Data/Conduit/OpenPGP/Keyring.hs view
@@ -19,8 +19,6 @@ , authSecretSubkeysAtReport , conduitToAuthSecretSubkeysAt , conduitToAuthSecretSubkeysAtReport- , conduitToTKsEither- , conduitToTKsDroppingEither , conduitToTKsWithWireRepEither , conduitToTKsDroppingWithWireRepEither , conduitDropErrorsAndNothings@@ -97,8 +95,15 @@ :: (Monad m) => ConduitT Pkt (Either TypedTKConduitError (Maybe SomeTK)) m () conduitToSomeTKsEither =- conduitToTKsEither+ CL.filter notTrustPacket+ .| CL.map (: [])+ .| fakecmAccumEither+ finalizeParsingEither+ (parseAChunkEither (anyTK True))+ ([], Just (Nothing, anyTK True)) .| CL.map toTypedSomeTKEither+ where+ notTrustPacket = not . isTrustPkt {- | Tolerant typed conduit (broken transferable-key chunks may be omitted), while still surfacing parse+conversion failures.@@ -107,8 +112,15 @@ :: (Monad m) => ConduitT Pkt (Either TypedTKConduitError (Maybe SomeTK)) m () conduitToSomeTKsDroppingEither =- conduitToTKsDroppingEither+ CL.filter notTrustPacket+ .| CL.map (: [])+ .| fakecmAccumEither+ finalizeParsingEither+ (parseAChunkEither (anyTK False))+ ([], Just (Nothing, anyTK False)) .| CL.map toTypedSomeTKEither+ where+ notTrustPacket = not . isTrustPkt toTypedSomeTKEither :: Either KeyringChunkParseError (Maybe TKUnknown)@@ -404,29 +416,6 @@ id sig -{-# DEPRECATED conduitToTKsEither "Use conduitToSomeTKsEither instead" #-}-conduitToTKsEither- :: Monad m- => ConduitT- Pkt- (Either KeyringChunkParseError (Maybe TKUnknown))- m- ()-conduitToTKsEither = conduitToTKsEither' True--{-# DEPRECATED- conduitToTKsDroppingEither- "Use conduitToSomeTKsDroppingEither instead"- #-}-conduitToTKsDroppingEither- :: Monad m- => ConduitT- Pkt- (Either KeyringChunkParseError (Maybe TKUnknown))- m- ()-conduitToTKsDroppingEither = conduitToTKsEither' False- conduitToTKsWithWireRepEither :: Monad m => ConduitT@@ -475,24 +464,6 @@ :: Monad m => ConduitT (Either e (Maybe a)) a m () conduitDropErrorsAndNothings = CL.mapMaybe (join . hush)--conduitToTKsEither'- :: Monad m- => Bool- -> ConduitT- Pkt- (Either KeyringChunkParseError (Maybe TKUnknown))- m- ()-conduitToTKsEither' intolerant =- CL.filter notTrustPacket- .| CL.map (: [])- .| fakecmAccumEither- finalizeParsingEither- (parseAChunkEither (anyTK intolerant))- ([], Just (Nothing, anyTK intolerant))- where- notTrustPacket = not . isTrustPkt conduitToTKsWithWireRepEither' :: Monad m
Data/Conduit/OpenPGP/Keyring/Instances.hs view
@@ -15,21 +15,14 @@ import Control.Lens (folded, (^.), (^..), _1) import Data.Data.Lens (biplate) import Data.Either (rights)-import Data.Function (on)-import qualified Data.HashMap.Lazy as HashMap import Data.IxSet.Typed (Indexable (..), ixFun, ixList)-import Data.List (nub, sort) import qualified Data.List.NonEmpty as NE-import qualified Data.Map as Map-import Data.Semigroup (Semigroup, (<>)) import Data.Text (Text) import Codec.Encryption.OpenPGP.Fingerprint ( eightOctetKeyID , fingerprint )-import Codec.Encryption.OpenPGP.Internal (issuer)-import Codec.Encryption.OpenPGP.SignatureQualities (sigCT) import Codec.Encryption.OpenPGP.Types instance Indexable KeyringIxs TKUnknown where
hOpenPGP.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP-Version: 3.2.1+Version: 3.3 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@@ -231,6 +231,8 @@ , Codec.Encryption.OpenPGP.Policy , Codec.Encryption.OpenPGP.S2K , Codec.Encryption.OpenPGP.SecretKey+ , Codec.Encryption.OpenPGP.SEIPDv1+ , Codec.Encryption.OpenPGP.SEIPDv2 , Codec.Encryption.OpenPGP.Serialize , Codec.Encryption.OpenPGP.Signatures , Codec.Encryption.OpenPGP.SignatureQualities@@ -248,7 +250,6 @@ , Codec.Encryption.OpenPGP.Internal.CryptoAES , Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes , Codec.Encryption.OpenPGP.Internal.CryptoECDH- , Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2 , Codec.Encryption.OpenPGP.Internal.Crypton , Codec.Encryption.OpenPGP.Internal.HOBlockCipher , Codec.Encryption.OpenPGP.Internal.RFC7253OCB@@ -281,6 +282,8 @@ , Codec.Encryption.OpenPGP.Policy , Codec.Encryption.OpenPGP.S2K , Codec.Encryption.OpenPGP.SecretKey+ , Codec.Encryption.OpenPGP.SEIPDv1+ , Codec.Encryption.OpenPGP.SEIPDv2 , Codec.Encryption.OpenPGP.Serialize , Codec.Encryption.OpenPGP.Signatures , Codec.Encryption.OpenPGP.SignatureQualities@@ -337,4 +340,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v3.2.1+ tag: v3.3
tests/Tests/Common.hs view
@@ -81,10 +81,7 @@ , conduitDecryptWithCandidatesCallbackAndPolicy , conduitDecryptWithDecryptPolicy , deriveECDHKekForTest- , deriveX25519KekForTest- , deriveX448KekForTest , doPkeyAndSkeyMatch- , encodeChecksum16 , forceVersionedRecipientIdentifier , isPrecedingESK , mkPKESKSessionMaterialOrFail@@ -108,9 +105,6 @@ import Control.Monad (join, unless, void) import Control.Monad.Trans.Resource (ResourceT) import qualified Crypto.Error as CE-import qualified Crypto.Hash as CH-import qualified Crypto.Hash.Algorithms as CHA-import Crypto.KDF.HKDF (expand, extract) import Crypto.Number.Serialize (os2ip) import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Types as ECCT@@ -128,8 +122,6 @@ , getWord8 , runGetOrFail )-import Data.Binary.Put (putWord64be, runPut)-import Data.Bits (xor) import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Base16.Lazy as B16L@@ -147,7 +139,7 @@ import Data.Text (Text) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Data.Word (Word32, Word64)+import Data.Word (Word32) import System.IO.Unsafe (unsafePerformIO) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit@@ -157,13 +149,15 @@ , assertFailure , testCase )-import qualified "crypton" Crypto.Cipher.AES as AES-import qualified "crypton" Crypto.Cipher.Types as CCT import Codec.Encryption.OpenPGP.Arbitrary ()+import Codec.Encryption.OpenPGP.BlockCipher+ ( renderCipherError+ ) import Codec.Encryption.OpenPGP.Compression (decompressPkt) import Codec.Encryption.OpenPGP.Encrypt ( PKESKSessionMaterial+ , aesKeyWrapRFC3394 , encodeOpenPGPSessionMaterial , mkPKESKSessionMaterial )@@ -172,20 +166,22 @@ , fingerprint ) import Codec.Encryption.OpenPGP.Internal- ( curveFromCurve- , curveToCurveoidBS+ ( checksum16Bytes , emptyPSC , lastPrimaryKey , lastSubkey , lastUIDorUAt )+import Codec.Encryption.OpenPGP.Internal.CryptoECDH+ ( buildECDHKDFParam+ , deriveECDHKek+ ) import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint) import Codec.Encryption.OpenPGP.Message ( ClearPayload , EncryptMessageOptions (..) , EncryptedPayload , MessageError (..)- , Passphrase , RecoveredSessionMaterial (..) , SessionMaterialExposure (..) , VersionedPKPayload@@ -493,7 +489,7 @@ expected = B.singleton (fromFVal AES256) <> keyBytes- <> encodeChecksum16 keyBytes+ <> checksum16Bytes keyBytes case encodeOpenPGPSessionMaterial AES256 (SessionKey keyBytes) of Left err -> assertFailure@@ -581,17 +577,13 @@ -> SymmetricAlgorithm -> B.ByteString buildECDHKDFParamForTest recipientPKP pka curve kdfHA kdfSA =- B.singleton (fromIntegral (B.length curveOid))- <> curveOid- <> B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA]- <> "Anonymous Sender "- <> BL.toStrict (unFingerprint (fingerprint recipientPKP))+ either+ error+ id+ (buildECDHKDFParam recipientPKP pka pkey kdfHA kdfSA) where- curveOid =- either- (const B.empty)- id- (curveToCurveoidBS (curveFromCurve curve))+ pkey =+ ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve ECCT.PointO)) buildCurve25519LegacyKdfParamForTest :: SomePKPayload@@ -600,13 +592,13 @@ -> SymmetricAlgorithm -> B.ByteString buildCurve25519LegacyKdfParamForTest recipientPKP pka kdfHA kdfSA =- B.singleton (fromIntegral (B.length curveOid))- <> curveOid- <> B.pack [fromFVal pka, 0x03, 0x01, fromFVal kdfHA, fromFVal kdfSA]- <> "Anonymous Sender "- <> BL.toStrict (unFingerprint (fingerprint recipientPKP))+ either+ error+ id+ (buildECDHKDFParam recipientPKP pka dummyKey kdfHA kdfSA) where- curveOid = "\x2b\x06\x01\x04\x01\x97\x55\x01\x05\x01"+ dummyKey =+ EdDSAPubKey EdSigningCurve25519 (PrefixedNativeEPoint (EPoint 0)) deriveECDHKekForTest :: HashAlgorithm@@ -615,58 +607,7 @@ -> B.ByteString -> B.ByteString deriveECDHKekForTest kdfHA kdfSA sharedSecret kdfParam =- B.take (keyLengthForTest kdfSA) digest- where- digest =- case kdfHA of- SHA256 ->- BA.convert- ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)- :: CH.Digest CHA.SHA256- )- SHA384 ->- BA.convert- ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)- :: CH.Digest CHA.SHA384- )- SHA512 ->- BA.convert- ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)- :: CH.Digest CHA.SHA512- )- _ ->- BA.convert- ( CH.hash (B.pack [0, 0, 0, 1] <> sharedSecret <> kdfParam)- :: CH.Digest CHA.SHA256- )--deriveX448KekForTest- :: B.ByteString- -> B.ByteString- -> B.ByteString- -> B.ByteString-deriveX448KekForTest ephemeralPublic recipientPublic sharedSecret =- let ikm = ephemeralPublic <> recipientPublic <> sharedSecret- prk = extract @CHA.SHA512 B.empty ikm- info = "OpenPGP X448" :: B.ByteString- in expand @CHA.SHA512 prk info 32--deriveX25519KekForTest- :: B.ByteString- -> B.ByteString- -> B.ByteString- -> B.ByteString-deriveX25519KekForTest ephemeralPublic recipientPublic sharedSecret =- let ikm = ephemeralPublic <> recipientPublic <> sharedSecret- prk = extract @CHA.SHA256 B.empty ikm- info = "OpenPGP X25519" :: B.ByteString- in expand @CHA.SHA256 prk info 16--keyLengthForTest :: SymmetricAlgorithm -> Int-keyLengthForTest AES128 = 16-keyLengthForTest AES192 = 24-keyLengthForTest AES256 = 32-keyLengthForTest _ = 16+ either error id (deriveECDHKek kdfHA kdfSA sharedSecret kdfParam) aesKeyWrapRFC3394ForTest :: SymmetricAlgorithm@@ -674,62 +615,10 @@ -> B.ByteString -> B.ByteString aesKeyWrapRFC3394ForTest sa kek plain =- case sa of- AES128 -> wrapWithCipher (initCipher kek :: AES.AES128) plain- AES192 -> wrapWithCipher (initCipher kek :: AES.AES192) plain- AES256 -> wrapWithCipher (initCipher kek :: AES.AES256) plain- _ -> error "unsupported KEK algorithm in test"- where- initCipher keyBytes =- case CE.eitherCryptoError (CCT.cipherInit keyBytes) of- Left err -> error ("cipher init failed: " ++ show err)- Right c -> c- wrapWithCipher cipher plainBytes =- let rs = chunksOf8ForTest plainBytes- n = length rs- a0 = B.replicate 8 0xA6- (aFinal, rFinal) =- foldl (\(a, r) j -> wrapRound cipher n j a r) (a0, rs) [0 .. 5]- in aFinal <> B.concat rFinal- wrapRound cipher n j a rs = foldl step (a, rs) [1 .. n]- where- step (aCurr, rCurr) i =- let b = CCT.ecbEncrypt cipher (aCurr <> (rCurr !! (i - 1)))- (aMsb, rLsb) = B.splitAt 8 b- t = fromIntegral (n * j + i) :: Word64- aNext = xorBSForTest aMsb (encodeWord64beForTest t)- in (aNext, replaceAtForTest (i - 1) rLsb rCurr)--encodeWord64beForTest :: Word64 -> B.ByteString-encodeWord64beForTest = BL.toStrict . runPut . putWord64be--chunksOf8ForTest :: B.ByteString -> [B.ByteString]-chunksOf8ForTest bs- | B.null bs = []- | otherwise =- let (h, t) = B.splitAt 8 bs- in h : chunksOf8ForTest t--replaceAtForTest :: Int -> a -> [a] -> [a]-replaceAtForTest idx x xs =- let (prefix, suffix) = splitAt idx xs- in case suffix of- [] -> xs- (_ : rest) -> prefix <> (x : rest)--xorBSForTest :: B.ByteString -> B.ByteString -> B.ByteString-xorBSForTest a b = B.pack (B.zipWith xor a b)--encodeChecksum16 :: B.ByteString -> B.ByteString-encodeChecksum16 bs =- B.pack- [fromIntegral (s `div` 256), fromIntegral (s `mod` 256)]- where- s =- B.foldl'- (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Int))- 0- bs+ either+ (error . renderCipherError)+ id+ (aesKeyWrapRFC3394 sa kek plain) verifyMessageFromPackets :: PublicKeyring -> BL.ByteString -> [Either String Verification]@@ -1013,7 +902,7 @@ V4 0 0- EdDSA+ EdDSALegacy ( EdDSAPubKey EdSigningCurve25519 ( PrefixedNativeEPoint@@ -1041,7 +930,7 @@ V6 0 0- EdDSA+ EdDSALegacy ( EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint (os2ip publicKeyBytes)))@@ -1067,7 +956,7 @@ V4 0 0- EdDSA+ EdDSALegacy ( EdDSAPubKey EdSigningCurve448 ( PrefixedNativeEPoint@@ -1095,7 +984,7 @@ V6 0 0- EdDSA+ EdDSALegacy ( EdDSAPubKey EdSigningCurve448 (NativeEPoint (EPoint (os2ip publicKeyBytes)))
tests/Tests/Encryption.hs view
@@ -92,7 +92,6 @@ , RecipientEncryptionTarget (..) , RecipientEncryptionTargetRejected (..) , RecipientEncryptionTargetsReport (..)- , RecipientPKESKVersionStrategy (..) , RecipientPKESKVersionStrategyW (..) , RecipientPayloadShape (..) , RecipientTargetRejectionReason (..)@@ -102,6 +101,8 @@ , buildPKESKv3PayloadForRecipient , canonicalizePKESKRecipientId , defaultRecipientPayloadShape+ , deriveX25519Kek+ , deriveX448Kek , encryptForRecipients , encryptForRecipientsLegacy , encryptForRecipientsWithCapabilityNegotiation@@ -120,7 +121,10 @@ , recipientVersionStrategyForProfileTyped ) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)-import Codec.Encryption.OpenPGP.Internal (point2MBS)+import Codec.Encryption.OpenPGP.Internal+ ( checksum16Bytes+ , point2MBS+ ) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher ( HOBlockCipher (..) )@@ -145,6 +149,15 @@ , skesk2SessionKey , string2Key )+import Codec.Encryption.OpenPGP.SEIPDv1+ ( mdcTrailerForSEIPDv1+ , renderMDCFailure+ , seipdv1NonceFromIV+ , validateSEIPD1MDC+ )+import Codec.Encryption.OpenPGP.SEIPDv2+ ( renderSEIPDv2Failure+ ) import Codec.Encryption.OpenPGP.SecretKey ( decryptPrivateKey , encryptPrivateKeyWithPolicyAndSaltAndIV@@ -156,6 +169,7 @@ ( DecryptKeyResolution (..) , DecryptOptions (..) , DecryptOutcome (..)+ , DecryptStructureError (..) , PKESKRecipientKey (..) ) import qualified Data.Conduit.OpenPGP.Decrypt as DCD@@ -179,10 +193,7 @@ , conduitDecryptWithDecryptPolicy , conduitDecryptWithPKESKContext , deriveECDHKekForTest- , deriveX25519KekForTest- , deriveX448KekForTest , doPkeyAndSkeyMatch- , encodeChecksum16 , encryptMessageDefault , fixturePath , forceVersionedRecipientIdentifier@@ -773,13 +784,13 @@ "encryptForRecipients rejects SEIPDv1 when recipients do not advertise MDC support" testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC , testCase- "recipientEncryptionTargetsFromTK returns only encryption-capable candidates"+ "recipientEncryptionTargetsFromTKAtTimestamp returns only encryption-capable candidates" testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys , testCase- "recipientEncryptionTargetFromTK prefers encryption-capable subkeys"+ "recipientEncryptionTargetFromTKWithPolicy prefers encryption-capable subkeys" testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary , testCase- "recipientEncryptionTargetFromTK rejects TKs without encryptable key material"+ "recipientEncryptionTargetFromTKWithPolicy rejects TKs without encryptable key material" testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys , testCase "recipientEncryptionTargetsReportFromTKAtTimestamp reports sign-only subkey rejection reasons"@@ -797,7 +808,7 @@ "recipientEncryptionTargetsFromTKAtTimestamp extracts effective self-signature capabilities" testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities , testCase- "recipientEncryptionTargetFromTKAtTimestamp filters subkey self-signatures by timestamp"+ "recipientEncryptionTargetFromTKAtTimestampWithPolicy filters subkey self-signatures by timestamp" testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering , testCase "recipientEncryptionTargetFromTKAtTimestampWithPolicy can prefer primary key"@@ -806,10 +817,10 @@ "recipientEncryptionTargetFromTKAtTimestampWithPolicy can prefer newest key" testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest , testCase- "recipientEncryptionTargetsFromTK excludes subkeys with non-encrypt key flags"+ "recipientEncryptionTargetsFromTKAtTimestamp excludes subkeys with non-encrypt key flags" testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags , testCase- "recipientEncryptionTargetsFromTK includes subkeys with no key flags advertised"+ "recipientEncryptionTargetsFromTKAtTimestamp includes subkeys with no key flags advertised" testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags , testCase "encryptForRecipients optionally emits one-pass signature packets"@@ -1068,7 +1079,8 @@ payloadOut <- either ( \err ->- assertFailure ("validateSEIPD1MDC failed: " ++ err)+ assertFailure+ ("validateSEIPD1MDC failed: " ++ renderMDCFailure err) >> pure mempty ) pure@@ -1300,10 +1312,8 @@ ( "Expected DecryptMalformedStructure but got exception: " ++ show err )- Right (DecryptMalformedStructure reason, _) ->- assertBool- ("Expected 'after message integrity boundary', got: " ++ reason)- ("after message integrity boundary" `isInfixOf` reason)+ Right (DecryptMalformedStructure DecryptStructureTrailingData, _) ->+ pure () Right (other, _) -> assertFailure ( "Expected strict policy to reject trailing data but got: "@@ -1398,12 +1408,8 @@ ( "Expected DecryptMalformedStructure but got exception: " ++ show err )- Right (DecryptMalformedStructure reason, _) ->- assertBool- ("Expected ESK prelude shape failure, got: " ++ reason)- ( "ESK packets must immediately precede encrypted data"- `isInfixOf` reason- )+ Right (DecryptMalformedStructure DecryptStructureESKOrder, _) ->+ pure () Right (other, _) -> assertFailure ("Expected DecryptMalformedStructure but got: " ++ show other)@@ -1434,10 +1440,9 @@ ( "Expected DecryptMalformedStructure but got exception: " ++ show err )- Right (DecryptMalformedStructure reason, _) ->- assertBool- ("Expected payload/ESK alignment failure, got: " ++ reason)- ("version-aligned" `isInfixOf` reason)+ Right+ (DecryptMalformedStructure DecryptStructureESKSEIPDMismatch, _) ->+ pure () Right (other, _) -> assertFailure ("Expected DecryptMalformedStructure but got: " ++ show other)@@ -1874,7 +1879,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -1950,7 +1956,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -2066,7 +2073,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -2295,7 +2303,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -3812,17 +3821,19 @@ V6 (ThirtyTwoBitTimeStamp 0) 0- EdDSA+ EdDSALegacy (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1))) sessionKey = SessionKey (B.replicate 32 0x19) sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey result <- buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial case result of- Left (UnsupportedRecipientAlgorithm EdDSA) -> pure ()+ Left (UnsupportedRecipientAlgorithm EdDSALegacy) -> pure () Left err -> assertFailure- ("Expected UnsupportedRecipientAlgorithm EdDSA, got " ++ show err)+ ( "Expected UnsupportedRecipientAlgorithm EdDSALegacy, got "+ ++ show err+ ) Right payload -> assertFailure ( "Expected UnsupportedRecipientAlgorithm, got payload: "@@ -4192,7 +4203,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -4246,7 +4258,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct result <-@@ -4329,7 +4342,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct let pkesk =@@ -4420,7 +4434,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct let pkesk =@@ -4519,7 +4534,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct let pkesk =@@ -4573,7 +4589,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> encodeChecksum16 sessionKey+ <> checksum16Bytes sessionKey <> B.replicate 5 0 sharedSecret = BA.convert@@ -4636,7 +4652,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -4682,7 +4699,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> encodeChecksum16 sessionKey+ <> checksum16Bytes sessionKey <> B.replicate 5 0 sharedSecret = BA.convert@@ -4746,7 +4763,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct result <-@@ -4814,7 +4832,7 @@ Right pk -> pk sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString kek =- deriveX25519KekForTest+ deriveX25519Kek ephPublicRaw recipientPublicRaw sharedSecret@@ -4860,7 +4878,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -4945,7 +4964,7 @@ Right pk -> pk sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString kek =- deriveX25519KekForTest+ deriveX25519Kek ephPublicRaw recipientPublicRaw sharedSecret@@ -4993,7 +5012,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -5045,7 +5065,7 @@ Right pk -> pk sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString kek =- deriveX25519KekForTest+ deriveX25519Kek ephPublicRaw recipientPublicRaw sharedSecret@@ -5120,7 +5140,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -5172,7 +5193,7 @@ Right pk -> pk sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString kek =- deriveX25519KekForTest+ deriveX25519Kek ephPublicRaw recipientPublicRaw sharedSecret@@ -5333,7 +5354,7 @@ Right pk -> pk sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString kek =- deriveX25519KekForTest+ deriveX25519Kek ephPublicRaw recipientPublicRaw sharedSecret@@ -5381,7 +5402,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -5468,7 +5490,7 @@ Right pk -> pk sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString kek =- deriveX25519KekForTest+ deriveX25519Kek ephPublicRaw recipientPublicRaw sharedSecret@@ -5516,7 +5538,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -5604,7 +5627,7 @@ Right pk -> pk sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString kek =- deriveX25519KekForTest+ deriveX25519Kek ephPublicRaw recipientPublicRaw sharedSecret@@ -5652,7 +5675,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct (report, decrypted) <-@@ -5762,7 +5786,7 @@ Right pk -> pk sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString kek =- deriveX25519KekForTest+ deriveX25519Kek ephPublicRaw recipientPublicRaw sharedSecret@@ -5809,7 +5833,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct result <-@@ -5880,7 +5905,7 @@ Right pk -> pk sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString kek =- deriveX25519KekForTest+ deriveX25519Kek ephPublicRaw recipientPublicRaw sharedSecret@@ -5963,7 +5988,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -6051,7 +6077,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -6097,7 +6124,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> encodeChecksum16 sessionKey+ <> checksum16Bytes sessionKey <> B.replicate 5 0 sharedSecret = BA.convert@@ -6160,7 +6187,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct result <-@@ -6242,7 +6270,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> encodeChecksum16 sessionKey+ <> checksum16Bytes sessionKey <> B.replicate 5 0 sharedSecret = BA.convert@@ -6295,7 +6323,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -6390,7 +6419,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKeyBytes- <> encodeChecksum16 sessionKeyBytes+ <> checksum16Bytes sessionKeyBytes <> B.replicate 5 0 wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession in (SessionKey sessionKeyBytes, wrappedSession)@@ -6440,7 +6469,8 @@ sessionKey (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -6514,7 +6544,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> encodeChecksum16 sessionKey+ <> checksum16Bytes sessionKey <> B.replicate 5 0 sharedSecret = BA.convert@@ -6567,7 +6597,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct result <-@@ -6606,7 +6637,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> encodeChecksum16 sessionKey+ <> checksum16Bytes sessionKey <> B.replicate 5 0 recipientSecret = case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of@@ -6626,7 +6657,7 @@ BA.convert (C448.dh (C448.toPublic recipientSecret) ephSecret) :: B.ByteString kek =- deriveX448KekForTest ephPublicRaw recipientPublicRaw sharedSecret+ deriveX448Kek ephPublicRaw recipientPublicRaw sharedSecret wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession esk = ephPublicRaw@@ -6677,7 +6708,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct decrypted <-@@ -6710,7 +6742,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> encodeChecksum16 sessionKey+ <> checksum16Bytes sessionKey <> B.replicate 5 0 recipientSecret = case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of@@ -6731,7 +6763,7 @@ BA.convert (C448.dh (C448.toPublic recipientSecret) ephSecret) :: B.ByteString kek =- deriveX448KekForTest ephPublicRaw recipientPublicRaw sharedSecret+ deriveX448Kek ephPublicRaw recipientPublicRaw sharedSecret wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession esk = shortEphemeral@@ -6782,7 +6814,8 @@ (SessionKey sessionKey) (BL.toStrict (runPut (put literalBlock))) of Left err ->- assertFailure ("encryptSEIPDv2Payload failed: " ++ err)+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct result <-@@ -6973,7 +7006,7 @@ let encodedWithChecksum = B.singleton (fromFVal sa) <> sessionKey- <> encodeChecksum16 sessionKey+ <> checksum16Bytes sessionKey encryptedEsk <- case withSymmetricCipher sa kek $ \cipher -> paddedCfbEncrypt@@ -7020,7 +7053,7 @@ Left err -> assertFailure ( "Expected passphrase SKESK force-v4 encryption to succeed, got: "- ++ err+ ++ renderSEIPDv2Failure err ) Right ( SKESKPkt (SKESKPayloadV4Packet _)@@ -7054,7 +7087,7 @@ Left err -> assertFailure ( "Expected passphrase SKESK prefer-v6 encryption to succeed, got: "- ++ err+ ++ renderSEIPDv2Failure err ) Right ( SKESKPkt (SKESKPayloadV6Packet _)
tests/Tests/Keys.hs view
@@ -9,7 +9,6 @@ module Tests.Keys (keyAndVerificationTests) where -import Control.Error.Util (isRight) import Crypto.Number.Serialize (os2ip) import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import Data.Bifunctor (first)@@ -22,6 +21,7 @@ import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.Serialization.Binary (conduitGet)+import Data.Either (isRight) import Data.IxSet.Typed (getOne, size, (@=)) import Data.List (find, isInfixOf) import Data.List.NonEmpty (NonEmpty (..))@@ -75,7 +75,6 @@ , decryptSecretKey , mkUnencryptedSKAddendum , reencryptSecretKey- , reinterpretUnknownSKeyForPKPayload ) import Codec.Encryption.OpenPGP.Serialize ( getSecretKey@@ -166,13 +165,13 @@ "ecd/256:F7708BADD6063224/174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224" ) , testCase- "EdDSA key"+ "EdDSALegacy key" ( testPKAandSizeAndKeyIDandFingerprint "sample-eddsa.pubkey" "edd/256:8CFDE12197965A9A/C959 BDBA FA32 A2F8 9A15 3B67 8CFD E121 9796 5A9A" ) , testCase- "EdDSA secret key (projected to public key packet)"+ "EdDSALegacy secret key (projected to public key packet)" ( testPKAandSizeAndKeyIDandFingerprint "ed25519.secretkey" "edd/256:B05F9287601D5914/B6FE 0C23 12EB D832 0238 C252 B05F 9287 601D 5914"@@ -343,9 +342,6 @@ "mkUnencryptedSKAddendum sets v6 unencrypted checksum to zero" testMkUnencryptedSKAddendumUsesV6ChecksumConvention , testCase- "reinterpretUnknownSKeyForPKPayload decodes EdDSA unknown key material"- testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA- , testCase "fromPrimaryKeyPktToSomeTK rejects subkey packets" testFromPrimaryKeyPktToSomeTKRejectsSubkey , testCase@@ -1802,7 +1798,7 @@ pkSigV6PK = SigV6 KeyRevocationSig- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x11)) []@@ -1812,7 +1808,7 @@ pkSigV6Direct = SigV6 SignatureDirectlyOnAKey- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x12)) []@@ -1822,7 +1818,7 @@ pkSigV6Binding = SigV6 SubkeyBindingSig- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x13)) []@@ -1835,7 +1831,7 @@ skSigV6Binding = SigV6 SubkeyBindingSig- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x14)) []@@ -1845,7 +1841,7 @@ skSigV6Revocation = SigV6 SubkeyRevocationSig- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x15)) []@@ -1855,7 +1851,7 @@ skSigV6Direct = SigV6 SignatureDirectlyOnAKey- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x16)) []@@ -1871,7 +1867,7 @@ uidSigV6Generic = SigV6 GenericCert- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x17)) []@@ -1881,7 +1877,7 @@ uidSigV6Persona = SigV6 PersonaCert- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x18)) []@@ -1891,7 +1887,7 @@ uidSigV6Casual = SigV6 CasualCert- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x19)) []@@ -1901,7 +1897,7 @@ uidSigV6Positive = SigV6 PositiveCert- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x1a)) []@@ -1911,7 +1907,7 @@ uidSigV6CertRev = SigV6 CertRevocationSig- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x1b)) []@@ -1921,7 +1917,7 @@ uidSigV6Binding = SigV6 SubkeyBindingSig- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x1c)) []@@ -2172,7 +2168,7 @@ V4 (ThirtyTwoBitTimeStamp 0) 0- EdDSA+ EdDSALegacy ( EdDSAPubKey EdSigningCurve25519 ( PrefixedNativeEPoint@@ -2207,7 +2203,7 @@ V4 (ThirtyTwoBitTimeStamp 0) 0- EdDSA+ EdDSALegacy ( EdDSAPubKey EdSigningCurve448 ( PrefixedNativeEPoint@@ -2284,34 +2280,6 @@ checksum Right other -> assertFailure ("unexpected addendum constructor: " ++ show other)--testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA :: Assertion-testReinterpretUnknownSKeyForPKPayloadDecodesEdDSA = do- let secretBytes = B.pack (0 : replicate 31 1)- pkp =- PKPayload- V4- (ThirtyTwoBitTimeStamp 0)- 0- EdDSA- ( EdDSAPubKey- EdSigningCurve25519- ( PrefixedNativeEPoint- (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01))))- )- )- unknown = UnknownSKey (runPut (put (MPI (os2ip secretBytes))))- case reinterpretUnknownSKeyForPKPayload pkp unknown of- Left err ->- assertFailure- ( "reinterpretUnknownSKeyForPKPayload should decode Ed25519 key: "- ++ err- )- Right skey ->- assertEqual- "reinterpretUnknownSKeyForPKPayload should return typed EdDSA secret key"- (EdDSAPrivateKey EdSigningCurve25519 secretBytes)- skey testFromPrimaryKeyPktToSomeTKRejectsSubkey :: Assertion testFromPrimaryKeyPktToSomeTKRejectsSubkey = do
tests/Tests/MessageAndArmor.hs view
@@ -13,6 +13,8 @@ , ArmorType (..) ) import Control.Lens ((^.))+import qualified Crypto.Error as CE+import qualified Crypto.PubKey.Ed25519 as Ed25519 import Data.Binary (get, put) import Data.Binary.Get (Get, runGetOrFail) import Data.Binary.Put@@ -32,6 +34,7 @@ ) import Data.List (isInfixOf) import qualified Data.List.NonEmpty as NE+import Data.Word (Word8) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit ( Assertion@@ -44,7 +47,6 @@ import Codec.Encryption.OpenPGP.BlockCipher (keySize) import Codec.Encryption.OpenPGP.CFB ( decryptPreservingNonce- , validateSEIPD1MDC ) import Codec.Encryption.OpenPGP.Compression (decompressPkt) import Codec.Encryption.OpenPGP.Encrypt@@ -54,7 +56,10 @@ ( eightOctetKeyID , fingerprint )-import Codec.Encryption.OpenPGP.Internal (emptyPSC, lastLD)+import Codec.Encryption.OpenPGP.Internal+ ( PktStreamContext (..)+ , emptyPSC+ ) import qualified Codec.Encryption.OpenPGP.Internal.Whitespace as WS import Codec.Encryption.OpenPGP.KeyringParser (parsePublicTKs) import Codec.Encryption.OpenPGP.Message@@ -63,6 +68,14 @@ , signatureV6SaltSizeForHashAlgorithm ) import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key)+import Codec.Encryption.OpenPGP.SEIPDv1+ ( renderMDCFailure+ , validateSEIPD1MDC+ )+import Codec.Encryption.OpenPGP.SEIPDv2+ ( SEIPDv2Failure (..)+ , renderSEIPDv2Failure+ ) import Codec.Encryption.OpenPGP.Serialize ( armorPayloadsOfType , parsePkts@@ -74,6 +87,7 @@ import Codec.Encryption.OpenPGP.SerializeForSigs ( payloadForSig , payloadForSigWith+ , putKeyforSigning , putPartialSigforSigning , putSigTrailer )@@ -131,6 +145,7 @@ , loadKeyring , loadUnencryptedRsaSigner , loadUnencryptedRsaSignerV6+ , loadV6UnencryptedSecretKeyFixtureForProperty , mkTestKeyring , readFixtureLazy , readFixtureStrict@@ -144,6 +159,32 @@ , verifyTimelinePackets ) +extractEd25519SecretKey :: SKey -> IO Ed25519.SecretKey+extractEd25519SecretKey skey =+ case skey of+ EdDSAPrivateKey EdSigningCurve25519 bs ->+ case CE.eitherCryptoError (Ed25519.secretKey bs) of+ Left err ->+ assertFailure+ ( "failed to initialize Ed25519 secret key from EdDSAPrivateKey: "+ ++ show err+ )+ >> fail "expected Ed25519 secret key"+ Right edSk -> pure edSk+ Ed25519PrivateKey bs ->+ case CE.eitherCryptoError (Ed25519.secretKey bs) of+ Left err ->+ assertFailure+ ( "failed to initialize Ed25519 secret key from Ed25519PrivateKey: "+ ++ show err+ )+ >> fail "expected Ed25519 secret key"+ Right edSk -> pure edSk+ _ ->+ assertFailure+ "v6-secret fixture did not contain Ed25519 secret key material"+ >> fail "expected Ed25519 secret key"+ messageAndArmorTests :: TestTree messageAndArmorTests = testGroup@@ -218,7 +259,7 @@ "detached v4 Ed25519 verifyAgainstKeys tolerates fake issuer hints" testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys , testCase- "v4 EdDSA signatures verify with Ed25519 key algorithm identifier"+ "v4 EdDSALegacy signatures verify with Ed25519 key algorithm identifier" testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm , testCase "sign message convenience API"@@ -268,6 +309,27 @@ , testCase "v6.txt.sig verifies against v6.txt with v6-secret.pgp.aa public key" testV6DetachedVerification+ , testCase+ "v6-secret fixture creates and verifies detached Ed25519 SigV6"+ testV6FixtureSignatureCreationAndVerification+ , testCase+ "v6-secret fixture creates and verifies binary message Ed25519 SigV6"+ testV6FixtureBinaryMessageSigning+ , testCase+ "v6-secret fixture creates and verifies direct-key Ed25519 SigV6"+ testV6FixtureDirectKeySignature+ , testCase+ "v6-secret fixture creates and verifies key-revocation Ed25519 SigV6"+ testV6FixtureKeyRevocation+ , testCase+ "v6-secret fixture creates and verifies certification Ed25519 SigV6"+ testV6FixtureCertification+ , testCase+ "v6.rev.aa ReasonForRevocation subpacket content"+ (testV6RevocationReasonSubpacket "v6.rev.aa")+ , testCase+ "v6-encrypted.rev.aa ReasonForRevocation subpacket content"+ (testV6RevocationReasonSubpacket "v6-encrypted.rev.aa") ] , testGroup "ASCII armor fixture group"@@ -402,14 +464,14 @@ (fp "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") (fingerprint pkp) assertEqual- "v4 encrypted secret fixture should use EdDSA for its primary key"- EdDSA+ "v4 encrypted secret fixture should use EdDSALegacy for its primary key"+ EdDSALegacy (_pkalgo pkp) assertEncryptedS2K "primary key" ska mapM_ (assertEncryptedS2K "subkey" . snd) secretSubkeys assertEqual- "v4 encrypted secret fixture should contain two EdDSA subkeys and one ECDH subkey"- [EdDSA, EdDSA, ECDH]+ "v4 encrypted secret fixture should contain two EdDSALegacy subkeys and one ECDH subkey"+ [EdDSALegacy, EdDSALegacy, ECDH] (map (_pkalgo . fst) secretSubkeys) _ -> assertFailure@@ -482,8 +544,8 @@ (fp "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1") (fingerprint pkp) assertEqual- "v4 encrypted revocation fixture should use EdDSA for its public key"- EdDSA+ "v4 encrypted revocation fixture should use EdDSALegacy for its public key"+ EdDSALegacy (_pkalgo pkp) _ -> assertFailure@@ -569,7 +631,9 @@ >> fail "unexpected revocation fixture packet shape" case sig of SigV6 _ _ ha salt _ _ _ _ ->- case expectedV6SaltSizeForTest ha of+ case fmap+ (fromIntegral :: Word8 -> Int)+ (signatureV6SaltSizeForHashAlgorithm ha) of Nothing -> assertFailure ( fixture@@ -704,10 +768,6 @@ "msg1.asc should contain at least one parseable packet block" (any (not . null) packetBlocks) -expectedV6SaltSizeForTest :: HashAlgorithm -> Maybe Int-expectedV6SaltSizeForTest =- fmap fromIntegral . signatureV6SaltSizeForHashAlgorithm- signatureHasIssuerFingerprintV6 :: Fingerprint -> SignaturePayload -> Bool signatureHasIssuerFingerprintV6 expectedFp (SigV6 _ _ _ _ hashed unhashed _ _) =@@ -924,7 +984,11 @@ block of Left err -> assertFailure- ("AES-128 " ++ label ++ " encryption failed: " ++ err)+ ( "AES-128 "+ ++ label+ ++ " encryption failed: "+ ++ renderSEIPDv2Failure err+ ) >> fail "encryptSEIPDv2WithSKESKBlock failed" Right ps -> pure ps let encrypted = mkEncryptedPayload (runPut (put (Block packets)))@@ -987,13 +1051,13 @@ s2k passphraseBytes block of- Left err- | "EAX is currently unsupported by the crypton AEAD backend"- `isInfixOf` err ->- pure ()- | otherwise ->- assertFailure- ("expected explicit EAX backend limitation, got: " ++ err)+ Left (SEIPDv2UnsupportedAEADAlgorithm EAX) ->+ pure ()+ Left err ->+ assertFailure+ ( "expected explicit EAX backend limitation, got: "+ ++ renderSEIPDv2Failure err+ ) Right packets -> assertFailure ( "expected AES-128 EAX encryption to fail explicitly, got packets: "@@ -1020,16 +1084,12 @@ ) passphrase payload of- Left (MessageEncryptError err)- | "deprecated hash algorithm disallowed for modern message generation"- `isInfixOf` err ->+ Left+ (MessageEncryptFailureError (MessageEncryptDeprecatedS2KHash _)) -> pure ()- | otherwise ->- assertFailure- ("Expected deprecated modern S2K hash rejection, got: " ++ err) Left err -> assertFailure- ( "Expected MessageEncryptError for deprecated modern S2K hash, got "+ ( "Expected deprecated modern S2K hash rejection, got: " ++ show err ) Right _ ->@@ -1143,7 +1203,8 @@ cleartext <- case validateSEIPD1MDC nonce decrypted of Left err ->- assertFailure ("validateSEIPD1MDC failed: " ++ err)+ assertFailure+ ("validateSEIPD1MDC failed: " ++ renderMDCFailure err) >> fail "validateSEIPD1MDC failed" Right out -> pure out case parsePktsEither (BL.fromStrict cleartext) of@@ -1260,14 +1321,15 @@ (BL.head (BL.drop midpoint raw) `xor` 0xFF) (BL.drop (midpoint + 1) raw) case decryptMessage passphrase (mkEncryptedPayload tampered) of- Left (MessageDecryptFailureError (PayloadDecryptFailed msg))- | "MDC" `isInfixOf` msg -> pure ()- | otherwise ->- assertFailure- ("Expected MDC-related PayloadDecryptFailed, got: " ++ msg)+ Left+ ( MessageDecryptFailureError+ (PayloadDecryptFailed (PayloadDecryptMDCFailed MDCDigestMismatch))+ ) -> pure () Left err -> assertFailure- ("Expected PayloadDecryptFailed with MDC error, got: " ++ show err)+ ( "Expected PayloadDecryptMDCFailed MDCDigestMismatch, got: "+ ++ show err+ ) Right _ -> assertFailure "Expected MDC tampering rejection, but decryption succeeded"@@ -1287,10 +1349,10 @@ >> pure mempty Right bs -> pure bs case parsePkts signedMessage of- [LiteralDataPkt {}, SignaturePkt _] -> pure ()+ [OnePassSignaturePkt {}, LiteralDataPkt {}, SignaturePkt _] -> pure () _ -> assertFailure- "signing output should contain literal data and one signature packet"+ "signing output should contain one-pass signature, literal data, and one signature packet" testSignMessageRSAV6 :: Assertion testSignMessageRSAV6 = do@@ -1309,7 +1371,8 @@ Right bs -> pure bs signaturePkt <- case parsePkts signedMessage of- [ LiteralDataPkt {}+ [ OnePassSignaturePkt {}+ , LiteralDataPkt {} , sig@(SignaturePkt (SigV6 BinarySig RSA SHA512 salt _ _ _ _)) ] -> do assertEqual@@ -1319,7 +1382,7 @@ pure sig other -> assertFailure- ( "RSA SigV6 signing output should contain [LiteralDataPkt, RSA SigV6], got "+ ( "RSA SigV6 signing output should contain [OPS, LiteralDataPkt, RSA SigV6], got " ++ show other ) >> fail "unexpected RSA SigV6 signMessage output shape"@@ -1364,13 +1427,14 @@ Right bs -> pure bs signaturePkt <- case parsePkts signedMessage of- [ LiteralDataPkt {}+ [ OnePassSignaturePkt {}+ , LiteralDataPkt {} , sig@(SignaturePkt (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _)) ] -> pure sig other -> assertFailure- ( "Ed25519 signing output should contain [LiteralDataPkt, Ed25519 SigV4], got "+ ( "Ed25519 signing output should contain [OPS, LiteralDataPkt, Ed25519 SigV4], got " ++ show other ) >> fail "unexpected Ed25519 signMessage output shape"@@ -1416,7 +1480,8 @@ Right bs -> pure bs signaturePkt <- case parsePkts signedMessage of- [ LiteralDataPkt {}+ [ OnePassSignaturePkt {}+ , LiteralDataPkt {} , sig@(SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _)) ] -> do assertEqual@@ -1426,7 +1491,7 @@ pure sig other -> assertFailure- ( "Ed25519 SigV6 signing output should contain [LiteralDataPkt, Ed25519 SigV6], got "+ ( "Ed25519 SigV6 signing output should contain [OPS, LiteralDataPkt, Ed25519 SigV6], got " ++ show other ) >> fail "unexpected Ed25519 SigV6 signMessage output shape"@@ -1465,7 +1530,7 @@ runPut $ do putWord8 4 putWord32be 0- putWord8 (fromFVal EdDSA)+ putWord8 (fromFVal EdDSALegacy) putWord8 (fromIntegral (B.length legacyEd25519Oid)) putByteString legacyEd25519Oid putWord16be 256@@ -1496,13 +1561,14 @@ Right bs -> pure bs signaturePkt <- case parsePkts signedMessage of- [ LiteralDataPkt {}+ [ OnePassSignaturePkt {}+ , LiteralDataPkt {} , sig@(SignaturePkt (SigV4 BinarySig PKA.Ed448 SHA512 _ _ _ _)) ] -> pure sig other -> assertFailure- ( "Ed448 signing output should contain [LiteralDataPkt, Ed448 SigV4], got "+ ( "Ed448 signing output should contain [OPS, LiteralDataPkt, Ed448 SigV4], got " ++ show other ) >> fail "unexpected Ed448 signMessage output shape"@@ -1548,7 +1614,8 @@ Right bs -> pure bs signaturePkt <- case parsePkts signedMessage of- [ LiteralDataPkt {}+ [ OnePassSignaturePkt {}+ , LiteralDataPkt {} , sig@(SignaturePkt (SigV6 BinarySig PKA.Ed448 SHA512 salt _ _ _ _)) ] -> do assertEqual@@ -1558,7 +1625,7 @@ pure sig other -> assertFailure- ( "Ed448 SigV6 signing output should contain [LiteralDataPkt, Ed448 SigV6], got "+ ( "Ed448 SigV6 signing output should contain [OPS, LiteralDataPkt, Ed448 SigV6], got " ++ show other ) >> fail "unexpected Ed448 SigV6 signMessage output shape"@@ -1791,7 +1858,7 @@ (payloadForSig BinarySig state) assertEqual "Canonical text signatures normalize line endings and trim trailing whitespace"- "line1\r\nline2\r\nline3\r\nline4"+ "line1\r\nline2\rline3\r\nline4" (payloadForSig CanonicalTextSig state) testTextNormalizationModes :: Assertion@@ -1948,7 +2015,7 @@ assertFailure ("failed to derive issuer key id: " ++ err) >> fail "expected issuer key id" Right i -> pure i- let mixedPayload = "line1 \t\nline2\t \rline3\t \r\nline4 \t"+ let mixedPayload = "line1 \nline2\t \r\nline3 \nline4 \t" normalizedPayload = "line1\r\nline2\r\nline3\r\nline4" hashed = [ SigSubPacket@@ -2733,10 +2800,10 @@ >> pure mempty Right bs -> pure bs case parsePkts signedMessage of- [LiteralDataPkt {}, SignaturePkt _] -> pure ()+ [OnePassSignaturePkt {}, LiteralDataPkt {}, SignaturePkt _] -> pure () _ -> assertFailure- "convenience signing output should contain literal data and one signature packet"+ "convenience signing output should contain one-pass signature, literal data, and one signature packet" testTypedVerifySurfaceMatchesLegacy :: Assertion testTypedVerifySurfaceMatchesLegacy = do@@ -2848,13 +2915,14 @@ >> fail "expected signed Ed25519 payload" Right signedMessage -> case parsePkts signedMessage of- [ LiteralDataPkt {}+ [ OnePassSignaturePkt {}+ , LiteralDataPkt {} , sig@(SignaturePkt (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _)) ] -> pure sig other -> assertFailure- ( "Expected [LiteralDataPkt, Ed25519 SigV4] for Ed25519-key-algorithm verification test, got "+ ( "Expected [OPS, LiteralDataPkt, Ed25519 SigV4] for Ed25519-key-algorithm verification test, got " ++ show other ) >> fail "unexpected Ed25519-key-algorithm signature shape"@@ -2952,3 +3020,347 @@ ++ renderVerificationError err ) Right _ -> pure ()++testV6FixtureSignatureCreationAndVerification :: Assertion+testV6FixtureSignatureCreationAndVerification = do+ fixtureResult <- loadV6UnencryptedSecretKeyFixtureForProperty+ (pkp, _ska, skey) <-+ case fixtureResult of+ Left err ->+ assertFailure+ ("failed to load v6 Ed25519 secret fixture: " ++ err)+ >> fail "expected v6 Ed25519 secret fixture"+ Right x -> pure x+ edSecretKey <- extractEd25519SecretKey skey+ let payload = "v6 fixture detached signature payload"+ salt = SignatureSalt (BL.fromStrict (B.replicate 32 0xAB))+ hashed = [SigSubPacket False (SigCreationTime 0)]+ unhashed =+ [ SigSubPacket+ False+ (IssuerFingerprint IssuerFingerprintV6 (fingerprint pkp))+ ]+ sigPayload <-+ case signDataWithEd25519V6+ BinarySig+ salt+ edSecretKey+ hashed+ unhashed+ payload of+ Left err ->+ assertFailure+ ( "v6 fixture Ed25519 detached signing failed: "+ ++ renderSignError err+ )+ >> fail "expected v6 fixture signature"+ Right sig -> pure sig+ let keyring =+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary pkp+ , _tkRevs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ state =+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData BL.empty 0 payload+ }+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeys keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "v6 fixture Ed25519 detached signature should verify: "+ ++ renderVerificationError err+ )+ Right _ -> pure ()++testV6FixtureBinaryMessageSigning :: Assertion+testV6FixtureBinaryMessageSigning = do+ fixtureResult <- loadV6UnencryptedSecretKeyFixtureForProperty+ (pkp, _ska, skey) <-+ case fixtureResult of+ Left err ->+ assertFailure ("failed to load v6 secret fixture: " ++ err)+ >> fail "expected v6 secret fixture"+ Right x -> pure x+ edSecretKey <- extractEd25519SecretKey skey+ let payload = "v6 fixture binary message signing payload"+ salt = SignatureSalt (BL.fromStrict (B.replicate 32 0xCD))+ hashed = [SigSubPacket False (SigCreationTime 0)]+ unhashed =+ [ SigSubPacket+ False+ (IssuerFingerprint IssuerFingerprintV6 (fingerprint pkp))+ ]+ sigPayload <-+ case signDataWithEd25519V6+ BinarySig+ salt+ edSecretKey+ hashed+ unhashed+ payload of+ Left err ->+ assertFailure+ ( "v6 fixture Ed25519 binary signing failed: "+ ++ renderSignError err+ )+ >> fail "expected v6 fixture signature"+ Right sig -> pure sig+ let keyring =+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary pkp+ , _tkRevs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ state =+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData BL.empty 0 payload+ }+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeys keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "v6 fixture Ed25519 binary message signature should verify: "+ ++ renderVerificationError err+ )+ Right _ -> pure ()++testV6FixtureDirectKeySignature :: Assertion+testV6FixtureDirectKeySignature = do+ fixtureResult <- loadV6UnencryptedSecretKeyFixtureForProperty+ (pkp, _ska, skey) <-+ case fixtureResult of+ Left err ->+ assertFailure ("failed to load v6 secret fixture: " ++ err)+ >> fail "expected v6 secret fixture"+ Right x -> pure x+ edSecretKey <- extractEd25519SecretKey skey+ let salt = SignatureSalt (BL.fromStrict (B.replicate 32 0xEF))+ hashed = [SigSubPacket False (SigCreationTime 0)]+ unhashed =+ [ SigSubPacket+ False+ (IssuerFingerprint IssuerFingerprintV6 (fingerprint pkp))+ ]+ keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp))+ sigPayload <-+ case signDataWithEd25519V6+ SignatureDirectlyOnAKey+ salt+ edSecretKey+ hashed+ unhashed+ keypayload of+ Left err ->+ assertFailure+ ( "v6 fixture direct-key signing failed: "+ ++ renderSignError err+ )+ >> fail "expected v6 fixture direct-key signature"+ Right sig -> pure sig+ let keyring =+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary pkp+ , _tkRevs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ state =+ emptyPSC+ { lastPrimaryKey = PublicKeyPkt pkp+ }+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeys keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "v6 fixture direct-key signature should verify: "+ ++ renderVerificationError err+ )+ Right _ -> pure ()++testV6FixtureKeyRevocation :: Assertion+testV6FixtureKeyRevocation = do+ fixtureResult <- loadV6UnencryptedSecretKeyFixtureForProperty+ (pkp, _ska, skey) <-+ case fixtureResult of+ Left err ->+ assertFailure ("failed to load v6 secret fixture: " ++ err)+ >> fail "expected v6 secret fixture"+ Right x -> pure x+ edSecretKey <- extractEd25519SecretKey skey+ let salt = SignatureSalt (BL.fromStrict (B.replicate 32 0x12))+ hashed =+ [ SigSubPacket False (SigCreationTime 0)+ , SigSubPacket+ False+ (ReasonForRevocation KeySuperseded "v6 fixture test")+ ]+ unhashed =+ [ SigSubPacket+ False+ (IssuerFingerprint IssuerFingerprintV6 (fingerprint pkp))+ ]+ keypayload = runPut (putKeyforSigning (PublicKeyPkt pkp))+ sigPayload <-+ case signDataWithEd25519V6+ KeyRevocationSig+ salt+ edSecretKey+ hashed+ unhashed+ keypayload of+ Left err ->+ assertFailure+ ( "v6 fixture key-revocation signing failed: "+ ++ renderSignError err+ )+ >> fail "expected v6 fixture key-revocation signature"+ Right sig -> pure sig+ let keyring =+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary pkp+ , _tkRevs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ state =+ emptyPSC+ { lastPrimaryKey = PublicKeyPkt pkp+ }+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeys keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "v6 fixture key-revocation signature should verify: "+ ++ renderVerificationError err+ )+ Right _ -> pure ()++testV6FixtureCertification :: Assertion+testV6FixtureCertification = do+ fixtureResult <- loadV6UnencryptedSecretKeyFixtureForProperty+ (pkp, _ska, skey) <-+ case fixtureResult of+ Left err ->+ assertFailure ("failed to load v6 secret fixture: " ++ err)+ >> fail "expected v6 secret fixture"+ Right x -> pure x+ edSecretKey <- extractEd25519SecretKey skey+ let uid = UserId "v6 Fixture User"+ uidText = let UserId t = uid in t+ salt = SignatureSalt (BL.fromStrict (B.replicate 32 0x34))+ hashed =+ [ SigSubPacket False (SigCreationTime 0)+ , SigSubPacket False (PrimaryUserId True)+ ]+ unhashed =+ [ SigSubPacket+ False+ (IssuerFingerprint IssuerFingerprintV6 (fingerprint pkp))+ ]+ state =+ emptyPSC+ { lastPrimaryKey = PublicKeyPkt pkp+ , lastUIDorUAt = UserIdPkt uidText+ }+ payload = payloadForSig GenericCert state+ sigPayload <-+ case signDataWithEd25519V6+ GenericCert+ salt+ edSecretKey+ hashed+ unhashed+ payload of+ Left err ->+ assertFailure+ ( "v6 fixture certification signing failed: "+ ++ renderSignError err+ )+ >> fail "expected v6 fixture certification signature"+ Right sig -> pure sig+ let keyring =+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary pkp+ , _tkRevs = []+ , _tkUIDs = [(uidText, [])]+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeys keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "v6 fixture certification signature should verify: "+ ++ renderVerificationError err+ )+ Right _ -> pure ()++testV6RevocationReasonSubpacket :: FilePath -> Assertion+testV6RevocationReasonSubpacket fixture = do+ armors <- loadArmor fixture+ payload <-+ case armors of+ [Armor ArmorPublicKeyBlock _ p] -> pure p+ _ ->+ assertFailure+ (fixture ++ " should contain one armored public-key payload")+ >> fail "expected one armored payload"+ let packets = parsePkts payload+ case packets of+ [ PublicKeyPkt _+ , SignaturePkt (SigV6 KeyRevocationSig _ _ _ hashed unhashed _ _)+ ] ->+ case [ rc+ | SigSubPacket _ (ReasonForRevocation rc _) <-+ hashed ++ unhashed+ ] of+ (rc : _) ->+ assertEqual+ ( fixture+ ++ " ReasonForRevocation code should be NoReason"+ )+ NoReason+ rc+ [] ->+ assertFailure+ ( fixture+ ++ " SigV6 key-revocation signature should include a ReasonForRevocation subpacket"+ )+ _ ->+ assertFailure+ ( fixture+ ++ " should parse as [PublicKeyPkt, SignaturePkt SigV6 KeyRevocationSig]"+ )
tests/Tests/Serialization.hs view
@@ -9,9 +9,11 @@ import Control.Applicative ((<|>)) import Control.Lens ((^.)) import Control.Monad (forM_)+import qualified Crypto.Error as CE import Crypto.Number.Serialize (os2ip) import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Types as ECCT+import qualified Crypto.PubKey.Ed25519 as Ed25519 import Data.Binary (Get, get, put) import Data.Binary.Put ( putByteString@@ -45,7 +47,11 @@ ( eightOctetKeyID , fingerprint )-import Codec.Encryption.OpenPGP.Internal (emptyPSC, point2MBS)+import Codec.Encryption.OpenPGP.Internal+ ( PktStreamContext (..)+ , emptyPSC+ , point2MBS+ ) import Codec.Encryption.OpenPGP.KeyringParser ( parseTKsWithWireRep )@@ -59,6 +65,10 @@ ) import Codec.Encryption.OpenPGP.Signatures ( VerificationError (..)+ , renderSignError+ , renderVerificationError+ , signDataWithEd25519V6+ , verifyAgainstKeys , verifySigWith ) import Codec.Encryption.OpenPGP.Types@@ -66,10 +76,37 @@ import Tests.Common ( armorPayload , loadArmor+ , loadV6UnencryptedSecretKeyFixtureForProperty , readFixturePayload , runGet ) +extractEd25519SecretKeyFromSKey :: SKey -> IO Ed25519.SecretKey+extractEd25519SecretKeyFromSKey skey =+ case skey of+ EdDSAPrivateKey EdSigningCurve25519 bs ->+ case CE.eitherCryptoError (Ed25519.secretKey bs) of+ Left err ->+ assertFailure+ ( "failed to initialize Ed25519 secret key from EdDSAPrivateKey: "+ ++ show err+ )+ >> fail "expected Ed25519 secret key"+ Right edSk -> pure edSk+ Ed25519PrivateKey bs ->+ case CE.eitherCryptoError (Ed25519.secretKey bs) of+ Left err ->+ assertFailure+ ( "failed to initialize Ed25519 secret key from Ed25519PrivateKey: "+ ++ show err+ )+ >> fail "expected Ed25519 secret key"+ Right edSk -> pure edSk+ _ ->+ assertFailure+ "v6-secret fixture did not contain Ed25519 secret key material"+ >> fail "expected Ed25519 secret key"+ serializationTests :: TestTree serializationTests = testGroup@@ -399,6 +436,9 @@ , testCase "v6-secret fixture derives eight-octet key-id from fingerprint prefix" testV6SecretFixtureDerivesEightOctetKeyID+ , testCase+ "v6-secret fixture creates SigV6 with multiple hash algorithms"+ testV6SecretFixtureMultiHashSignatures ] ] @@ -495,7 +535,7 @@ V6 (ThirtyTwoBitTimeStamp 0) 0- EdDSA+ EdDSALegacy (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1))) encoded = runPut (put (PublicKeyPkt pkp)) assertEqual@@ -574,13 +614,13 @@ V6 (ThirtyTwoBitTimeStamp 0) 0- EdDSA+ EdDSALegacy (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1))) sig = SignaturePkt ( SigV6 BinarySig- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0)) [ SigSubPacket@@ -1055,10 +1095,6 @@ ++ show other ) -expectedV6SaltSizeForTest :: HashAlgorithm -> Maybe Int-expectedV6SaltSizeForTest =- fmap fromIntegral . signatureV6SaltSizeForHashAlgorithm- signatureHasIssuerFingerprintV6 :: Fingerprint -> SignaturePayload -> Bool signatureHasIssuerFingerprintV6 expectedFp (SigV6 _ _ _ _ hashed unhashed _ _) =@@ -1107,7 +1143,9 @@ (not (null signatures)) mapM_ ( \(_, ha, salt) ->- case expectedV6SaltSizeForTest ha of+ case fmap+ (fromIntegral :: Word8 -> Int)+ (signatureV6SaltSizeForHashAlgorithm ha) of Nothing -> assertFailure ( "SigV6 in v6-secret.pgp.aa uses unsupported salt hash algorithm: "@@ -1169,3 +1207,76 @@ "v6 eight-octet key-id should be the high-order 64 bits of the fingerprint" expectedKeyId derivedKeyId++testV6SecretFixtureMultiHashSignatures :: Assertion+testV6SecretFixtureMultiHashSignatures = do+ fixtureResult <- loadV6UnencryptedSecretKeyFixtureForProperty+ (pkp, _ska, skey) <-+ case fixtureResult of+ Left err ->+ assertFailure+ ("failed to load v6 secret fixture: " ++ err)+ >> fail "expected v6 secret fixture"+ Right x -> pure x+ edSecretKey <- extractEd25519SecretKeyFromSKey skey+ let payload = "v6 multi-hash fixture payload"+ keyring =+ [ TK+ { _tkPrimaryKey = KeyPktPublicPrimary pkp+ , _tkRevs = []+ , _tkUIDs = []+ , _tkUAts = []+ , _tkSubs = []+ }+ ]+ state =+ emptyPSC+ { lastLD = LiteralDataPkt BinaryData BL.empty 0 payload+ }+ testHash ha = do+ salt <- case signatureV6SaltSizeForHashAlgorithm ha of+ Nothing ->+ assertFailure+ ( "v6 multi-hash fixture does not define salt size for: "+ ++ show ha+ )+ >> fail "expected defined salt size"+ Just sz -> pure (SignatureSalt (BL.replicate (fromIntegral sz) 0xAB))+ let hashed = [SigSubPacket False (SigCreationTime 0)]+ unhashed =+ [ SigSubPacket+ False+ (IssuerFingerprint IssuerFingerprintV6 (fingerprint pkp))+ ]+ sigPayload <-+ case signDataWithEd25519V6+ BinarySig+ salt+ edSecretKey+ hashed+ unhashed+ payload of+ Left err ->+ assertFailure+ ( "v6 fixture signing failed for "+ ++ show ha+ ++ ": "+ ++ renderSignError err+ )+ >> fail "expected v6 fixture signature"+ Right sig -> pure sig+ case verifySigWith+ defaultVerificationPolicy+ (verifyAgainstKeys keyring)+ (SignaturePkt sigPayload)+ state+ Nothing of+ Left err ->+ assertFailure+ ( "v6 fixture signature should verify for "+ ++ show ha+ ++ ": "+ ++ renderVerificationError err+ )+ Right _ -> pure ()+ mapM_ testHash [SHA512]
tests/Tests/Utilities.hs view
@@ -1558,7 +1558,7 @@ V4 (ThirtyTwoBitTimeStamp 0) 0- EdDSA+ EdDSALegacy ( EdDSAPubKey EdSigningCurve25519 ( PrefixedNativeEPoint@@ -1590,12 +1590,12 @@ V6 (ThirtyTwoBitTimeStamp 0) 0- EdDSA+ EdDSALegacy (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1))) invalidSig = SigV6 GenericCert- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x01)) []@@ -1626,12 +1626,12 @@ V6 (ThirtyTwoBitTimeStamp 0) 0- EdDSA+ EdDSALegacy (EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1))) allowedSig = SigV6 KeyRevocationSig- EdDSA+ EdDSALegacy SHA512 (SignatureSalt (BL.replicate 32 0x02)) []