hOpenPGP 3.5.1 → 3.6
raw patch · 48 files changed
+2893/−2240 lines, 48 files
Files
- Codec/Encryption/OpenPGP/Arbitrary.hs +8/−8
- Codec/Encryption/OpenPGP/BlockCipher.hs +5/−21
- Codec/Encryption/OpenPGP/CFB.hs +1/−2
- Codec/Encryption/OpenPGP/Compression.hs +34/−57
- Codec/Encryption/OpenPGP/Encrypt.hs +56/−221
- Codec/Encryption/OpenPGP/Fingerprint.hs +9/−4
- Codec/Encryption/OpenPGP/Internal.hs +12/−11
- Codec/Encryption/OpenPGP/Internal/CryptoCipherTypes.hs +41/−34
- Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs +5/−4
- Codec/Encryption/OpenPGP/Internal/Crypton.hs +16/−15
- Codec/Encryption/OpenPGP/Internal/HOBlockCipher.hs +29/−18
- Codec/Encryption/OpenPGP/KeyGeneration.hs +1/−1
- Codec/Encryption/OpenPGP/KeyInfo.hs +5/−2
- Codec/Encryption/OpenPGP/KeySelection.hs +19/−14
- Codec/Encryption/OpenPGP/KeyringParser.hs +0/−13
- Codec/Encryption/OpenPGP/Message.hs +23/−144
- Codec/Encryption/OpenPGP/S2K.hs +8/−72
- Codec/Encryption/OpenPGP/SEIPDv1.hs +5/−14
- Codec/Encryption/OpenPGP/SEIPDv2.hs +15/−68
- Codec/Encryption/OpenPGP/SecretKey.hs +249/−262
- Codec/Encryption/OpenPGP/Serialize.hs +290/−193
- Codec/Encryption/OpenPGP/SerializeForSigs.hs +9/−2
- Codec/Encryption/OpenPGP/Signatures.hs +78/−216
- Codec/Encryption/OpenPGP/Signing.hs +10/−58
- Codec/Encryption/OpenPGP/Types.hs +1/−0
- Codec/Encryption/OpenPGP/Types/Internal/Base.hs +17/−1
- Codec/Encryption/OpenPGP/Types/Internal/CryptonNewtypes.hs +133/−119
- Codec/Encryption/OpenPGP/Types/Internal/Errors.hs +1332/−0
- Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs +20/−25
- Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs +53/−27
- Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs +24/−26
- Codec/Encryption/OpenPGP/Types/Internal/PrettyUtils.hs +1/−1
- Codec/Encryption/OpenPGP/Types/Internal/TK.hs +1/−23
- Codec/Encryption/OpenPGP/Version.hs +3/−2
- Data/Conduit/OpenPGP/Compression.hs +15/−12
- Data/Conduit/OpenPGP/Decrypt.hs +40/−220
- Data/Conduit/OpenPGP/Keyring.hs +1/−2
- Data/Conduit/OpenPGP/Message.hs +71/−64
- Data/Conduit/OpenPGP/Verify.hs +12/−4
- hOpenPGP.cabal +8/−7
- tests/Tests/Common.hs +46/−48
- tests/Tests/Encryption.hs +125/−142
- tests/Tests/KeyGeneration.hs +1/−1
- tests/Tests/Keys.hs +13/−7
- tests/Tests/MessageAndArmor.hs +17/−19
- tests/Tests/Properties.hs +16/−23
- tests/Tests/Serialization.hs +12/−10
- tests/Tests/Utilities.hs +3/−3
Codec/Encryption/OpenPGP/Arbitrary.hs view
@@ -4,6 +4,7 @@ -- (See the LICENSE file). {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-} module Codec.Encryption.OpenPGP.Arbitrary (@@ -30,6 +31,7 @@ import Test.QuickCheck.Instances () import Codec.Encryption.OpenPGP.Types+import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes instance Arbitrary (PKESK 'PKESKV3) where arbitrary = do@@ -56,21 +58,19 @@ instance Arbitrary (PKESK 'PKESKV6) where arbitrary = do- rid <-+ mKvFp <- oneof- [ pure B.empty- , B.pack <$> vector 20- , B.pack . (4 :) <$> vector 20- , B.pack <$> vector 32- , B.pack . (6 :) <$> vector 32+ [ pure Nothing+ , (Just . (V4,)) . Fingerprint <$> (B.pack <$> vector 20)+ , (Just . (V6,)) . Fingerprint <$> (B.pack <$> vector 32) ] pka <- arbitrary esk <- B.pack <$> listOf1 arbitrary- pure (PKESK6Packet rid pka esk)+ pure (PKESK6Packet mKvFp pka (EncryptedSessionKey esk)) instance Arbitrary (SKESK 'SKESKV4) where arbitrary = do- sa <- elements [AES128, AES192, AES256]+ sa <- elements [Camellia128, AES128, AES192, AES256] s2k <- arbitrarySKESKv4S2K esk <- oneof [pure Nothing, Just . B.pack <$> listOf1 arbitrary] pure (SKESK4Packet sa s2k esk)
Codec/Encryption/OpenPGP/BlockCipher.hs view
@@ -5,9 +5,7 @@ {-# LANGUAGE RankNTypes #-} module Codec.Encryption.OpenPGP.BlockCipher- ( CipherError (..)- , renderCipherError- , keySize+ ( keySize , supportedSymmetricAlgorithmsForCFB , withSymmetricCipher ) where@@ -28,24 +26,10 @@ ) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types---- | Errors that can arise from block-cipher operations in this library.-data CipherError- = -- | The algorithm is not supported or not implemented.- UnsupportedAlgorithm SymmetricAlgorithm- | -- | Cipher initialization failed (bad key material).- CipherInitFailed SymmetricAlgorithm String- | -- | A CFB or other block-cipher operation failed.- CipherOperationFailed String- deriving (Eq, Show)--renderCipherError :: CipherError -> String-renderCipherError (UnsupportedAlgorithm sa) =- "Unsupported symmetric algorithm: " ++ show sa-renderCipherError (CipherInitFailed sa msg) =- "Cipher initialization failed for " ++ show sa ++ ": " ++ msg-renderCipherError (CipherOperationFailed msg) =- "Cipher operation failed: " ++ msg+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( CipherError (..)+ , renderCipherError+ ) type HOCipher a = forall cipher
Codec/Encryption/OpenPGP/CFB.hs view
@@ -22,8 +22,7 @@ import qualified Data.ByteString as B import Codec.Encryption.OpenPGP.BlockCipher- ( CipherError (..)- , withSymmetricCipher+ ( withSymmetricCipher ) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher import Codec.Encryption.OpenPGP.Types
Codec/Encryption/OpenPGP/Compression.hs view
@@ -4,85 +4,62 @@ -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Compression- ( CompressionError(..)- , renderCompressionError- , decompressPkt- , compressPkts- ) where+ ( decompressPkt+ , compressPkts+ ) where import qualified Codec.Compression.BZip as BZip import qualified Codec.Compression.Zlib as Zlib import qualified Codec.Compression.Zlib.Raw as ZlibRaw-import Codec.Encryption.OpenPGP.Serialize ()-import Codec.Encryption.OpenPGP.Types import Data.Binary (get, put) import Data.Binary.Get (runGetOrFail) import Data.Binary.Put (runPut) import qualified Data.ByteString.Lazy as BL --- | Errors that can arise during decompression of an OpenPGP Compressed Data--- packet. Note that corrupt stream exceptions from the underlying--- zlib\/bzip2 library are not captured here; they propagate as 'IOException'--- through the call stack.-data CompressionError- = -- | The compressed payload bytes are empty; nothing to decompress.- EmptyCompressedPayload CompressionAlgorithm- | -- | Decompression succeeded but the binary parse of the inner packet- -- sequence failed.- InnerPacketParseFailed CompressionAlgorithm String- | -- | Decompression and parse succeeded but produced no packets at all- -- (zero-length uncompressed payload).- ZeroLengthDecompressedPayload CompressionAlgorithm- | -- | The decompressed content contains only Marker packets (RFC4880 §5.8- -- marker packets carry no semantic content).- MarkerOnlyPayload CompressionAlgorithm- deriving (Eq, Show)--renderCompressionError :: CompressionError -> String-renderCompressionError (EmptyCompressedPayload algo) =- "Compressed Data packet (" ++ show algo ++ "): empty compressed payload"-renderCompressionError (InnerPacketParseFailed algo err) =- "Compressed Data packet (" ++ show algo ++ "): inner packet parse failed: " ++ err-renderCompressionError (ZeroLengthDecompressedPayload algo) =- "Compressed Data packet (" ++ show algo ++ "): zero-length decompressed payload"-renderCompressionError (MarkerOnlyPayload algo) =- "Compressed Data packet (" ++ show algo ++ "): decompressed content contains only Marker packets"+import Codec.Encryption.OpenPGP.Serialize ()+import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( CompressionError (..)+ , renderCompressionError+ ) --- | Decompress an OpenPGP Compressed Data packet, classifying structural--- failures as 'CompressionError'. Non-Compressed-Data packets are returned--- unchanged in @Right [p]@. Corrupt compressed streams may still throw--- 'IOException' from the underlying decompression library.+{- | Decompress an OpenPGP Compressed Data packet, classifying structural+failures as 'CompressionErrorReason. Non-Compressed-Data packets are returned+unchanged in @Right [p]@. Corrupt compressed streams may still throw+'IOException' from the underlying decompression library.+-} decompressPkt :: Pkt -> Either CompressionError [Pkt] decompressPkt compressed@(CompressedDataPkt (OtherCA _) _) = Right [compressed] decompressPkt (CompressedDataPkt algo bs)- | BL.null bs = Left (EmptyCompressedPayload algo)- | otherwise =- case runGetOrFail get (dfunc algo bs) of- Left (_, _, err) -> Left (InnerPacketParseFailed algo err)- Right (_, _, packs) ->- let pkts = unBlock packs- in case pkts of- [] -> Left (ZeroLengthDecompressedPayload algo)- _ | all isMarkerPkt pkts -> Left (MarkerOnlyPayload algo)- _ -> Right pkts+ | BL.null bs = Left (EmptyCompressedPayload algo)+ | otherwise =+ case runGetOrFail get (dfunc algo bs) of+ Left (_, _, err) -> Left (InnerPacketParseFailed algo err)+ Right (_, _, packs) ->+ let pkts = unBlock packs+ in case pkts of+ [] -> Left (ZeroLengthDecompressedPayload algo)+ _ | all isMarkerPkt pkts -> Left (MarkerOnlyPayload algo)+ _ -> Right pkts where dfunc Uncompressed = id- dfunc ZIP = ZlibRaw.decompress- dfunc ZLIB = Zlib.decompress- dfunc BZip2 = BZip.decompress- dfunc (OtherCA _) = id+ dfunc ZIP = ZlibRaw.decompress+ dfunc ZLIB = Zlib.decompress+ dfunc BZip2 = BZip.decompress+ dfunc (OtherCA _) = id decompressPkt p = Right [p] isMarkerPkt :: Pkt -> Bool isMarkerPkt (MarkerPkt _) = True-isMarkerPkt _ = False+isMarkerPkt _ = False compressPkts :: CompressionAlgorithm -> [Pkt] -> Pkt compressPkts ca packs =- let bs = runPut $ put (Block packs)- cbs = cfunc ca bs- outAlgo = if isSupportedCompressionAlgorithm ca then ca else Uncompressed- in CompressedDataPkt outAlgo cbs+ let bs = runPut $ put (Block packs)+ cbs = cfunc ca bs+ outAlgo =+ if isSupportedCompressionAlgorithm ca then ca else Uncompressed+ in CompressedDataPkt outAlgo cbs where cfunc Uncompressed = id cfunc ZIP = ZlibRaw.compress
Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -12,11 +12,7 @@ {-# LANGUAGE TypeFamilies #-} module Codec.Encryption.OpenPGP.Encrypt- ( PKESKEncryptError (..)- , renderPKESKEncryptError- , RecipientCapabilityNegotiationMode (..)- , RecipientCapabilityError (..)- , renderRecipientCapabilityError+ ( RecipientCapabilityNegotiationMode (..) , RecipientCapabilities (..) , recipientCapabilitiesFromSubpacketPayloads , recipientCapabilitySupportsEncryption@@ -70,8 +66,6 @@ , pkeskV6RawSessionMaterial , encodeOpenPGPSessionMaterial , generateSessionKeyMaterial- , canonicalizePKESKRecipientId- , canonicalizePKESKPacketRecipientIds , buildPKESKv3PayloadForRecipient , buildPKESKv3PktForRecipient , buildPKESKPayloadForRecipient@@ -84,8 +78,6 @@ , encryptSEIPDv2LiteralDataWithSKESK , composeMessageWithSEIPDv2 , buildOnePassSignature- , OPSBuildError (..)- , renderOPSBuildError , NestedFlag , aesKeyWrapRFC3394 , deriveX25519Kek@@ -133,9 +125,7 @@ import qualified "crypton" Crypto.Cipher.Types as CCT import Codec.Encryption.OpenPGP.BlockCipher- ( CipherError (..)- , keySize- , renderCipherError+ ( keySize , supportedSymmetricAlgorithmsForCFB , withSymmetricCipher )@@ -198,11 +188,9 @@ ) import Codec.Encryption.OpenPGP.SEIPDv1 (mdcTrailerForSEIPDv1) import Codec.Encryption.OpenPGP.SEIPDv2- ( SEIPDv2Failure (..)- , aeadModeAndNonceSizeForSEIPDv2+ ( aeadModeAndNonceSizeForSEIPDv2 , deriveSKESK6KEK , encryptSKESK6SessionKey- , renderSEIPDv2Failure , seipdv2SymmetricKeySize , supportedSEIPDv2AEADAlgorithms , supportedSEIPDv2SymmetricAlgorithms@@ -215,129 +203,11 @@ import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes --- | Typed failures from one-pass signature packet construction.-data OPSBuildError- = OPSBuildMissingIssuerKeyId- | OPSBuildMissingIssuerFingerprint- | OPSBuildFingerprintWrongLength Int64- | OPSBuildUnsupportedSigVersion PacketVersion- | OPSBuildIssuerKeyIdProhibitedInV6- deriving (Eq, Show)--renderOPSBuildError :: OPSBuildError -> String-renderOPSBuildError OPSBuildMissingIssuerKeyId =- "cannot build OPS3 packet from v4 signature without issuer metadata"-renderOPSBuildError OPSBuildMissingIssuerFingerprint =- "cannot build OPS6 packet from v6 signature without issuer fingerprint"-renderOPSBuildError (OPSBuildFingerprintWrongLength n) =- "cannot build OPS6 packet: issuer fingerprint must be 32 octets, got "- ++ show n-renderOPSBuildError (OPSBuildUnsupportedSigVersion v) =- "cannot build one-pass signature packet for unsupported signature version "- ++ show v-renderOPSBuildError OPSBuildIssuerKeyIdProhibitedInV6 =- "cannot build OPS3 packet: Issuer Key ID subpacket is prohibited in v6 signatures"---- | Typed failures surfaced by encrypt-side PKESK and SEIPD-v2 helpers.-data PKESKEncryptError- = UnsupportedSessionKeyAlgorithm SymmetricAlgorithm String- | InvalidSessionKeyLength SymmetricAlgorithm Int Int- | InvalidRecipientIdentifier String- | UnsupportedRecipientAlgorithm PubKeyAlgorithm- | InvalidRecipientKeyMaterial PubKeyAlgorithm String- | RecipientKdfFailure PubKeyAlgorithm String- | RecipientKeyWrapFailure PubKeyAlgorithm String- | RecipientKeyWrapFailureCipher PubKeyAlgorithm CipherError- | RecipientCapabilitySelectionFailure RecipientCapabilityError- | PayloadBuildFailure String- | PayloadBuildFailureCipher CipherError- | NoRecipientsProvided- deriving (Eq, Show)--renderPKESKEncryptError :: PKESKEncryptError -> String-renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm algo reason) =- "unsupported session key algorithm "- ++ show algo- ++ ": "- ++ reason-renderPKESKEncryptError (InvalidSessionKeyLength algo expected actual) =- "invalid session key length for "- ++ show algo- ++ ": expected "- ++ show expected- ++ ", got "- ++ show actual-renderPKESKEncryptError (InvalidRecipientIdentifier reason) =- "invalid recipient identifier: " ++ reason-renderPKESKEncryptError (UnsupportedRecipientAlgorithm algo) =- "unsupported recipient public-key algorithm: " ++ show algo-renderPKESKEncryptError (InvalidRecipientKeyMaterial algo reason) =- "invalid recipient key material for "- ++ show algo- ++ ": "- ++ reason-renderPKESKEncryptError (RecipientKdfFailure algo reason) =- "KDF failure for recipient algorithm "- ++ show algo- ++ ": "- ++ reason-renderPKESKEncryptError (RecipientKeyWrapFailure algo reason) =- "key wrap failure for recipient algorithm "- ++ 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"- data RecipientCapabilityNegotiationMode = RecipientCapabilityNegotiationOff | RecipientCapabilityNegotiationOn deriving (Eq, Show) -data RecipientCapabilityError- = RecipientCapabilityMissingEncryptionFlags- SomePKPayload- (Set.Set KeyFlag)- | RecipientCapabilityNoEncryptableKeyMaterialInTK- | RecipientCapabilityMissingSEIPDv1Support [SomePKPayload]- | RecipientCapabilityMissingSEIPDv2Support [SomePKPayload]- | RecipientCapabilityNoCommonSymmetricAlgorithms- [SymmetricAlgorithm]- | RecipientCapabilityNoCommonAEADAlgorithms [AEADAlgorithm]- deriving (Eq, Show)--renderRecipientCapabilityError- :: RecipientCapabilityError -> String-renderRecipientCapabilityError (RecipientCapabilityMissingEncryptionFlags recipient flags) =- "recipient "- ++ show (_keyVersion recipient, _pkalgo recipient)- ++ " does not advertise encryption-capable key flags; observed flags: "- ++ show (Set.toList flags)-renderRecipientCapabilityError RecipientCapabilityNoEncryptableKeyMaterialInTK =- "no encryption-capable primary key or subkey was found in transferable key material"-renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv1Support recipients) =- "recipient set does not advertise SEIPDv1 (MDC) support: "- ++ show (map (\r -> (_keyVersion r, _pkalgo r)) recipients)-renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv2Support recipients) =- "recipient set does not advertise SEIPDv2 support: "- ++ show (map (\r -> (_keyVersion r, _pkalgo r)) recipients)-renderRecipientCapabilityError (RecipientCapabilityNoCommonSymmetricAlgorithms syms) =- "no common recipient-supported symmetric algorithms: "- ++ show syms-renderRecipientCapabilityError (RecipientCapabilityNoCommonAEADAlgorithms aeads) =- "no common recipient-supported AEAD algorithms: " ++ show aeads- data RecipientCapabilities = RecipientCapabilities { recipientCapabilityKeyVersion :: KeyVersion@@ -799,7 +669,7 @@ validatedSessionKeyBytes symalgo (SessionKey sessionKey) = do keyLen <- first- (UnsupportedSessionKeyAlgorithm symalgo . renderCipherError)+ (UnsupportedSessionKeyAlgorithm symalgo) (keySize symalgo) let actualLen = B.length sessionKey if actualLen /= keyLen@@ -1111,27 +981,27 @@ buildV4 = do keyLen <- first- (UnsupportedSessionKeyAlgorithm symalgo . renderCipherError)+ (UnsupportedSessionKeyAlgorithm symalgo) $ keySize symalgo _wrappingKey <-- first (PayloadBuildFailure . show) $+ first PayloadBuildFailureS2K $ string2Key s2k keyLen password pure . SKESKPkt . SKESKPayloadV4Packet $ SKESKPayloadV4 symalgo s2k Nothing buildV6 = do keyLen <- first- (UnsupportedSessionKeyAlgorithm symalgo . renderCipherError)+ (UnsupportedSessionKeyAlgorithm symalgo) $ keySize symalgo wrappingKey <-- first (PayloadBuildFailure . show) $+ first PayloadBuildFailureS2K $ string2Key s2k keyLen password let iv = B.take nonceSize (unSalt (sharedSessionSalt request)) kek <-- first (PayloadBuildFailure . renderSEIPDv2Failure) $+ first PayloadBuildFailureSEIPDv2 $ deriveSKESK6KEK symalgo aead wrappingKey (wrapped, tag) <-- first (PayloadBuildFailure . renderSEIPDv2Failure) $+ first PayloadBuildFailureSEIPDv2 $ encryptSKESK6SessionKey symalgo aead@@ -1207,53 +1077,13 @@ Left err -> pure ( Left- (UnsupportedSessionKeyAlgorithm symalgo (renderCipherError err))+ (UnsupportedSessionKeyAlgorithm symalgo err) ) Right keyLen -> do sessionKeyBytes <- getRandomBytes keyLen let sessionKey = SessionKey sessionKeyBytes pure (mkPKESKSessionMaterial symalgo sessionKey) -canonicalizePKESKRecipientId- :: PKESKPayload -> Either PKESKEncryptError PKESKPayload-canonicalizePKESKRecipientId payload =- case payload of- PKESKPayloadV6Packet payloadV6 ->- PKESKPayloadV6Packet <$> canonicalizePKESKRecipientIdV6 payloadV6- _ -> Right payload--canonicalizePKESKRecipientIdV6- :: PKESKPayloadV6 -> Either PKESKEncryptError PKESKPayloadV6-canonicalizePKESKRecipientIdV6 (PKESKPayloadV6 rid pka esk) =- (\normalizedRid -> PKESKPayloadV6 normalizedRid pka esk)- <$> canonicalizeRecipientKeyIdentifier rid--canonicalizeRecipientKeyIdentifier- :: B.ByteString -> Either PKESKEncryptError B.ByteString-canonicalizeRecipientKeyIdentifier rid- | B.length rid == 20 || B.length rid == 32 = Right rid- | B.length rid == 21 && B.head rid == 0x04 =- Right (B.tail rid)- | B.length rid == 33 && B.head rid == 0x06 =- Right (B.tail rid)- | otherwise =- Left- ( InvalidRecipientIdentifier- ( "unsupported PKESK recipient identifier length/prefix: "- ++ show (B.length rid)- )- )--canonicalizePKESKPacketRecipientIds- :: [Pkt] -> Either PKESKEncryptError [Pkt]-canonicalizePKESKPacketRecipientIds =- mapM- ( \pkt ->- case pkt of- PKESKPkt payload -> fmap PKESKPkt (canonicalizePKESKRecipientId payload)- _ -> Right pkt- )- -- | Build a v6 PKESK payload for one recipient key according to the selected version policy. buildPKESKPayloadForRecipient :: MonadRandom m@@ -1365,8 +1195,7 @@ (RecipientForceV3Payload v3Material) ) targets- pure- (sequence pkeskResults >>= canonicalizePKESKPacketRecipientIds)+ pure (sequence pkeskResults) preparePKESKVersionedMaterial :: PKESKSessionMaterial@@ -1623,7 +1452,7 @@ Nothing -> let keyBytes = unSessionKey (pkeskSessionKey sessionMaterial) in case withSymmetricCipher symalgo keyBytes (\c -> Right (blockSize c)) of- Left err -> pure (Left (PayloadBuildFailure (renderCipherError err)))+ Left err -> pure (Left (PayloadBuildFailureCipher err)) Right n -> getRandomBytes n >>= \bytes -> pure $@@ -1862,7 +1691,7 @@ buildEncryptedPacketSequenceWithShape symalgo aead chunkSize payloadShape salt sessionKey pkesks payload = do onePassSignatures <- first- (PayloadBuildFailure . renderOPSBuildError)+ PayloadBuildFailureOPSBuild (buildOnePassSignaturePackets payloadShape) let signatures = recipientPayloadSignatures payloadShape literalBlock =@@ -1877,7 +1706,7 @@ ++ map SignaturePkt signatures ) ciphertext <-- first (PayloadBuildFailure . renderSEIPDv2Failure) $+ first PayloadBuildFailureSEIPDv2 $ encryptSEIPDv2Payload symalgo aead@@ -1921,7 +1750,7 @@ buildEncryptedPacketSequenceWithShapeSEIPDv1 symalgo iv payloadShape sessionKey pkesks payload = do onePassSignatures <- first- (PayloadBuildFailure . renderOPSBuildError)+ PayloadBuildFailureOPSBuild (buildOnePassSignaturePackets payloadShape) let signatures = recipientPayloadSignatures payloadShape literalBlock =@@ -2171,11 +2000,11 @@ ( \esk -> let mpiEsk = runPut (put (MPI (os2ip esk))) in PKESKPayloadV6- (recipientKeyIdentifier recipient)+ (Just (_keyVersion recipient, fingerprint recipient)) RSA- (BL.toStrict mpiEsk)+ (EncryptedSessionKey (BL.toStrict mpiEsk)) )- (first (RecipientKeyWrapFailure RSA . show) encrypted)+ (first (RecipientKeyWrapFailureRSA RSA) encrypted) _ -> pure ( Left@@ -2197,9 +2026,9 @@ Left err -> pure ( Left- ( InvalidRecipientKeyMaterial+ ( InvalidRecipientKeyMaterialKeyId (_pkalgo recipient)- ("failed to derive PKESKv3 recipient key ID: " ++ err)+ err ) ) Right eoki -> do@@ -2215,7 +2044,7 @@ (MPI (os2ip esk) :| []) ) ( first- (RecipientKeyWrapFailure (_pkalgo recipient) . show)+ (RecipientKeyWrapFailureRSA (_pkalgo recipient)) encrypted ) _ ->@@ -2239,9 +2068,9 @@ Left err -> pure ( Left- ( InvalidRecipientKeyMaterial+ ( InvalidRecipientKeyMaterialKeyId ECDH- ("failed to derive PKESKv3 recipient key ID: " ++ err)+ err ) ) Right eoki ->@@ -2284,11 +2113,11 @@ recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint) ephSecret <-- first (RecipientKeyWrapFailure ECDH . show)+ first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError $ C25519.secretKey (leftPadTo 32 ephSecretRaw) recipientPub <-- first (RecipientKeyWrapFailure ECDH . show)+ first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError $ C25519.publicKey recipientPublicBytes let ephPublicBytes =@@ -2369,11 +2198,11 @@ recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint) ephSecret <-- first (RecipientKeyWrapFailure ECDH . show)+ first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError $ C25519.secretKey (leftPadTo 32 ephSecretRaw) recipientPub <-- first (RecipientKeyWrapFailure ECDH . show)+ first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError $ C25519.publicKey recipientPublicBytes let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString@@ -2394,11 +2223,11 @@ recipientPublicBytes <- normalizeX448Public (edPointBytes recipientPoint) ephSecret <-- first (RecipientKeyWrapFailure ECDH . show)+ first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError $ C448.secretKey (leftPadTo 56 ephSecretRaw) recipientPub <-- first (RecipientKeyWrapFailure ECDH . show)+ first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError $ C448.publicKey recipientPublicBytes let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString@@ -2440,11 +2269,11 @@ do recipientPublic <- extractX25519RecipientPublic recipient ephSecret <-- first (RecipientKeyWrapFailure X25519 . show)+ first (RecipientKeyWrapFailureCrypto X25519) . CE.eitherCryptoError $ C25519.secretKey (leftPadTo 32 ephSecretRaw) recipientPub <-- first (RecipientKeyWrapFailure X25519 . show)+ first (RecipientKeyWrapFailureCrypto X25519) . CE.eitherCryptoError $ C25519.publicKey recipientPublic let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString@@ -2457,9 +2286,9 @@ esk <- encodeV6X25519Esk ephPublicBytes wrapped Right ( PKESKPayloadV6- (recipientKeyIdentifier recipient)+ (Just (_keyVersion recipient, fingerprint recipient)) X25519- esk+ (EncryptedSessionKey esk) ) buildX448PKESKv6@@ -2473,11 +2302,11 @@ do recipientPublic <- extractX448RecipientPublic recipient ephSecret <-- first (RecipientKeyWrapFailure X448 . show)+ first (RecipientKeyWrapFailureCrypto X448) . CE.eitherCryptoError $ C448.secretKey (leftPadTo 56 ephSecretRaw) recipientPub <-- first (RecipientKeyWrapFailure X448 . show)+ first (RecipientKeyWrapFailureCrypto X448) . CE.eitherCryptoError $ C448.publicKey recipientPublic let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString@@ -2490,9 +2319,9 @@ esk <- encodeV6X448Esk ephPublicBytes wrapped Right ( PKESKPayloadV6- (recipientKeyIdentifier recipient)+ (Just (_keyVersion recipient, fingerprint recipient)) X448- esk+ (EncryptedSessionKey esk) ) buildEcdhV6Esk@@ -2519,9 +2348,9 @@ esk <- encodeV6EcdhEsk ephemeralBytes wrapped Right ( PKESKPayloadV6- (recipientKeyIdentifier recipient)+ (Just (_keyVersion recipient, fingerprint recipient)) pka- esk+ (EncryptedSessionKey esk) ) buildEcdhV3Payload@@ -2554,9 +2383,6 @@ (MPI (os2ip ephemeralBytes) :| [MPI (os2ip wrapped)]) ) -recipientKeyIdentifier :: SomePKPayload -> B.ByteString-recipientKeyIdentifier = unFingerprint . fingerprint- encodeV6EcdhEsk :: B.ByteString -> B.ByteString@@ -2905,15 +2731,24 @@ messageKey = B.take keyLen okm noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm) withAESCipher- SEIPDv2CipherInitFailed+ (SEIPDv2CipherFailed . CipherInitFailed symalgo . show) (SEIPDv2UnsupportedSymmetricAlgorithm symalgo) symalgo messageKey- (encryptChunks aead mode info chunkSize noncePrefix plaintext)+ ( encryptChunks+ symalgo+ aead+ mode+ info+ chunkSize+ noncePrefix+ plaintext+ ) encryptChunks :: CCT.BlockCipher cipher- => AEADAlgorithm+ => SymmetricAlgorithm+ -> AEADAlgorithm -> CCT.AEADMode -> B.ByteString -> Word8@@ -2921,7 +2756,7 @@ -> B.ByteString -> cipher -> Either SEIPDv2Failure B.ByteString-encryptChunks aead mode info chunkSize noncePrefix plaintext cipher = go 0 plaintext [] 0+encryptChunks symalgo aead mode info chunkSize noncePrefix plaintext cipher = go 0 plaintext [] 0 where chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6) go idx remaining acc totalPlain@@ -2929,7 +2764,7 @@ (finalTag, finalCipher) <- if mode == CCT.AEAD_OCB then- first SEIPDv2CipherInitFailed $+ first SEIPDv2CipherFailed $ encryptWithOCBRFC7253 cipher (noncePrefix <> encodeWord64be idx)@@ -2958,7 +2793,7 @@ (tag, chunkCipher) <- if mode == CCT.AEAD_OCB then- first SEIPDv2CipherInitFailed $+ first SEIPDv2CipherFailed $ encryptWithOCBRFC7253 cipher (noncePrefix <> encodeWord64be idx)@@ -2975,7 +2810,7 @@ (totalPlain + B.length chunkPlain) initAEAD idx =- first SEIPDv2CipherInitFailed+ first (SEIPDv2CipherFailed . CipherInitFailed symalgo . show) . CE.eitherCryptoError $ CCT.aeadInit mode cipher (noncePrefix <> encodeWord64be idx)
Codec/Encryption/OpenPGP/Fingerprint.hs view
@@ -24,25 +24,30 @@ ( putPKPforFingerprinting ) import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( KeyIdError (..)+ , renderKeyIdError+ ) -eightOctetKeyID :: SomePKPayload -> Either String EightOctetKeyId+eightOctetKeyID+ :: SomePKPayload -> Either KeyIdError EightOctetKeyId eightOctetKeyID pkp = case classifyFingerprintingKey pkp of FingerprintingV3RSA _ rp -> Right (v3RSAKeyId rp) FingerprintingV3NonRSA _ ->- Left "Cannot calculate the key ID of a non-RSA V3 key"+ Left KeyIdUnsupportedNonRSAV3 FingerprintingV4 pkpV4 -> keyIdFromFingerprint (fingerprintV4 pkpV4) FingerprintingV6 pkpV6 -> keyIdFromFingerprint (fingerprintV6 pkpV6) keyIdFromFingerprint- :: Fingerprint -> Either String EightOctetKeyId+ :: Fingerprint -> Either KeyIdError EightOctetKeyId keyIdFromFingerprint (Fingerprint bs) | B.length bs == 20 = Right (EightOctetKeyId (B.drop 12 bs)) | B.length bs == 32 = Right (EightOctetKeyId (B.take 8 bs)) | otherwise =- Left "cannot derive key ID from fingerprint of unexpected length"+ Left (KeyIdFingerprintLengthMismatch (B.length bs)) fingerprint :: SomePKPayload -> Fingerprint fingerprint pkp =
Codec/Encryption/OpenPGP/Internal.hs view
@@ -45,6 +45,10 @@ ( isIssuerSSP ) import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( CurveConversionError (..)+ , renderCurveConversionError+ ) countBits :: ByteString -> Word16 countBits bs@@ -206,7 +210,8 @@ where n = p - multiplicativeInverse p (q `mod` p) -curveoidBSToCurve :: B.ByteString -> Either String ECCCurve+curveoidBSToCurve+ :: B.ByteString -> Either CurveConversionError ECCCurve curveoidBSToCurve oidbs | B.pack [0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07] == oidbs = Right $ NISTP256 -- ECCT.getCurveByName ECCT.SEC_p256r1@@ -221,9 +226,10 @@ | B.pack [0x2B, 0x65, 0x6F] == oidbs = Right Curve448 | otherwise =- Left $ concat ["unknown curve (...", show (B.unpack oidbs), ")"]+ Left (CurveConversionUnsupportedCurve oidbs) -curveToCurveoidBS :: ECCCurve -> Either String B.ByteString+curveToCurveoidBS+ :: ECCCurve -> Either CurveConversionError B.ByteString curveToCurveoidBS NISTP256 = Right $ B.pack [0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07] curveToCurveoidBS NISTP384 = Right $ B.pack [0x2B, 0x81, 0x04, 0x00, 0x22]@@ -256,7 +262,7 @@ "OpenPGP EC point serialization requires equal non-empty coordinate widths" curveoidBSToEdSigningCurve- :: B.ByteString -> Either String EdSigningCurve+ :: B.ByteString -> Either CurveConversionError EdSigningCurve curveoidBSToEdSigningCurve oidbs | B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01] == oidbs =@@ -264,15 +270,10 @@ | B.pack [0x2B, 0x65, 0x71] == oidbs = Right EdSigningCurve448 | otherwise =- Left $- concat- [ "unknown Edwards signing curve (..."- , show (B.unpack oidbs)- , ")"- ]+ Left (CurveConversionUnsupportedEdCurve oidbs) edSigningCurveToCurveoidBS- :: EdSigningCurve -> Either String B.ByteString+ :: EdSigningCurve -> Either CurveConversionError B.ByteString edSigningCurveToCurveoidBS EdSigningCurve25519 = Right $ B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01]
Codec/Encryption/OpenPGP/Internal/CryptoCipherTypes.hs view
@@ -7,53 +7,60 @@ {-# LANGUAGE UndecidableInstances #-} module Codec.Encryption.OpenPGP.Internal.CryptoCipherTypes- ( HOWrappedOldCCT(..)- ) where+ ( HOWrappedOldCCT (..)+ ) where import Control.Error.Util (note)+import qualified Data.ByteString as B import qualified "crypto-cipher-types" Crypto.Cipher.Types as OldCCT import qualified "crypton" Crypto.Cipher.Types as CCT-import qualified Data.ByteString as B import Codec.Encryption.OpenPGP.Internal.HOBlockCipher -newtype HOWrappedOldCCT a =- HWOCCT a+newtype HOWrappedOldCCT a+ = HWOCCT a -instance OldCCT.BlockCipher cipher =>- HOBlockCipher (HOWrappedOldCCT cipher) where- cipherInit =- fmap HWOCCT .- either (const (Left "nettle invalid key")) (Right . OldCCT.cipherInit) .- OldCCT.makeKey- cipherName (HWOCCT c) = OldCCT.cipherName c- cipherKeySize (HWOCCT c) = convertKSS . OldCCT.cipherKeySize $ c- blockSize (HWOCCT c) = OldCCT.blockSize c- cfbEncrypt (HWOCCT c) iv bs =- hammerIV iv >>= \i -> return (OldCCT.cfbEncrypt c i bs)- cfbDecrypt (HWOCCT c) iv bs =- hammerIV iv >>= \i -> return (OldCCT.cfbDecrypt c i bs)- paddedCfbEncrypt _ _ _ =- Left "padding for nettle-encryption not implemented yet"- paddedCfbDecrypt (HWOCCT cipher) iv ciphertext =- hammerIV iv >>= \i ->- return (B.take (B.length ciphertext) (OldCCT.cfbDecrypt cipher i padded))+instance+ OldCCT.BlockCipher cipher+ => HOBlockCipher (HOWrappedOldCCT cipher) where- padded =- ciphertext `B.append`- B.pack- (replicate- (OldCCT.blockSize cipher -- (B.length ciphertext `mod` OldCCT.blockSize cipher))- 0)+ cipherInit =+ fmap HWOCCT+ . either+ (const (Left "nettle invalid key"))+ (Right . OldCCT.cipherInit)+ . OldCCT.makeKey+ cipherName (HWOCCT c) = OldCCT.cipherName c+ cipherKeySize (HWOCCT c) = convertKSS . OldCCT.cipherKeySize $ c+ blockSize (HWOCCT c) = OldCCT.blockSize c+ cfbEncrypt (HWOCCT c) iv bs =+ hammerIV iv >>= \i -> return (OldCCT.cfbEncrypt c i bs)+ cfbDecrypt (HWOCCT c) iv bs =+ hammerIV iv >>= \i -> return (OldCCT.cfbDecrypt c i bs)+ paddedCfbEncrypt _ _ _ =+ Left "padding for nettle-encryption not implemented yet"+ paddedCfbDecrypt (HWOCCT cipher) iv ciphertext =+ hammerIV iv >>= \i ->+ return+ (B.take (B.length ciphertext) (OldCCT.cfbDecrypt cipher i padded))+ where+ padded =+ ciphertext+ `B.append` B.pack+ ( replicate+ ( OldCCT.blockSize cipher+ - (B.length ciphertext `mod` OldCCT.blockSize cipher)+ )+ 0+ ) convertKSS :: OldCCT.KeySizeSpecifier -> CCT.KeySizeSpecifier convertKSS (OldCCT.KeySizeRange a b) = CCT.KeySizeRange a b convertKSS (OldCCT.KeySizeEnum as) = CCT.KeySizeEnum as convertKSS (OldCCT.KeySizeFixed a) = CCT.KeySizeFixed a -hammerIV ::- OldCCT.BlockCipher cipher- => B.ByteString- -> Either String (OldCCT.IV cipher)+hammerIV+ :: OldCCT.BlockCipher cipher+ => B.ByteString+ -> Either String (OldCCT.IV cipher) hammerIV = note "nettle bad IV" . OldCCT.makeIV
Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs view
@@ -16,7 +16,6 @@ import Codec.Encryption.OpenPGP.BlockCipher ( keySize- , renderCipherError ) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.Internal@@ -60,11 +59,13 @@ curveOid = case recipientECDHPub of ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) ->- curveToCurveoidBS (curveFromCurve curve)+ first+ renderCurveConversionError+ (curveToCurveoidBS (curveFromCurve curve)) EdDSAPubKey EdSigningCurve25519 _ ->- curveToCurveoidBS Curve25519+ first renderCurveConversionError (curveToCurveoidBS Curve25519) EdDSAPubKey EdSigningCurve448 _ ->- curveToCurveoidBS Curve448+ first renderCurveConversionError (curveToCurveoidBS Curve448) _ -> Left "ECDH KDF param requires ECDH recipient key" deriveECDHKek
Codec/Encryption/OpenPGP/Internal/Crypton.hs view
@@ -8,30 +8,31 @@ {-# LANGUAGE UndecidableInstances #-} module Codec.Encryption.OpenPGP.Internal.Crypton- ( HOWrappedCCT(..)- ) where+ ( HOWrappedCCT (..)+ ) where import Control.Error.Util (note)-import qualified "crypton" Crypto.Cipher.Types as CCT import qualified Crypto.Error as CE import Data.Bifunctor (bimap) import qualified Data.ByteString as B+import qualified "crypton" Crypto.Cipher.Types as CCT import Codec.Encryption.OpenPGP.Internal.HOBlockCipher -newtype HOWrappedCCT a =- HWCCT a+newtype HOWrappedCCT a+ = HWCCT a instance CCT.BlockCipher cipher => HOBlockCipher (HOWrappedCCT cipher) where- cipherInit = bimap show HWCCT . CE.eitherCryptoError . CCT.cipherInit- cipherName (HWCCT c) = CCT.cipherName c- cipherKeySize (HWCCT c) = CCT.cipherKeySize c- blockSize (HWCCT c) = CCT.blockSize c- cfbEncrypt (HWCCT c) iv bs =- hammerIV iv >>= \i -> return (CCT.cfbEncrypt c i bs)- cfbDecrypt (HWCCT c) iv bs =- hammerIV iv >>= \i -> return (CCT.cfbDecrypt c i bs)+ cipherInit = bimap show HWCCT . CE.eitherCryptoError . CCT.cipherInit+ cipherName (HWCCT c) = CCT.cipherName c+ cipherKeySize (HWCCT c) = CCT.cipherKeySize c+ blockSize (HWCCT c) = CCT.blockSize c+ cfbEncrypt (HWCCT c) iv bs =+ hammerIV iv >>= \i -> return (CCT.cfbEncrypt c i bs)+ cfbDecrypt (HWCCT c) iv bs =+ hammerIV iv >>= \i -> return (CCT.cfbDecrypt c i bs) -hammerIV ::- CCT.BlockCipher cipher => B.ByteString -> Either String (CCT.IV cipher)+hammerIV+ :: CCT.BlockCipher cipher+ => B.ByteString -> Either String (CCT.IV cipher) hammerIV = note "crypton bad IV" . CCT.makeIV
Codec/Encryption/OpenPGP/Internal/HOBlockCipher.hs view
@@ -5,25 +5,36 @@ {-# LANGUAGE PackageImports #-} module Codec.Encryption.OpenPGP.Internal.HOBlockCipher- ( HOBlockCipher(..)- ) where--import qualified "crypton" Crypto.Cipher.Types as CCT+ ( HOBlockCipher (..)+ ) where import qualified Data.ByteString as B+import qualified "crypton" Crypto.Cipher.Types as CCT class HOBlockCipher cipher where- cipherInit :: B.ByteString -> Either String cipher- cipherName :: cipher -> String- cipherKeySize :: cipher -> CCT.KeySizeSpecifier- blockSize :: cipher -> Int- cfbEncrypt ::- cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString- cfbDecrypt ::- cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString- paddedCfbEncrypt ::- cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString- paddedCfbEncrypt = cfbEncrypt- paddedCfbDecrypt ::- cipher -> B.ByteString -> B.ByteString -> Either String B.ByteString- paddedCfbDecrypt = cfbDecrypt+ cipherInit :: B.ByteString -> Either String cipher+ cipherName :: cipher -> String+ cipherKeySize :: cipher -> CCT.KeySizeSpecifier+ blockSize :: cipher -> Int+ cfbEncrypt+ :: cipher+ -> B.ByteString+ -> B.ByteString+ -> Either String B.ByteString+ cfbDecrypt+ :: cipher+ -> B.ByteString+ -> B.ByteString+ -> Either String B.ByteString+ paddedCfbEncrypt+ :: cipher+ -> B.ByteString+ -> B.ByteString+ -> Either String B.ByteString+ paddedCfbEncrypt = cfbEncrypt+ paddedCfbDecrypt+ :: cipher+ -> B.ByteString+ -> B.ByteString+ -> Either String B.ByteString+ paddedCfbDecrypt = cfbDecrypt
Codec/Encryption/OpenPGP/KeyGeneration.hs view
@@ -822,7 +822,7 @@ issuerKeyIdSub :: SomePKPayload -> SigSubPacket issuerKeyIdSub pkp = case eightOctetKeyID pkp of- Left err -> error ("failed to derive issuer key id: " ++ err)+ Left err -> error ("failed to derive issuer key id: " ++ show err) Right eoki -> SigSubPacket False (Issuer eoki) baseHashedSubs
Codec/Encryption/OpenPGP/KeyInfo.hs view
@@ -17,8 +17,11 @@ import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BaseTypes+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( KeyInfoError (..)+ ) -pubkeySize :: PKey -> Either String Int+pubkeySize :: PKey -> Either KeyInfoError Int pubkeySize (RSAPubKey (RSA_PublicKey x)) = Right (RSA.public_size x * 8) pubkeySize (DSAPubKey (DSA_PublicKey x)) = Right (bitcount . DSA.params_p . DSA.public_params $ x)@@ -36,7 +39,7 @@ pubkeySize (ECDHPubKey (EdDSAPubKey EdSigningCurve448 _) _ _) = Right 448 pubkeySize (EdDSAPubKey EdSigningCurve25519 _) = Right 256 pubkeySize (EdDSAPubKey EdSigningCurve448 _) = Right 448-pubkeySize x = Left $ "Unable to calculate size of " ++ show x+pubkeySize x = Left (KeyInfoUnsupportedAlgorithm x) bitcount :: Integer -> Int bitcount =
Codec/Encryption/OpenPGP/KeySelection.hs view
@@ -10,7 +10,6 @@ ) where import Control.Applicative (optional, (<|>))-import Control.Monad ((<=<)) import Crypto.Number.Serialize (i2osp) import Data.Attoparsec.Text ( Parser@@ -27,21 +26,27 @@ import qualified Data.Text as T import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( KeySelectionError (..)+ ) -parseEightOctetKeyId :: Text -> Either String EightOctetKeyId-parseEightOctetKeyId =- fmap EightOctetKeyId- . (parseOnly hexes <=< parseOnly (hexPrefix *> hexen 16))- . toUpper+parseEightOctetKeyId+ :: Text -> Either KeySelectionError EightOctetKeyId+parseEightOctetKeyId input =+ case parseOnly hexes+ =<< parseOnly (hexPrefix *> hexen 16) (toUpper input) of+ Left _ -> Left (KeySelectionParseError (toUpper input))+ Right bs -> Right (EightOctetKeyId bs) -parseFingerprint :: Text -> Either String Fingerprint-parseFingerprint =- fmap Fingerprint- . ( parseOnly hexes- <=< parseOnly (hexen 64 <|> hexen 40 <|> hexen 32)- )- . toUpper- . T.filter (/= ' ')+parseFingerprint :: Text -> Either KeySelectionError Fingerprint+parseFingerprint input =+ case parseOnly hexes+ =<< parseOnly+ (hexen 64 <|> hexen 40 <|> hexen 32)+ (toUpper (T.filter (/= ' ') input)) of+ Left _ ->+ Left (KeySelectionParseError (toUpper (T.filter (/= ' ') input)))+ Right bs -> Right (Fingerprint bs) hexPrefix :: Parser (Maybe Text) hexPrefix = optional (asciiCI "0x")
Codec/Encryption/OpenPGP/KeyringParser.hs view
@@ -11,7 +11,6 @@ , parseAChunkEither , finalizeParsing , finalizeParsingEither- , KeyringChunkParseError (..) , anyTK , anyTKWithWireRep , UidOrUat (..)@@ -76,18 +75,6 @@ import Codec.Encryption.OpenPGP.SignatureQualities (sigType) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Keyring.Instances ()--data KeyringChunkParseError- = ChunkFailureBeforeInput String- | ChunkUnexpectedFinalizationFailure- | ChunkParserFailure String- deriving (Eq, Show)--renderChunkParseError :: KeyringChunkParseError -> String-renderChunkParseError (ChunkFailureBeforeInput msg) = msg-renderChunkParseError ChunkUnexpectedFinalizationFailure =- "Unexpected finalization failure"-renderChunkParseError (ChunkParserFailure msg) = msg collapseCompleted :: Monoid s
Codec/Encryption/OpenPGP/Message.hs view
@@ -32,18 +32,6 @@ , mkEd25519SignerV6 , mkEd448SignerV4 , mkEd448SignerV6- , MessageParseFailure (..)- , renderMessageParseFailure- , MDCFailure (..)- , renderMDCFailure- , PayloadDecryptFailure (..)- , renderPayloadDecryptFailure- , MessageDecryptFailure (..)- , renderMessageDecryptFailure- , MessageEncryptFailure (..)- , renderMessageEncryptFailure- , MessageError (..)- , renderMessageError , SessionMaterialExposure (..) , EncryptMessageProfile , EncryptMessageOptions (..)@@ -72,9 +60,7 @@ import Data.Word (Word8) import Codec.Encryption.OpenPGP.BlockCipher- ( CipherError- , keySize- , renderCipherError+ ( keySize ) import Codec.Encryption.OpenPGP.CFB ( OpenPGPCFBModeW (..)@@ -85,7 +71,6 @@ import Codec.Encryption.OpenPGP.Encrypt ( buildOnePassSignature , encryptSEIPDv2WithSKESKBlock- , renderOPSBuildError ) import Codec.Encryption.OpenPGP.Fingerprint ( eightOctetKeyID@@ -105,29 +90,20 @@ , supportsSEIPDv2Symmetric ) import Codec.Encryption.OpenPGP.S2K- ( S2KError (..)- , renderS2KError- , skesk2SessionKey+ ( skesk2SessionKey , string2Key ) import Codec.Encryption.OpenPGP.SEIPDv1- ( MDCFailure (..)- , mdcTrailerForSEIPDv1- , renderMDCFailure+ ( mdcTrailerForSEIPDv1 , validateSEIPD1MDC ) import Codec.Encryption.OpenPGP.SEIPDv2- ( SEIPDv2Failure (..)- , decryptSKESK6SessionKey+ ( decryptSKESK6SessionKey , deriveSKESK6KEK- , renderSEIPDv2Failure ) import Codec.Encryption.OpenPGP.Serialize (parsePkts) import Codec.Encryption.OpenPGP.Signatures- ( SignError (..)- , VerificationError- , renderSignError- , signDataWithEd25519Builder+ ( signDataWithEd25519Builder , signDataWithEd25519V6Builder , signDataWithEd448Builder , signDataWithEd448V6Builder@@ -242,15 +218,6 @@ -> Signer 'AlgoEd448 V6Sig mkEd448SignerV6 = Ed448Signer -data MessageError- = MessageEncryptFailureError MessageEncryptFailure- | MessageDecryptError String- | MessageSignError SignError- | MessageParseError String- | MessageParseFailureError MessageParseFailure- | MessageDecryptFailureError MessageDecryptFailure- deriving (Eq, Show)- messageStep :: Monad m => Either MessageError a -> ExceptT MessageError m a messageStep = ExceptT . pure@@ -282,42 +249,14 @@ => Either MessageEncryptFailure a -> ExceptT MessageError m a encryptStep = messageStep . first MessageEncryptFailureError -data MessageParseFailure- = MissingEncryptedMessage- | ExpectedSKESKThenEncryptedData- | SKESKSEIPDAlgorithmMismatch- | UnsupportedEncryptedSKESK- | MissingLiteralDataPacket- | UnknownCriticalPacketType Word8- | 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 PayloadDecryptFailure+data SessionMaterialExposure+ = DoNotExposeSessionMaterial+ | ExposeSessionMaterial deriving (Eq, Show) -data MessageEncryptFailure- = MessageEncryptSEIPDv2Failed SEIPDv2Failure- | MessageEncryptCipherFailed CipherError- | MessageEncryptS2KFailed S2KError- | MessageEncryptDeprecatedS2KHash HashAlgorithm- | MessageEncryptUnsupportedSymmetricAlgorithm SymmetricAlgorithm- deriving (Eq, Show)+data EncryptMessageProfile+ = RFC4880Message+ | RFC9580Message data ParsedEncryptedPayloadKind = LegacySEDPayloadKind@@ -328,15 +267,6 @@ = LegacyEncryptedPreludeKind | SEIPDv2EncryptedPreludeKind -data SessionMaterialExposure- = DoNotExposeSessionMaterial- | ExposeSessionMaterial- deriving (Eq, Show)--data EncryptMessageProfile- = RFC4880Message- | RFC9580Message- data EncryptMessageOptions (p :: EncryptMessageProfile) where RFC4880EncryptMessageOptions :: { rfc4880EncryptMessageExposure :: SessionMaterialExposure@@ -363,63 +293,6 @@ } deriving (Eq, Show) -renderMessageParseFailure :: MessageParseFailure -> String-renderMessageParseFailure MissingEncryptedMessage =- "Could not parse encrypted OpenPGP message"-renderMessageParseFailure ExpectedSKESKThenEncryptedData =- "Expected an SKESK packet followed by symmetrically encrypted data or SEIPD v2 data"-renderMessageParseFailure SKESKSEIPDAlgorithmMismatch =- "SKESK and SEIPD v2 algorithms do not match"-renderMessageParseFailure UnsupportedEncryptedSKESK =- "Cannot decrypt SKESK packets with encrypted session keys"-renderMessageParseFailure MissingLiteralDataPacket =- "Decrypted message does not contain a literal data packet"-renderMessageParseFailure (UnknownCriticalPacketType t) =- "Unknown critical packet type: " ++ show t-renderMessageParseFailure (BrokenCriticalPacketType t err) =- "Broken critical packet type " ++ show t ++ ": " ++ err--renderMessageDecryptFailure :: MessageDecryptFailure -> String-renderMessageDecryptFailure (SessionMaterialDerivationFailed err) = renderS2KError 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 @@ -432,8 +305,8 @@ encryptedPayloadBytes :: EncryptedPayload -> BL.ByteString encryptedPayloadBytes = unEncryptedPayload -signBackendStep :: Either String a -> Either SignError a-signBackendStep = first SignBackendError+signBackendStep :: Either KeyIdError a -> Either SignError a+signBackendStep = first SignBackendErrorKeyId decryptSessionStep :: Either S2KError a -> Either MessageDecryptFailure a@@ -762,7 +635,8 @@ -> Either SignError BL.ByteString signV4WithIssuers signer signingFn payload = do issuerKeyId <-- signBackendStep (eightOctetKeyID (SomePKPayload signer))+ signBackendStep+ (eightOctetKeyID (SomePKPayload signer)) let hashed = [ SigSubPacket False@@ -811,7 +685,7 @@ signature <- signingFn hashed unhashed clear let sigPkt = SignaturePkt signature bimap- (SignBackendError . renderOPSBuildError)+ (SignBackendErrorOPSBuild) ( \ops -> runPut . put $ Block [OnePassSignaturePkt ops, literal, sigPkt] )@@ -1110,8 +984,13 @@ where go acc pkt = case pkt of- OtherPacketPkt t _ | t < 40 -> Left (UnknownCriticalPacketType t)- BrokenPacketPkt err t _ | t < 40 -> Left (BrokenCriticalPacketType t err)+ OtherPacketPkt t _+ | t < 40 ->+ Left (MessageParseCriticalPacketError (UnknownCriticalPacket t))+ BrokenPacketPkt err t _+ | t < 40 ->+ Left+ (MessageParseCriticalPacketError (BrokenCriticalPacket t err)) _ -> Right (pkt : acc) validateModernMessageS2K
Codec/Encryption/OpenPGP/S2K.hs view
@@ -6,11 +6,7 @@ {-# LANGUAGE GADTs #-} module Codec.Encryption.OpenPGP.S2K- ( EncodedSessionKeyError (..)- , renderEncodedSessionKeyError- , S2KError (..)- , renderS2KError- , decodeOpenPGPEncodedSessionKey+ ( decodeOpenPGPEncodedSessionKey , string2Key , skesk2Key , skesk2SessionKey@@ -27,79 +23,19 @@ import Data.Word (Word16, Word8) import Codec.Encryption.OpenPGP.BlockCipher- ( CipherError (..)- , keySize+ ( keySize , withSymmetricCipher ) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher ( HOBlockCipher (..) ) import Codec.Encryption.OpenPGP.Types--data EncodedSessionKeyError- = EncodedSessionKeyTooShort- | EncodedSessionKeyUnsupportedAlgorithm SymmetricAlgorithm- | EncodedSessionKeyLengthMismatch SymmetricAlgorithm Int Int- | EncodedSessionKeyChecksumMismatch- deriving (Eq, Show)--renderEncodedSessionKeyError :: EncodedSessionKeyError -> String-renderEncodedSessionKeyError EncodedSessionKeyTooShort =- "session key material too short"-renderEncodedSessionKeyError (EncodedSessionKeyUnsupportedAlgorithm sa) =- "unsupported symmetric algorithm: " ++ show sa-renderEncodedSessionKeyError (EncodedSessionKeyLengthMismatch _ _ _) =- "session key material length does not match encoded algorithm"-renderEncodedSessionKeyError EncodedSessionKeyChecksumMismatch =- "session key checksum mismatch"---- | Errors that can arise during string-to-key derivation.-data S2KError- = -- | The symmetric algorithm used in the SKESK is not supported.- S2KUnsupportedAlgorithm CipherError- | -- | An unsupported or unknown S2K specifier type was encountered.- S2KUnsupportedSpecifier Word8- | -- | An unsupported SKESK shape (e.g. non-zero ESK).- S2KUnsupportedSKESKShape String- | -- | A required hash algorithm is not supported for S2K.- S2KUnsupportedHashAlgorithm HashAlgorithm- | -- | The Argon2 S2K parameters are invalid.- S2KArgon2ParamError String- | -- | The Argon2 KDF itself failed.- S2KArgon2Failed String- | -- | Decrypting an embedded encrypted session key failed.- S2KEncryptedSessionKeyCipherError CipherError- | -- | Embedded encrypted session key material was malformed.- S2KEncryptedSessionKeyDecodeError EncodedSessionKeyError- deriving (Eq, Show)--renderS2KError :: S2KError -> String-renderS2KError (S2KUnsupportedAlgorithm ce) =- "S2K: " ++ renderCipherError' ce- where- renderCipherError' (UnsupportedAlgorithm sa) = "unsupported symmetric algorithm: " ++ show sa- renderCipherError' (CipherInitFailed sa msg) = "cipher init failed for " ++ show sa ++ ": " ++ msg- renderCipherError' (CipherOperationFailed msg) = "cipher operation failed: " ++ msg-renderS2KError (S2KUnsupportedSpecifier t) =- "S2K: unsupported S2K type " ++ show t-renderS2KError (S2KUnsupportedSKESKShape msg) =- "S2K: unsupported SKESK shape: " ++ msg-renderS2KError (S2KUnsupportedHashAlgorithm ha) =- "S2K: unsupported hash algorithm for S2K: " ++ show ha-renderS2KError (S2KArgon2ParamError msg) =- "S2K: Argon2 parameter error: " ++ msg-renderS2KError (S2KArgon2Failed msg) =- "S2K: Argon2 KDF failed: " ++ msg-renderS2KError (S2KEncryptedSessionKeyCipherError ce) =- "S2K: encrypted session key decrypt failed: "- ++ renderCipherError' ce- where- renderCipherError' (UnsupportedAlgorithm sa) = "unsupported symmetric algorithm: " ++ show sa- renderCipherError' (CipherInitFailed sa msg) = "cipher init failed for " ++ show sa ++ ": " ++ msg- renderCipherError' (CipherOperationFailed msg) = "cipher operation failed: " ++ msg-renderS2KError (S2KEncryptedSessionKeyDecodeError err) =- "S2K: encrypted session key decode failed: "- ++ renderEncodedSessionKeyError err+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( EncodedSessionKeyError (..)+ , S2KError (..)+ , renderEncodedSessionKeyError+ , renderS2KError+ ) string2Key :: S2K -> Int -> B.ByteString -> Either S2KError B.ByteString
Codec/Encryption/OpenPGP/SEIPDv1.hs view
@@ -7,9 +7,7 @@ {-# LANGUAGE KindSignatures #-} module Codec.Encryption.OpenPGP.SEIPDv1- ( MDCFailure (..)- , mdcTrailerForSEIPDv1- , renderMDCFailure+ ( mdcTrailerForSEIPDv1 , seipdv1NonceFromIV , validateSEIPD1MDC , calculateMDC@@ -24,6 +22,10 @@ import qualified Data.ByteString.Lazy as BL import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( MDCFailure (..)+ , renderMDCFailure+ ) {- | Compute the MDC trailer appended to SEIPDv1 plaintext before encryption. The trailer is: @0xd3 0x14 SHA1(nonce || plaintext || 0xd3 0x14)@.@@ -54,17 +56,6 @@ ) :: 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)
Codec/Encryption/OpenPGP/SEIPDv2.hs view
@@ -7,15 +7,13 @@ {-# LANGUAGE TypeApplications #-} module Codec.Encryption.OpenPGP.SEIPDv2- ( SEIPDv2Failure (..)- , aeadModeAndNonceSizeForSEIPDv2+ ( aeadModeAndNonceSizeForSEIPDv2 , supportedSEIPDv2AEADAlgorithms , supportedSEIPDv2SymmetricAlgorithms , seipdv2SymmetricKeySize , deriveSKESK6KEK , encryptSKESK6SessionKey , decryptSKESK6SessionKey- , renderSEIPDv2Failure ) where import Control.Error.Util (note)@@ -29,10 +27,6 @@ import qualified Data.Set as Set import qualified "crypton" Crypto.Cipher.Types as CCT -import Codec.Encryption.OpenPGP.BlockCipher- ( CipherError (..)- , renderCipherError- ) import Codec.Encryption.OpenPGP.Internal.CryptoAES ( withAESCipher )@@ -40,61 +34,8 @@ ( 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 =@@ -166,8 +107,10 @@ then Left SEIPDv2InvalidIVLength else withAESCipher- SEIPDv2CipherInitFailed- (SEIPDv2UnsupportedSymmetricAlgorithm symalgo)+ (SEIPDv2CipherFailed . CipherInitFailed symalgo . show)+ ( SEIPDv2CipherFailed+ (CipherInitFailed symalgo "unsupported symmetric algorithm")+ ) symalgo kek ( \cipher ->@@ -182,8 +125,9 @@ pure (ciphertext, authTagToBS tag) else do aeadCtx <-- first SEIPDv2CipherInitFailed . CE.eitherCryptoError $- CCT.aeadInit mode cipher iv+ first (SEIPDv2CipherFailed . CipherInitFailed symalgo . show)+ . CE.eitherCryptoError+ $ CCT.aeadInit mode cipher iv let (tag, ciphertext) = CCT.aeadSimpleEncrypt aeadCtx@@ -207,8 +151,10 @@ then Left SEIPDv2InvalidIVLength else withAESCipher- SEIPDv2CipherInitFailed- (SEIPDv2UnsupportedSymmetricAlgorithm symalgo)+ (SEIPDv2CipherFailed . CipherInitFailed symalgo . show)+ ( SEIPDv2CipherFailed+ (CipherInitFailed symalgo "unsupported symmetric algorithm")+ ) symalgo kek ( \cipher ->@@ -223,8 +169,9 @@ (mkAuthTag tag) else do aeadCtx <-- first SEIPDv2CipherInitFailed . CE.eitherCryptoError $- CCT.aeadInit mode cipher iv+ first (SEIPDv2CipherFailed . CipherInitFailed symalgo . show)+ . CE.eitherCryptoError+ $ CCT.aeadInit mode cipher iv note SEIPDv2AuthFailed ( CCT.aeadSimpleDecrypt
Codec/Encryption/OpenPGP/SecretKey.hs view
@@ -8,19 +8,12 @@ {-# LANGUAGE TypeApplications #-} module Codec.Encryption.OpenPGP.SecretKey- ( decryptPrivateKey- , mkUnencryptedSKAddendum- , encryptPrivateKeyWithPolicyAndSaltAndIV- , reencryptPrivateKeyTyped- , reencryptPrivateKeyTypedWithPolicy- , reencryptPrivateKeyWithSaltAndIV- , SecretKeyError (..)- , renderSecretKeyError- , SecretKeyEncryptOptions (..)+ ( SecretKeyEncryptOptions (..) , decryptSecretKey , decryptSecretKeyAddendum , encryptSecretKey , encryptSecretKeyWithPolicy+ , mkUnencryptedSKAddendum , reencryptSecretKey , reencryptSecretKeyRandom ) where@@ -67,7 +60,6 @@ import Codec.Encryption.OpenPGP.BlockCipher ( keySize- , renderCipherError ) import Codec.Encryption.OpenPGP.CFB ( decryptNoNonce@@ -94,8 +86,7 @@ , secretKeyS2KSaltOctets ) import Codec.Encryption.OpenPGP.S2K- ( renderS2KError- , skesk2Key+ ( skesk2Key , string2Key ) import Codec.Encryption.OpenPGP.Serialize@@ -104,20 +95,6 @@ ) import Codec.Encryption.OpenPGP.Types -data SecretKeyError- = SecretKeyDecryptError String- | SecretKeyEncryptError String- | SecretKeyPolicyError String- | 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@@ -125,16 +102,6 @@ , skeoIV :: Maybe IV } -{-# DEPRECATED decryptPrivateKey "Use decryptSecretKeyAddendum" #-}-decryptPrivateKey- :: (SomePKPayload, SKAddendum)- -> Passphrase- -> Either String SKAddendum-decryptPrivateKey (pkp, ska) (Passphrase pp) =- fromSKAddendumForPKPayload pkp ska >>= \case- SomeSKAddendumV skaV ->- toSKAddendum <$> decryptPrivateKeyTyped pkp skaV (Passphrase pp)- decryptSecretKey :: SecretKey -> Passphrase@@ -153,15 +120,15 @@ -> Passphrase -> Either SecretKeyError (SKey, SKAddendum) decryptSecretKeyAddendum pkp ska pp =- case decryptPrivateKey (pkp, ska) pp of- Left err -> Left $ SecretKeyDecryptError err- Right decrypted ->- case decrypted of- SUSUnprotected skey _ -> Right (skey, decrypted)- _ ->- Left $- SecretKeyDecryptError- "decrypted secret key material was not in unencrypted form"+ case fromSKAddendumForPKPayload pkp ska of+ Left err -> Left (SecretKeyDecryptAddendumError err)+ Right (SomeSKAddendumV skaV) ->+ case decryptPrivateKeyTyped pkp skaV pp of+ Left err -> Left err+ Right decryptedV ->+ case toSKAddendum decryptedV of+ SUSUnprotected skey _ -> Right (skey, toSKAddendum decryptedV)+ _ -> Left SecretKeyDecryptNotUnencrypted encryptSecretKey :: MonadRandom m@@ -177,25 +144,21 @@ then do nextMaterial <- lift $ generateSecretKeyProtectionMaterial (skeoPolicy opts) pkp- except $ first SecretKeyPolicyError nextMaterial+ except nextMaterial else case (skeoSalt opts, skeoIV opts) of (Just salt, Just iv) -> return (salt, iv)- _ ->- throwE $- SecretKeyEncryptError- "skeoGenerateSaltAndIV is False but skeoSalt or skeoIV are Nothing"+ _ -> throwE SecretKeyEncryptOptionsInconsistent ska <- except- (first SecretKeyEncryptError $ mkUnencryptedSKAddendum pkp skey)+ (mkUnencryptedSKAddendum pkp skey) except- ( first SecretKeyEncryptError $- encryptPrivateKeyWithPolicyAndSaltAndIV- (skeoPolicy opts)- pkp- salt- iv- ska- newPassphrase+ ( encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV+ (skeoPolicy opts)+ pkp+ salt+ iv+ skey+ newPassphrase ) return result @@ -229,11 +192,14 @@ result <- runExceptT $ do let pkp = _secretKeyPKPayload sk originalSka = _secretKeySKAddendum sk- decrypted <-- except $- first SecretKeyDecryptError $- decryptPrivateKey (pkp, originalSka) oldPassphrase- case decrypted of+ decryptedSKA <-+ except $ case fromSKAddendumForPKPayload pkp originalSka of+ Left err -> Left (SecretKeyDecryptAddendumError err)+ Right (SomeSKAddendumV skaV) ->+ case decryptPrivateKeyTyped pkp skaV oldPassphrase of+ Left err -> Left err+ Right decryptedV -> Right (toSKAddendum decryptedV)+ case decryptedSKA of SUSUnprotected skey _ -> do let pp = unPassphrase newPassphrase (salt, iv) <-@@ -241,13 +207,10 @@ then do nextMaterial <- lift $ generateSecretKeyProtectionMaterial (skeoPolicy opts) pkp- except $ first SecretKeyPolicyError nextMaterial+ except nextMaterial else case (skeoSalt opts, skeoIV opts) of (Just salt, Just iv) -> return (salt, iv)- _ ->- throwE $- SecretKeyEncryptError- "skeoGenerateSaltAndIV is False but skeoSalt or skeoIV are Nothing"+ _ -> throwE SecretKeyEncryptOptionsInconsistent newSka <- except $ reencryptWithPolicyAndSaltAndIV@@ -259,10 +222,7 @@ (Passphrase pp) (skeoPolicy opts) return $ sk {_secretKeySKAddendum = newSka}- _ ->- throwE $- SecretKeyDecryptError- "decrypted secret key material was not in unencrypted form"+ _ -> throwE SecretKeyDecryptNotUnencrypted return result reencryptWithPolicyAndSaltAndIV@@ -276,20 +236,19 @@ -> Either SecretKeyError SKAddendum reencryptWithPolicyAndSaltAndIV pkp originalSka salt iv skey (Passphrase pp) policy = first- SecretKeyEncryptError+ SecretKeyEncryptAddendumError (fromSKAddendumForPKPayload pkp originalSka) >>= \case SomeSKAddendumV skaV ->- first SecretKeyEncryptError $- toSKAddendum- <$> reencryptPrivateKeyTypedWithPolicy- policy- pkp- skaV- salt- iv- skey- (Passphrase pp)+ toSKAddendum+ <$> reencryptWithPolicyAndSaltAndIVTyped+ policy+ pkp+ skaV+ salt+ iv+ skey+ (Passphrase pp) reencryptSecretKeyRandom :: MonadRandom m@@ -314,7 +273,7 @@ :: SomePKPayload -> SKAddendumV v -> Passphrase- -> Either String (SKAddendumV v)+ -> Either SecretKeyError (SKAddendumV v) decryptPrivateKeyTyped pkp (SKAMalleableCFB sa s2k iv payload) pp = do (sk, cksum) <- decryptS2KProtectedPayload@@ -357,26 +316,28 @@ decryptAEADPayloadCore pkp sa aa s2k iv (BL.toStrict payload) pp pure (SKAUnprotectedLegacy sk 0) decryptPrivateKeyTyped pkp (SKALegacyCFBLegacy sa iv payload) pp = do- keyLen <- first renderCipherError (keySize sa)+ keyLen <-+ first SecretKeyPolicyCipherError (keySize sa) dek <- first- renderS2KError+ SecretKeyInvalidS2KMode (string2Key (Simple DeprecatedMD5) keyLen (unPassphrase pp)) p <- first- renderCipherError+ SecretKeyDecryptCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek) (sk, cksum) <- parse16BitProtectedSecretKey pkp p pure (SKAUnprotectedLegacy sk cksum) decryptPrivateKeyTyped pkp (SKALegacyCFBV6 sa iv payload) pp = do- keyLen <- first renderCipherError (keySize sa)+ keyLen <-+ first SecretKeyPolicyCipherError (keySize sa) dek <- first- renderS2KError+ SecretKeyInvalidS2KMode (string2Key (Simple DeprecatedMD5) keyLen (unPassphrase pp)) p <- first- renderCipherError+ SecretKeyDecryptCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek) (sk, _) <- parse16BitProtectedSecretKey pkp p pure (SKAUnprotectedV6 sk)@@ -384,7 +345,7 @@ decryptPrivateKeyTyped _ ska@(SKAUnprotectedV6 {}) _ = Right ska mkUnencryptedSKAddendum- :: SomePKPayload -> SKey -> Either String SKAddendum+ :: SomePKPayload -> SKey -> Either SecretKeyError SKAddendum mkUnencryptedSKAddendum pkp skey = do payload <- legacySecretKeyPayload pkp skey let checksum =@@ -400,21 +361,31 @@ -> IV -> BL.ByteString -> Passphrase- -> (SomePKPayload -> B.ByteString -> Either String (SKey, Word16))- -> Either String (SKey, Word16)+ -> ( SomePKPayload+ -> B.ByteString+ -> Either SecretKeyError (SKey, Word16)+ )+ -> Either SecretKeyError (SKey, Word16) decryptS2KProtectedPayload pkp sa s2k iv payload (Passphrase pp) parser = do dek <-- first renderS2KError (skesk2Key (SKESK4Packet sa s2k Nothing) pp)+ first+ SecretKeyInvalidS2KMode+ (skesk2Key (SKESK4Packet sa s2k Nothing) pp) decrypted <- first- renderCipherError+ SecretKeyDecryptCipherError (decryptNoNonce sa iv (BL.toStrict payload) dek) parser pkp decrypted parse16BitProtectedSecretKey- :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16)+ :: SomePKPayload+ -> B.ByteString+ -> Either SecretKeyError (SKey, Word16) parse16BitProtectedSecretKey pkp p | B.length p < 2 =- Left "secret key payload is too short for a 16-bit checksum"+ Left+ ( SecretKeyPayloadTooShort+ "secret key payload is too short for a 16-bit checksum"+ ) | otherwise = do let (skeyPayload, checksumPayload) = B.splitAt (B.length p - 2) p sk <- decodeSecretKey pkp skeyPayload@@ -424,40 +395,54 @@ then Right (sk, cksum) else Left- ( "16-bit secret key checksum mismatch (expected "- ++ show expected- ++ ", got "- ++ show cksum- ++ ")"+ ( SecretKeyChecksumError+ ( "16-bit secret key checksum mismatch (expected "+ ++ show expected+ ++ ", got "+ ++ show cksum+ ++ ")"+ ) ) parseSHA1ProtectedSecretKey- :: SomePKPayload -> B.ByteString -> Either String (SKey, Word16)+ :: SomePKPayload+ -> B.ByteString+ -> Either SecretKeyError (SKey, Word16) parseSHA1ProtectedSecretKey pkp p | B.length p < 20 =- Left "secret key payload is too short for a SHA1 checksum"+ Left+ ( SecretKeyPayloadTooShort+ "secret key payload is too short for a SHA1 checksum"+ ) | otherwise = do let (skeyPayload, hashPayload) = B.splitAt (B.length p - 20) p expected = BA.convert (CH.hash skeyPayload :: CH.Digest CH.SHA1) sk <- decodeSecretKey pkp skeyPayload if hashPayload == expected then Right (sk, checksum16 skeyPayload)- else Left "SHA1 secret key checksum mismatch"+ else+ Left (SecretKeyChecksumError "SHA1 secret key checksum mismatch") decodeSecretKey- :: SomePKPayload -> B.ByteString -> Either String SKey+ :: SomePKPayload -> B.ByteString -> Either SecretKeyError SKey decodeSecretKey pkp payloadBytes =- bimap- (\(_, _, x) -> x)- (\(_, _, x) -> x)- (runGetOrFail (getSecretKey pkp) (BL.fromStrict payloadBytes))+ first+ SecretKeyDecodeError+ ( bimap+ (\(_, _, x) -> x)+ (\(_, _, x) -> x)+ (runGetOrFail (getSecretKey pkp) (BL.fromStrict payloadBytes))+ ) -decodeChecksum :: B.ByteString -> Either String Word16+decodeChecksum :: B.ByteString -> Either SecretKeyError Word16 decodeChecksum checksumBytes =- bimap- (\(_, _, x) -> x)- (\(_, _, x) -> x)- (runGetOrFail getWord16be (BL.fromStrict checksumBytes))+ first+ SecretKeyDecodeError+ ( bimap+ (\(_, _, x) -> x)+ (\(_, _, x) -> x)+ (runGetOrFail getWord16be (BL.fromStrict checksumBytes))+ ) decryptAEADPayloadCore :: SomePKPayload -> SymmetricAlgorithm@@ -466,16 +451,24 @@ -> IV -> B.ByteString -> Passphrase- -> Either String SKey+ -> Either SecretKeyError SKey decryptAEADPayloadCore pkp sa aa s2k iv payload (Passphrase pp) = do- keyLen <- first renderCipherError (keySize sa)- keyMaterial <- first renderS2KError (string2Key s2k keyLen pp)+ keyLen <-+ first SecretKeyPolicyCipherError (keySize sa)+ keyMaterial <-+ first+ SecretKeyInvalidS2KMode+ (string2Key s2k keyLen pp) let keyCandidates = [keyMaterial] tagCandidates = [0xC5, 0xC7, 0x94, 0x95, 0x96, 0x97, 0x9C, 0x9D, 0x9E, 0x9F] infoCandidates = nubOrd [ B.pack- [tag, keyVersionByte (_keyVersion pkp), fromFVal sa, fromFVal aa]+ [ tag+ , fromIntegral (fromEnum (_keyVersion pkp))+ , fromFVal sa+ , fromFVal aa+ ] | tag <- tagCandidates ] pkpBytes = BL.toStrict (runPut (put pkp))@@ -488,7 +481,8 @@ tagLen = 16 tryDecrypt candidateKeyMaterial info ad aaTry = do when (B.length payloadStrict < tagLen) $- Left "v6 AEAD secret key payload too short"+ Left+ (SecretKeyPayloadTooShort "v6 AEAD secret key payload too short") let (ciphertext, tagBytes) = B.splitAt (B.length payloadStrict - tagLen) payloadStrict authTag = CCT.AuthTag (BA.convert tagBytes) prk = extract @CHA.SHA256 B.empty candidateKeyMaterial@@ -502,23 +496,33 @@ where go merr [] = Left $- "could not decrypt using any KEK candidate"- ++ maybe "" (\e -> " (last error: " ++ e ++ ")") merr+ SecretKeyAEADError+ ( "could not decrypt using any KEK candidate"+ ++ maybe+ ""+ (\e -> " (last error: " ++ renderSecretKeyError e ++ ")")+ merr+ ) go merr (kek : ks) = case decryptWithKey sa aaTry kek ad nonce ciphertext authTag of Right cleartext -> Right cleartext- Left err -> go (Just (maybe err id merr)) ks+ Left err -> go (Just err) ks tryKeks kekCandidates tryAll = go Nothing where go merr [] = Left $- "could not decrypt v6 AEAD secret key payload"- ++ maybe "" (\e -> " (last error: " ++ e ++ ")") merr+ SecretKeyAEADError+ ( "could not decrypt v6 AEAD secret key payload"+ ++ maybe+ ""+ (\e -> " (last error: " ++ renderSecretKeyError e ++ ")")+ merr+ ) go merr ((keyMaterialCandidate, info, ad, aaTry) : xs) = case tryDecrypt keyMaterialCandidate info ad aaTry of Right cleartext -> Right cleartext- Left err -> go (Just (maybe err id merr)) xs+ Left err -> go (Just err) xs cleartext <- tryAll [ (k, i, a, m)@@ -544,28 +548,31 @@ -> B.ByteString -> B.ByteString -> CCT.AuthTag- -> Either String B.ByteString+ -> Either SecretKeyError B.ByteString decryptWithKey sa aa kek ad nonce ciphertext authTag = do let toHex = BC.unpack . B16.encode authFailure expectedTag computedTag n a hashAd plaintext =- "failed to authenticate v6 AEAD secret key payload (expected tag="- ++ toHex expectedTag- ++ ", computed tag="- ++ toHex computedTag- ++ ", nonce="- ++ toHex n- ++ ", ad="- ++ toHex a- ++ ", hashAd="- ++ toHex hashAd- ++ ", plaintext="- ++ toHex plaintext- ++ ")"- unsupportedSecretKeyAEADError = "unsupported secret-key AEAD symmetric algorithm"+ SecretKeyAuthError+ ( "failed to authenticate v6 AEAD secret key payload (expected tag="+ ++ toHex expectedTag+ ++ ", computed tag="+ ++ toHex computedTag+ ++ ", nonce="+ ++ toHex n+ ++ ", ad="+ ++ toHex a+ ++ ", hashAd="+ ++ toHex hashAd+ ++ ", plaintext="+ ++ toHex plaintext+ ++ ")"+ )+ unsupportedSecretKeyAEADError =+ SecretKeyAEADModeUnsupportedCipher sa case aa of OCB -> withAESCipher- show+ SecretKeyAEADModeCrypto unsupportedSecretKeyAEADError sa kek@@ -582,68 +589,52 @@ mode <- aeadMode aa expectedNonceLen <- aeadNonceSize aa when (B.length nonce /= expectedNonceLen) $- Left "invalid nonce size for v6 AEAD secret key payload"- withAESCipher show unsupportedSecretKeyAEADError sa kek $ \cipher ->- first- show- (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))- >>= \aead ->- note- "failed to authenticate v6 AEAD secret key payload"- (CCT.aeadSimpleDecrypt aead ad ciphertext authTag)+ Left+ ( SecretKeyInvalidNonceSize+ "invalid nonce size for v6 AEAD secret key payload"+ )+ withAESCipher+ SecretKeyAEADModeCrypto+ unsupportedSecretKeyAEADError+ sa+ kek+ $ \cipher ->+ first+ SecretKeyAEADModeCrypto+ (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))+ >>= \aead ->+ note+ ( SecretKeyAuthError+ "failed to authenticate v6 AEAD secret key payload"+ )+ (CCT.aeadSimpleDecrypt aead ad ciphertext authTag) -aeadMode :: AEADAlgorithm -> Either String CCT.AEADMode+aeadMode :: AEADAlgorithm -> Either SecretKeyError CCT.AEADMode aeadMode EAX = Right CCT.AEAD_EAX aeadMode OCB = Right CCT.AEAD_OCB aeadMode GCM = Right CCT.AEAD_GCM-aeadMode (OtherAEADAlgo _) = Left "unknown AEAD mode"+aeadMode aa@(OtherAEADAlgo _) = Left (SecretKeyAEADModeUnsupportedAlgo aa) -aeadNonceSize :: AEADAlgorithm -> Either String Int+aeadNonceSize :: AEADAlgorithm -> Either SecretKeyError Int aeadNonceSize EAX = Right 16 aeadNonceSize OCB = Right 15 aeadNonceSize GCM = Right 12-aeadNonceSize (OtherAEADAlgo _) = Left "unknown AEAD nonce size"+aeadNonceSize (OtherAEADAlgo _) = Left (SecretKeyInvalidNonceSize "unknown AEAD nonce size") parseSecretKeyExact- :: SomePKPayload -> B.ByteString -> Either String SKey+ :: SomePKPayload -> B.ByteString -> Either SecretKeyError SKey parseSecretKeyExact pkp cleartext = case runGetOrFail ((,) <$> getSecretKey pkp <*> getRemainingLazyByteString) (BL.fromStrict cleartext) of- Left (_, _, err) -> Left err+ Left (_, _, err) -> Left (SecretKeyDecodeError err) Right (_, _, (sk, trailing)) | BL.null trailing -> Right sk | otherwise ->- Left "v6 AEAD secret key cleartext has trailing bytes"--keyVersionByte :: KeyVersion -> Word8-keyVersionByte DeprecatedV3 = 3-keyVersionByte V4 = 4-keyVersionByte V6 = 6--{-# DEPRECATED- encryptPrivateKeyWithPolicyAndSaltAndIV- "Use encryptSecretKeyWithPolicy"- #-}-encryptPrivateKeyWithPolicyAndSaltAndIV- :: OpenPGPPolicy- -> SomePKPayload- -> Salt- -> IV- -> SKAddendum- -> Passphrase- -> Either String SKAddendum-encryptPrivateKeyWithPolicyAndSaltAndIV policy pkp salt iv ska (Passphrase pp) =- case ska of- SUSUnprotected skey _ ->- encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV- policy- pkp- salt- iv- skey- (Passphrase pp)- _ -> Right ska+ Left+ ( SecretKeyTrailingBytes+ "v6 AEAD secret key cleartext has trailing bytes"+ ) encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV :: OpenPGPPolicy@@ -652,7 +643,7 @@ -> IV -> SKey -> Passphrase- -> Either String SKAddendum+ -> Either SecretKeyError SKAddendum encryptUnencryptedPrivateSKeyWithPolicyAndSaltAndIV policy pkp salt iv skey (Passphrase pp) = do (sa, _aa, s2k) <- secretKeyProtectionDefaults policy pkp salt iv let retargetedS2K = retargetS2K salt s2k@@ -666,9 +657,12 @@ (\payload -> SUSAEAD sa _aa s2k iv (BL.fromStrict payload)) <$> encryptV6SKey pkp skey sa _aa s2k iv (Passphrase pp) else do- keyLen <- first renderCipherError (keySize sa)+ keyLen <-+ first SecretKeyPolicyCipherError (keySize sa) keyMaterial <-- first renderS2KError (string2Key retargetedS2K keyLen pp)+ first+ SecretKeyInvalidS2KMode+ (string2Key retargetedS2K keyLen pp) cleartext <- legacySecretKeyPayload pkp skey let clearWithSHA1 = BL.toStrict cleartext@@ -679,20 +673,19 @@ ) encrypted <- first- renderCipherError+ SecretKeyEncryptCipherError (encryptNoNonce sa retargetedS2K iv clearWithSHA1 keyMaterial) pure (SUSCFB sa retargetedS2K iv (BL.fromStrict encrypted)) DeprecatedV3 ->- Left "v3 secret key encryption is not supported"+ Left SecretKeyUnsupportedLegacyProtection -encodeSKeyMaterial :: SKey -> Either String BL.ByteString+encodeSKeyMaterial :: SKey -> Either SecretKeyError BL.ByteString encodeSKeyMaterial keyMaterial = case keyMaterial of RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _)) -> case inverse p q of Nothing ->- Left- "could not derive RSA multiplicative inverse while encrypting secret key"+ Left SecretKeyRSAInverseError Just u -> Right (runPut (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)))@@ -725,15 +718,19 @@ -> S2K -> IV -> Passphrase- -> Either String B.ByteString+ -> Either SecretKeyError B.ByteString encryptV6SKey pkp skey sa aa s2k iv (Passphrase pp) = do- keyLen <- first renderCipherError (keySize sa)- keyMaterial <- first renderS2KError (string2Key s2k keyLen pp)+ keyLen <-+ first SecretKeyPolicyCipherError (keySize sa)+ keyMaterial <-+ first+ SecretKeyInvalidS2KMode+ (string2Key s2k keyLen pp) payload <- encodeSKeyMaterial skey let info = B.pack [ 0xC5- , keyVersionByte (_keyVersion pkp)+ , fromIntegral (fromEnum (_keyVersion pkp)) , fromFVal sa , fromFVal aa ]@@ -745,7 +742,9 @@ pure (ciphertext <> BA.convert (CCT.unAuthTag tag)) secretKeyProtectionMaterialLengths- :: OpenPGPPolicy -> SomePKPayload -> Either String (Int, Int)+ :: OpenPGPPolicy+ -> SomePKPayload+ -> Either SecretKeyError (Int, Int) secretKeyProtectionMaterialLengths policy pkp = case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of Just skPolicy ->@@ -753,13 +752,13 @@ V4 -> 8 _ -> secretKeyS2KSaltOctets skPolicy in Right (saltLen, secretKeyAEADNonceOctets skPolicy)- Nothing -> Left legacySecretKeyProtectionErrorMessage+ Nothing -> Left SecretKeyUnsupportedLegacyProtection generateSecretKeyProtectionMaterial :: MonadRandom m => OpenPGPPolicy -> SomePKPayload- -> m (Either String (Salt, IV))+ -> m (Either SecretKeyError (Salt, IV)) generateSecretKeyProtectionMaterial policy pkp = case secretKeyProtectionMaterialLengths policy pkp of Left err -> pure (Left err)@@ -773,7 +772,7 @@ -> SomePKPayload -> Salt -> IV- -> Either String (SymmetricAlgorithm, AEADAlgorithm, S2K)+ -> Either SecretKeyError (SymmetricAlgorithm, AEADAlgorithm, S2K) secretKeyProtectionDefaults policy pkp salt iv = case secretKeyProtectionPolicyForEncryption policy (_keyVersion pkp) of Just skPolicy -> do@@ -782,18 +781,18 @@ _ -> secretKeyS2KSaltOctets skPolicy when (B.length (unSalt salt) /= expectedSaltLen) $ Left- ( "secret key S2K salt must be "- ++ show expectedSaltLen- ++ " octets"+ ( SecretKeyPolicySaltLengthMismatch+ expectedSaltLen+ (B.length (unSalt salt)) ) when ( _keyVersion pkp == V6 && B.length (unIV iv) /= secretKeyAEADNonceOctets skPolicy ) $ Left- ( "v6 secret key AEAD nonce must be "- ++ show (secretKeyAEADNonceOctets skPolicy)- ++ " octets"+ ( SecretKeyPolicyNonceLengthMismatch+ (secretKeyAEADNonceOctets skPolicy)+ (B.length (unIV iv)) ) let defaultS2K = secretKeyDefaultS2KForSalt skPolicy salt s2k = case _keyVersion pkp of@@ -809,7 +808,7 @@ let sa = secretKeyDefaultSymmetricAlgorithm skPolicy aa = secretKeyDefaultAEADAlgorithm skPolicy pure (sa, aa, s2k)- Nothing -> Left legacySecretKeyProtectionErrorMessage+ Nothing -> Left SecretKeyUnsupportedLegacyProtection secretKeyProtectionPolicyForEncryption :: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy@@ -828,42 +827,39 @@ -> B.ByteString -> B.ByteString -> B.ByteString- -> Either String (CCT.AuthTag, B.ByteString)+ -> Either SecretKeyError (CCT.AuthTag, B.ByteString) encryptWithKey sa aa kek ad nonce plaintext = do expectedNonceLen <- aeadNonceSize aa when (B.length nonce /= expectedNonceLen) $- Left "invalid nonce size for v6 AEAD secret key payload"- let unsupportedSecretKeyAEADError = "unsupported secret-key AEAD symmetric algorithm"+ Left+ ( SecretKeyInvalidNonceSize+ "invalid nonce size for v6 AEAD secret key payload"+ )+ let unsupportedSecretKeyAEADError =+ SecretKeyAEADModeUnsupportedCipher sa case aa of OCB -> withAESCipher- show+ SecretKeyAEADModeCrypto unsupportedSecretKeyAEADError sa kek (\cipher -> encryptWithOCBRFC7253 cipher nonce ad plaintext) _ -> do mode <- aeadMode aa- withAESCipher show unsupportedSecretKeyAEADError sa kek $ \cipher ->- first- show- (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))- >>= \aead ->- pure (CCT.aeadSimpleEncrypt aead ad plaintext 16)--{-# DEPRECATED reencryptPrivateKeyTyped "Use reencryptSecretKey" #-}-reencryptPrivateKeyTyped- :: SomePKPayload- -> SKAddendumV v- -> Salt- -> IV- -> SKey- -> Passphrase- -> Either String (SKAddendumV v)-reencryptPrivateKeyTyped = reencryptPrivateKeyTypedWithPolicy defaultPolicy+ withAESCipher+ SecretKeyAEADModeCrypto+ unsupportedSecretKeyAEADError+ sa+ kek+ $ \cipher ->+ first+ SecretKeyAEADModeCrypto+ (CE.eitherCryptoError (CCT.aeadInit mode cipher nonce))+ >>= \aead ->+ pure (CCT.aeadSimpleEncrypt aead ad plaintext 16) -{-# DEPRECATED reencryptPrivateKeyTypedWithPolicy "Use reencryptSecretKey" #-}-reencryptPrivateKeyTypedWithPolicy+reencryptWithPolicyAndSaltAndIVTyped :: OpenPGPPolicy -> SomePKPayload -> SKAddendumV v@@ -871,8 +867,8 @@ -> IV -> SKey -> Passphrase- -> Either String (SKAddendumV v)-reencryptPrivateKeyTypedWithPolicy policy pkp skaV salt iv skey pp =+ -> Either SecretKeyError (SKAddendumV v)+reencryptWithPolicyAndSaltAndIVTyped policy pkp skaV salt iv skey pp = case skaV of SKAAEADV6 {} -> reencryptV6 policy SKACFBV6 {} -> reencryptV6 policy@@ -909,10 +905,11 @@ sha1Trailer (SKACFBLegacy sa' s2k' iv') SKALegacyCFBLegacy sa _ _ -> do- keyLen <- first renderCipherError (keySize sa)+ keyLen <-+ first SecretKeyPolicyCipherError (keySize sa) keyMaterial <- first- renderS2KError+ SecretKeyInvalidS2KMode (string2Key (Simple DeprecatedMD5) keyLen (unPassphrase pp)) cleartext <- legacySecretKeyPayload pkp skey let clearWithChecksum =@@ -922,7 +919,7 @@ ) (\encrypted -> SKALegacyCFBLegacy sa iv (BL.fromStrict encrypted)) <$> first- renderCipherError+ SecretKeyEncryptCipherError ( encryptNoNonce sa (Simple DeprecatedMD5)@@ -930,27 +927,13 @@ clearWithChecksum keyMaterial )- SKAUnprotectedLegacy _ _ -> Left legacySecretKeyProtectionErrorMessage+ SKAUnprotectedLegacy _ _ -> Left SecretKeyUnsupportedLegacyProtection where reencryptV6 pol = do (sa, aa, s2k) <- secretKeyProtectionDefaults pol pkp salt iv (\payload -> SKAAEADV6 sa aa s2k iv (BL.fromStrict payload)) <$> encryptV6SKey pkp skey sa aa s2k iv pp -{-# DEPRECATED reencryptPrivateKeyWithSaltAndIV "Use reencryptSecretKey" #-}-reencryptPrivateKeyWithSaltAndIV- :: SomePKPayload- -> SKAddendum- -> Salt- -> IV- -> SKey- -> Passphrase- -> Either String SKAddendum-reencryptPrivateKeyWithSaltAndIV pkp originalSka salt iv skey (Passphrase pp) =- fromSKAddendumForPKPayload pkp originalSka >>= \(SomeSKAddendumV skaV) ->- toSKAddendum- <$> reencryptPrivateKeyTyped pkp skaV salt iv skey (Passphrase pp)- reencryptS2KProtectedSecretKey :: SomePKPayload -> Salt@@ -964,14 +947,17 @@ -> IV -> BL.ByteString -> B.ByteString- -> Either String r+ -> Either SecretKeyError r )- -> Either String r+ -> Either SecretKeyError r reencryptS2KProtectedSecretKey pkp salt iv skey (Passphrase pp) sa s2k encryptFn = do- keyLen <- first renderCipherError (keySize sa)+ keyLen <-+ first SecretKeyPolicyCipherError (keySize sa) let retargetedS2K = retargetS2K salt s2k keyMaterial <-- first renderS2KError (string2Key retargetedS2K keyLen pp)+ first+ SecretKeyInvalidS2KMode+ (string2Key retargetedS2K keyLen pp) cleartext <- legacySecretKeyPayload pkp skey encryptFn sa retargetedS2K iv cleartext keyMaterial @@ -983,12 +969,12 @@ -> B.ByteString -> (BL.ByteString -> BL.ByteString) -> (BL.ByteString -> r)- -> Either String r+ -> Either SecretKeyError r encryptProtectedSecretKey sa s2k iv cleartext keyMaterial checksumTrailer mkAddendum = do let clearWithChecksum = BL.toStrict (cleartext <> checksumTrailer cleartext) encrypted <- first- renderCipherError+ SecretKeyEncryptCipherError (encryptNoNonce sa s2k iv clearWithChecksum keyMaterial) pure (mkAddendum (BL.fromStrict encrypted)) @@ -1002,9 +988,10 @@ (BA.convert (CH.hash (BL.toStrict cleartext) :: CH.Digest CH.SHA1)) legacySecretKeyPayload- :: SomePKPayload -> SKey -> Either String BL.ByteString+ :: SomePKPayload -> SKey -> Either SecretKeyError BL.ByteString legacySecretKeyPayload pkp skey =- runPut <$> putSKeyForPKPayload pkp skey+ first SecretKeyEncodeError $+ runPut <$> putSKeyForPKPayload pkp skey retargetS2K :: Salt -> S2K -> S2K retargetS2K salt (Salted ha oldSalt) =
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -23,9 +23,9 @@ , singleArmorPayloadOfType , singleClearSignedBlock , recommendedArmorType+ , parseRecipientKeyIdentifier , WireRepInput (..) , wireRepRefFromInput- , PktParseError (..) , parsePkts , parsePktsEither , parsePktsWithWireRep@@ -95,6 +95,7 @@ import Data.Text.Encoding.Error (lenientDecode) import Data.Word (Word16, Word32, Word8) import Network.URI (nullURI, parseURI, uriToString)+import Numeric (showHex) import Codec.Encryption.OpenPGP.Internal ( curve2Curve@@ -111,6 +112,24 @@ ) import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( ECDHOctetError (..)+ , ECPointError (..)+ , PktParseError (..)+ , PktParseErrorReason (..)+ , PktValidationError (..)+ , SKeyError (..)+ , SerializeError (..)+ , X25519OctetError (..)+ , renderECDHOctetError+ , renderECPointError+ , renderPktParseError+ , renderPktParseReason+ , renderPktValidationError+ , renderSKeyError+ , renderSerializeError+ , renderX25519OctetError+ ) import qualified Codec.Encryption.OpenPGP.Types.Internal.PKITypes as P instance Binary SigSubPacket where@@ -156,91 +175,91 @@ put = putS2K instance Binary (PKESK 'PKESKV3) where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary (PKESK 'PKESKV6) where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary Signature where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary (SKESK 'SKESKV4) where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary (SKESK 'SKESKV6) where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary (OnePassSignature 'OPSV3) where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary (OnePassSignature 'OPSV6) where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary SecretKey where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary PublicKey where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary SecretSubkey where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary CompressedData where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary SymEncData where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary Marker where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary LiteralData where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary Trust where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary UserId where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary PublicSubkey where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary UserAttribute where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary SymEncIntegrityProtectedData where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary ModificationDetectionCode where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary Padding where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary OtherPacket where- get = getPkt >>= either fail pure . fromPktEither+ get = getPkt >>= either (fail . show) pure . fromPktEither put = putPkt . toPkt instance Binary Pkt where@@ -1020,11 +1039,13 @@ Right (_, _, p) -> return p where parseLegacyPKESK- :: PacketVersion -> BL.ByteString -> Either String Pkt+ :: PacketVersion -> BL.ByteString -> Either PktParseError Pkt parseLegacyPKESK pv body = do (_, _, (eokeyid, pkaRaw, mpib)) <-- bimap (\(_, _, e) -> e) id $- runGetOrFail+ bimap+ (\(_, _, e) -> PktParseError 0 (PktParseErrorReasonGeneric e))+ id+ $ runGetOrFail ( do eokeyid <- getByteString 8 pka <- getWord8@@ -1043,7 +1064,7 @@ parseLegacyPKESKMPIs :: PubKeyAlgorithm -> BL.ByteString- -> Either String (NE.NonEmpty MPI)+ -> Either PktParseError (NE.NonEmpty MPI) parseLegacyPKESKMPIs pka mpib = do case parseLegacyPKESKMPIsStrict pka mpib of Right sk -> pure sk@@ -1051,54 +1072,72 @@ | pka == X25519 -> case parseLegacyPKESKX25519V3Octets mpib of Right sk -> Right sk- Left octetErr ->- Left- ( strictErr- ++ "; also failed to parse RFC9580 X25519 v3 octet layout: "- ++ octetErr- )+ Left _ ->+ Left $+ case strictErr of+ PktParseError o r -> PktParseError o r | pka == ECDH -> case parseLegacyPKESKECDHOctets mpib of Right sk -> Right sk- Left octetErr ->- Left- ( strictErr- ++ "; also failed to parse RFC6637 ECDH v3 octet layout: "- ++ octetErr- )+ Left _ ->+ Left $+ case strictErr of+ PktParseError o r -> PktParseError o r | otherwise -> Left strictErr parseLegacyPKESKMPIsStrict :: PubKeyAlgorithm -> BL.ByteString- -> Either String (NE.NonEmpty MPI)+ -> Either PktParseError (NE.NonEmpty MPI) parseLegacyPKESKMPIsStrict pka mpib = do (rest, _, sk) <-- bimap (\(_, _, e) -> e) id $- runGetOrFail (parserForLegacyPKESKMPIs pka) mpib+ bimap+ (\(_, _, e) -> PktParseError 0 (PktParseErrorReasonGeneric e))+ id+ $ runGetOrFail (parserForLegacyPKESKMPIs pka) mpib if BL.null rest then pure (NE.fromList sk) else- Left- ("unexpected trailing PKESK MPI data for algorithm " ++ show pka)+ Left $+ PktParseError+ 0+ ( PktParseErrorReasonUnexpectedTrailingPKESKData+ { pkeskAlgorithm = pka+ }+ ) parseLegacyPKESKX25519V3Octets- :: BL.ByteString -> Either String (NE.NonEmpty MPI)+ :: BL.ByteString -> Either PktParseError (NE.NonEmpty MPI) parseLegacyPKESKX25519V3Octets mpib = do if BL.length mpib < 33- then Left "X25519 v3 PKESK octet layout is too short"+ then+ Left $+ PktParseError+ 0+ ( PktParseErrorReasonX25519V3OctetLayoutInvalid+ X25519OctetErrorReasonTooShort+ ) else Right () let ephemeral = BL.toStrict (BL.take 32 mpib) eskLen = fromIntegral (BL.index mpib 32) :: Int eskWithAlgo = BL.toStrict (BL.drop 33 mpib) if eskLen /= B.length eskWithAlgo then- Left "X25519 v3 PKESK octet layout has inconsistent ESK length"+ Left $+ PktParseError+ 0+ ( PktParseErrorReasonX25519V3OctetLayoutInvalid+ X25519OctetErrorReasonInconsistentESKLength+ ) else Right () if B.null eskWithAlgo then- Left- "X25519 v3 PKESK octet layout must include a symmetric algorithm octet"+ Left $+ PktParseError+ 0+ ( PktParseErrorReasonX25519V3OctetLayoutInvalid+ X25519OctetErrorReasonMissingSymmetricAlgorithm+ ) else Right () let symAlgo = B.head eskWithAlgo if symAlgo@@ -1110,39 +1149,59 @@ pure (NE.fromList [MPI (os2ip ephemeral), MPI (os2ip eskWithAlgo)]) else- Left- ( "X25519 v3 PKESK octet layout has unsupported symmetric algorithm octet "- ++ show symAlgo- )+ Left $+ PktParseError+ 0+ ( PktParseErrorReasonX25519V3OctetLayoutInvalid+ ( X25519OctetErrorReasonUnsupportedSymmetricAlgorithm+ { x25519SymmetricAlgorithmOctet = symAlgo+ }+ )+ ) -- \| Parse an RFC 6637 §8 ECDH PKESKv3 body as MPI(ephemeral) || 1-octet-count || C. -- This is the interoperable wire format produced by GnuPG and other RFC-compliant -- implementations. hOpenPGP previously wrote both fields as MPIs; this fallback -- allows reading RFC-compliant packets when the strict two-MPI path fails. parseLegacyPKESKECDHOctets- :: BL.ByteString -> Either String (NE.NonEmpty MPI)+ :: BL.ByteString -> Either PktParseError (NE.NonEmpty MPI) parseLegacyPKESKECDHOctets mpib = do (rest, _, ephMPI) <-- bimap (\(_, _, e) -> e) id $ runGetOrFail getMPI mpib+ bimap+ (\(_, _, e) -> PktParseError 0 (PktParseErrorReasonGeneric e))+ id+ $ runGetOrFail getMPI mpib let restBS = BL.toStrict rest when (B.null restBS) $- Left- "ECDH v3 PKESK RFC6637 octet layout: missing wrapped-key length octet after ephemeral MPI"+ Left $+ PktParseError+ 0+ ( PktParseErrorReasonECDHOctetLayoutInvalid+ ECDHOctetErrorReasonMissingWrappedKeyLength+ ) let wrappedLen = fromIntegral (B.head restBS) :: Int wrapped = B.tail restBS when (wrappedLen /= B.length wrapped) $- Left- ( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length field "- ++ show wrappedLen- ++ " does not match body length "- ++ show (B.length wrapped)- )+ Left $+ PktParseError+ 0+ ( PktParseErrorReasonECDHOctetLayoutInvalid+ ( ECDHOctetErrorReasonWrappedKeyLengthMismatch+ { ecdhDeclaredLength = wrappedLen+ , ecdhActualLength = B.length wrapped+ }+ )+ ) when (wrappedLen < 24 || wrappedLen `mod` 8 /= 0) $- Left- ( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length "- ++ show wrappedLen- ++ " is not a valid RFC 3394 wrapped key size"- )+ Left $+ PktParseError+ 0+ ( PktParseErrorReasonECDHOctetLayoutInvalid+ ( ECDHOctetErrorReasonInvalidWrappedKeySize+ { ecdhWrappedKeySize = wrappedLen+ }+ )+ ) pure (ephMPI NE.:| [MPI (os2ip wrapped)]) parserForLegacyPKESKMPIs :: PubKeyAlgorithm -> Get [MPI]@@ -1166,75 +1225,33 @@ "v4 SKESK packets with encrypted session keys must not use Simple S2K" validateV4SKESKEncryptedSessionKeyS2K _ (Just _) = pure () - parseV6PKESK :: BL.ByteString -> Either String Pkt+ parseV6PKESK :: BL.ByteString -> Either PktParseError Pkt parseV6PKESK body = do- (_, _, (recipientKeyIdentifier, pka, esk)) <-- bimap (\(_, _, e) -> e) id $- runGetOrFail+ (_, _, (recipientIdBytes, pka, esk)) <-+ bimap+ (\(_, _, e) -> PktParseError 0 (PktParseErrorReasonGeneric e))+ id+ $ runGetOrFail ( do keyIdentifierLen <- getWord8- recipientKeyIdentifier <-+ recipientIdBytes <- getLazyByteString (fromIntegral keyIdentifierLen) pka <- getWord8 esk <- getRemainingLazyByteString- pure (recipientKeyIdentifier, pka, esk)+ pure (recipientIdBytes, pka, esk) ) body- validateV6PKESKRecipientIdentifier recipientKeyIdentifier+ mKvFp <- parseRecipientKeyIdentifier recipientIdBytes pure $ PKESKPkt ( PKESKPayloadV6Packet ( PKESKPayloadV6- (BL.toStrict recipientKeyIdentifier)+ mKvFp (toFVal pka)- (BL.toStrict esk)+ (EncryptedSessionKey (BL.toStrict esk)) ) )- where- validateV6PKESKRecipientIdentifier- :: BL.ByteString -> Either String ()- validateV6PKESKRecipientIdentifier rid =- case BL.length rid of- 0 -> Right ()- 20 -> Right ()- 32 -> Right ()- 21 -> validateVersionedFingerprint rid- 33 -> validateVersionedFingerprint rid- ridLen ->- Left- ( "invalid PKESK v6 recipient identifier length: "- ++ show ridLen- ++ " (expected 0, 20, 21, 32, or 33)"- ) - validateVersionedFingerprint :: BL.ByteString -> Either String ()- validateVersionedFingerprint rid =- let keyVersion = BL.head rid- fingerprintLen = BL.length (BL.tail rid)- in case keyVersion of- 4 ->- if fingerprintLen == 20- then Right ()- else- Left- ( "PKESK v6 recipient identifier length/version mismatch: key version 4 requires fingerprint length 20, got "- ++ show fingerprintLen- )- 6 ->- if fingerprintLen == 32- then Right ()- else- Left- ( "PKESK v6 recipient identifier length/version mismatch: key version 6 requires fingerprint length 32, got "- ++ show fingerprintLen- )- _ ->- Left- ( "invalid PKESK v6 recipient key version: "- ++ show keyVersion- ++ " (expected 4 or 6)"- )- getPkt' :: Word8 -> ByteOffset -> Get Pkt getPkt' t len = case t of 1 -> getPKESK@@ -1266,10 +1283,10 @@ if pv == 6 then case parseV6PKESK body of Right pkt -> return pkt- Left err -> fail err+ Left err -> fail (renderPktParseError err) else case parseLegacyPKESK pv body of Right pkt -> return pkt- Left err -> fail err+ Left err -> fail (renderPktParseError err) getSKESK :: Get Pkt getSKESK = do@@ -1501,6 +1518,43 @@ ) _ -> fail ("Unsupported SEIPD version: " ++ show pv) +parseRecipientKeyIdentifier+ :: BL.ByteString+ -> Either PktParseError (Maybe (KeyVersion, Fingerprint))+parseRecipientKeyIdentifier rid =+ case BL.length rid of+ 0 -> Right Nothing+ 21 -> parseVersionedKeyIdentifier rid V4 0x04 20+ 33 -> parseVersionedKeyIdentifier rid V6 0x06 32+ n ->+ Left $+ PktParseError+ { pktParseErrorOffset = 0+ , pktParseErrorReason =+ PktParseErrorReasonPKESKv6RecipientIdentifierInvalid+ { pkeskRecipientIdLength = fromIntegral n+ }+ }+ where+ parseVersionedKeyIdentifier bs kv expectedVersionByte expectedFpLen =+ case BL.uncons bs of+ Just (v, fpBytes)+ | v == expectedVersionByte+ && BL.length fpBytes == fromIntegral expectedFpLen ->+ Right $ Just (kv, Fingerprint (BL.toStrict fpBytes))+ _ ->+ Left $+ PktParseError+ { pktParseErrorOffset = 0+ , pktParseErrorReason =+ PktParseErrorReasonPKESKv6FingerprintLengthMismatch+ { pkeskKeyVersion = expectedVersionByte+ , pkeskExpectedFingerprintLength = expectedFpLen+ , pkeskActualFingerprintLength =+ fromIntegral $ BL.length (BL.tail bs)+ }+ }+ getUserAttrSubPacket :: Get UserAttrSubPacket getUserAttrSubPacket = do l <- fmap fromIntegral getSubPacketLength@@ -1607,16 +1661,24 @@ putLazyByteString bsk putPKESKV6 :: PKESKPayloadV6 -> Put-putPKESKV6 (PKESKPayloadV6 recipientKeyIdentifier pka esk) = do+putPKESKV6 (PKESKPayloadV6 mKvFp pka (EncryptedSessionKey esk)) = do putWord8 (0xc0 .|. 1)- let keyIdentifierLen = B.length recipientKeyIdentifier- when (keyIdentifierLen > 255) $- error "PKESK v6 recipient key identifier must fit in one octet"- putPacketLength . fromIntegral $- 3 + keyIdentifierLen + B.length esk- putWord8 6- putWord8 (fromIntegral keyIdentifierLen)- putByteString recipientKeyIdentifier+ case mKvFp of+ Nothing -> do+ putPacketLength . fromIntegral $ 3 + B.length esk+ putWord8 6+ putWord8 0+ Just (kv, fp) -> do+ let versionByte = fromIntegral (fromEnum kv) :: Word8+ fpBytes = unFingerprint fp+ ridLen = B.length fpBytes+ when (ridLen > 255) $+ error "PKESK v6 recipient key identifier must fit in one octet"+ putPacketLength . fromIntegral $ 3 + 1 + ridLen + B.length esk+ putWord8 6+ putWord8 (fromIntegral (1 + ridLen))+ putWord8 versionByte+ putByteString fpBytes putWord8 $ fromIntegral . fromFVal $ pka putByteString esk @@ -1842,15 +1904,18 @@ {- | Validate a packet before serialization to catch constraint violations early. Returns Left with descriptive error if validation fails. -}-validatePkt :: Pkt -> Either String ()+validatePkt :: Pkt -> Either SerializeError () validatePkt ( PKESKPkt- (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier _ _))+ (PKESKPayloadV6Packet (PKESKPayloadV6 mKvFp _ _)) ) = do- let keyIdentifierLen = B.length recipientKeyIdentifier+ let keyIdentifierLen = case mKvFp of+ Nothing -> 0+ Just (_, Fingerprint fp) -> 1 + B.length fp when (keyIdentifierLen > 255) $- Left- "PKESK v6 recipient key identifier must fit in one octet (max 255 bytes)"+ Left $+ SerializeErrorReasonValidation+ PktValidationErrorReasonPKESKv6RecipientKeyIdentifierTooLong Right () validatePkt ( OnePassSignaturePkt@@ -1858,50 +1923,70 @@ ) = do let saltBytes = unSignatureSalt salt saltSize = B.length saltBytes- expectedSaltSize <-+ expectedSaltSizeE <- case v6SaltSizeForHashAlgorithm ha of Nothing -> Left $- "signature hash algorithm does not define a V6 salt size: "- ++ show ha+ SerializeErrorReasonValidation+ (PktValidationErrorReasonHashAlgorithmNoV6SaltSize ha) Just sz -> Right sz+ let expectedSaltSize = expectedSaltSizeE when (fromIntegral saltSize /= expectedSaltSize) $- Left- ( "OPS v6 salt size mismatch for "- ++ show ha- ++ ": expected "- ++ show expectedSaltSize- ++ ", got "- ++ show saltSize- )+ Left $+ SerializeErrorReasonValidation+ ( PktValidationErrorReasonOPSv6SaltSizeMismatch+ { saltSizeExpected = expectedSaltSize+ , saltSizeActual = fromIntegral saltSize+ }+ ) when (B.length (unFingerprint signerFingerprint) /= 32) $- Left "OPS v6 signer fingerprint must be exactly 32 octets"+ Left $+ SerializeErrorReasonValidation+ PktValidationErrorReasonOPSv6SignerFingerprintWrongLength Right () validatePkt ( SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aeadalgo chunkSize salt _) ) = do when (B.length (unSalt salt) /= 32) $- Left "SEIPD v2 salt must be exactly 32 octets"+ Left $+ SerializeErrorReasonValidation+ PktValidationErrorReasonSEIPDv2SaltWrongLength when (chunkSize > 16) $- Left "SEIPD v2 chunk size octet must be between 0 and 16"+ Left $+ SerializeErrorReasonValidation+ PktValidationErrorReasonSEIPDv2ChunkSizeTooLarge case symalgo of- OtherSA _ -> Left "SEIPD v2 requires a known symmetric algorithm"- Plaintext -> Left "SEIPD v2 cannot use plaintext cipher"+ OtherSA _ ->+ Left $+ SerializeErrorReasonValidation+ PktValidationErrorReasonSEIPDv2SymmetricAlgorithmUnknown+ Plaintext ->+ Left $+ SerializeErrorReasonValidation+ PktValidationErrorReasonSEIPDv2SymmetricAlgorithmPlaintext _ -> Right () case aeadalgo of- OtherAEADAlgo _ -> Left "SEIPD v2 requires a known AEAD algorithm"+ OtherAEADAlgo _ ->+ Left $+ SerializeErrorReasonValidation+ PktValidationErrorReasonSEIPDv2AEADAlgorithmUnknown _ -> Right () validatePkt (OtherPacketPkt t _) = do when (t > 63) $- Left ("cannot serialize OtherPacket packet tag > 63: " ++ show t)+ Left $+ SerializeErrorReasonValidation+ ( PktValidationErrorReasonOtherPacketTagTooLarge+ { otherPacketTag = t+ }+ ) Right () validatePkt _ = Right () {- | Serialize a packet with explicit validation and error handling. Validates constraints before calling putPkt to ensure errors are caught early. -}-putPktEither :: Pkt -> Either String Put+putPktEither :: Pkt -> Either SerializeError Put putPktEither pkt = (putPkt pkt) <$ validatePkt pkt putLengthThenPayload :: ByteString -> Put@@ -1986,7 +2071,7 @@ curveoid <- getByteString (fromIntegral curvelength) MPI mpi <- getMPI case curveoidBSToCurve curveoid of- Left e -> fail e+ Left e -> fail (renderCurveConversionError e) Right Curve25519 -> EdDSAPubKey P.EdSigningCurve25519 <$> ( PrefixedNativeEPoint@@ -1994,7 +2079,7 @@ ) Right curve -> case bs2Point (i2osp mpi) of- Left e -> fail e+ Left e -> fail (renderSerializeError e) Right point -> return . ECDSAPubKey@@ -2021,7 +2106,7 @@ curveoid <- getByteString (fromIntegral curvelength) MPI mpi <- getMPI case curveoidBSToEdSigningCurve curveoid of- Left e -> fail e+ Left e -> fail (renderCurveConversionError e) Right P.EdSigningCurve25519 -> EdDSAPubKey P.EdSigningCurve25519 <$> ( PrefixedNativeEPoint@@ -2159,19 +2244,24 @@ return $ SLHDSAPubKey bs | otherwise = getPubkey pka -bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint+bs2Point+ :: B.ByteString -> Either SerializeError ECDSA.PublicPoint bs2Point bs = if B.null bs- then Left "empty EC point encoding"+ then Left $ SerializeErrorReasonECPoint ECPointErrorReasonEmpty else let xy = B.drop 1 bs l = B.length xy in if B.head bs /= 0x04- then Left $ "unknown type of point: " ++ show (B.unpack bs)+ then+ Left $+ SerializeErrorReasonECPoint+ (ECPointErrorReasonUnknownType (B.head bs)) else if odd l then- Left "malformed EC point encoding: odd coordinate payload length"+ Left $+ SerializeErrorReasonECPoint ECPointErrorReasonOddCoordinateLength else return ( uncurry@@ -2189,7 +2279,7 @@ Right curveoidbs -> putCurveOID curveoidbs >> mapM_ put (pubkeyToMPIs p)- Left err -> error err+ Left err -> error (renderCurveConversionError err) putPubkey p@( ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)))@@ -2201,14 +2291,14 @@ putCurveOID curveoidbs >> mapM_ put (pubkeyToMPIs p) >> putECDHKDFParams kha ksa- Left err -> error err+ Left err -> error (renderCurveConversionError err) putPubkey p@(ECDHPubKey (EdDSAPubKey curve (PrefixedNativeEPoint _)) kha ksa) = case curveToCurveoidBS (ed2ec curve) of Right curveoidbs -> putCurveOID curveoidbs >> mapM_ put (pubkeyToMPIs p) >> putECDHKDFParams kha ksa- Left err -> error err+ Left err -> error (renderCurveConversionError err) where ed2ec P.EdSigningCurve25519 = Curve25519 ed2ec P.EdSigningCurve448 = Curve448@@ -2217,7 +2307,7 @@ Right curveoidbs -> putCurveOID curveoidbs >> mapM_ put (pubkeyToMPIs p)- Left err -> error err+ Left err -> error (renderCurveConversionError err) putPubkey (ECDHPubKey (EdDSAPubKey curve (NativeEPoint _)) _ _) = error ( "legacy ECDH serialization requires a prefixed-native "@@ -2493,14 +2583,13 @@ ++ show other ) -putSKey :: SKey -> Either String Put+putSKey :: SKey -> Either SerializeError Put putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) = case inverse q p of Just u -> Right (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)) Nothing ->- Left- "putSKey: invalid RSA key — q has no multiplicative inverse mod p (key is mathematically broken)"+ Left $ SerializeErrorReasonPutSKey SKeyErrorReasonInvalidRSAKey putSKey (DSAPrivateKey (DSA_PrivateKey (D.PrivateKey _ x))) = Right (put (MPI x)) putSKey (ElGamalPrivateKey x) =@@ -2519,7 +2608,8 @@ putSKey (SLHDSAPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk)) putSKey (UnknownSKey bs) = Right (putLazyByteString bs) -putSKeyForPKPayload :: SomePKPayload -> SKey -> Either String Put+putSKeyForPKPayload+ :: SomePKPayload -> SKey -> Either SerializeError Put putSKeyForPKPayload _ sk@(EdDSAPrivateKey {}) = putSKey sk putSKeyForPKPayload _ sk@(Ed25519PrivateKey {}) = putSKey sk putSKeyForPKPayload _ sk@(Ed448PrivateKey {}) = putSKey sk@@ -2633,7 +2723,11 @@ case s2k of OtherS2K _ _ -> return $ constructor symenc s2k mempty BL.empty _ -> do- blockSize <- either fail pure (symEncBlockSize symenc)+ blockSize <-+ either+ (fail . renderSerializeError)+ pure+ (symEncBlockSize symenc) iv <- IV <$> getByteString blockSize encryptedblock <- getRemainingLazyByteString return $ constructor symenc s2k iv encryptedblock@@ -2733,7 +2827,11 @@ | otherwise -> pure parsed iv <- getRemainingLazyByteString let symenc = toFVal symencWord- blockSize <- either fail pure (symEncBlockSize symenc)+ blockSize <-+ either+ (fail . renderSerializeError)+ pure+ (symEncBlockSize symenc) when (BL.length iv /= fromIntegral blockSize) $ fail "invalid v6 CFB IV length" pure (symenc, s2k, BL.toStrict iv)@@ -2798,19 +2896,27 @@ fail "v6 secret key packets MUST NOT use LegacyCFB (known cipher algo ID)" PKPayloadV3 {} -> do- blockSize <- either fail pure (symEncBlockSize (toFVal symenc))+ blockSize <-+ either+ (fail . renderSerializeError)+ pure+ (symEncBlockSize (toFVal symenc)) iv <- getByteString blockSize encryptedblock <- getRemainingLazyByteString return (SKALegacyCFBLegacy (toFVal symenc) (IV iv) encryptedblock) PKPayloadV4 {} -> do- blockSize <- either fail pure (symEncBlockSize (toFVal symenc))+ blockSize <-+ either+ (fail . renderSerializeError)+ pure+ (symEncBlockSize (toFVal symenc)) iv <- getByteString blockSize encryptedblock <- getRemainingLazyByteString return (SKALegacyCFBLegacy (toFVal symenc) (IV iv) encryptedblock) -putSKAddendum :: SKAddendum -> Either String Put+putSKAddendum :: SKAddendum -> Either SerializeError Put putSKAddendum (SUSMalleableCFB symenc s2k iv encryptedblock) = Right $ do putWord8 255@@ -2863,7 +2969,7 @@ putSKAddendumForPKPayload :: SomePKPayload -> SKAddendum -> Put putSKAddendumForPKPayload pkp ska = case fromSKAddendumForPKPayload pkp ska of- Left e -> error e+ Left e -> error (renderSKAddendumKeyVersionError e) Right (SomeSKAddendumV skaV) -> putSKAddendumForPKPayloadTyped pkp skaV @@ -2872,7 +2978,7 @@ putWord8 0 let putSecret = case putSKeyForPKPayload pkp sk of- Left err -> error err+ Left err -> error (renderSerializeError err) Right p -> p skb = runPut putSecret putLazyByteString skb@@ -2885,7 +2991,7 @@ let skb = runPut ( case putSKeyForPKPayload pkp sk of- Left err -> error err+ Left err -> error (renderSerializeError err) Right p -> p ) putUnencryptedSKAddendum pkp sk@@ -2936,7 +3042,7 @@ putLazyByteString encryptedblock putSKAddendumForPKPayloadTyped _ skaV = case putSKAddendum (toSKAddendum skaV) of- Left e -> error e+ Left e -> error (renderSerializeError e) Right p -> p aeadNonceSize :: AEADAlgorithm -> Int@@ -2945,7 +3051,8 @@ aeadNonceSize GCM = 12 aeadNonceSize (OtherAEADAlgo _) = 0 -symEncBlockSize :: SymmetricAlgorithm -> Either String Int+symEncBlockSize+ :: SymmetricAlgorithm -> Either SerializeError Int symEncBlockSize Plaintext = Right 0 symEncBlockSize IDEA = Right 8 symEncBlockSize TripleDES = Right 8@@ -2959,10 +3066,7 @@ symEncBlockSize Camellia192 = Right 16 symEncBlockSize Camellia256 = Right 16 symEncBlockSize sa =- Left- ( "unsupported symmetric algorithm for secret-key IV sizing: "- ++ show sa- )+ Left $ SerializeErrorReasonSymEncBlockSize sa decodeIterationCount :: Word8 -> IterationCount decodeIterationCount c =@@ -3535,13 +3639,6 @@ (pkts, Nothing) -> Right (reverse pkts) (_, Just err) -> Left err -data PktParseError- = PktParseError- { pktParseErrorOffset :: Int64- , pktParseErrorMessage :: String- }- deriving (Eq, Show)- parsePktsAccum :: Int64 -> [Pkt] -> ByteString -> ([Pkt], Maybe PktParseError) parsePktsAccum offset acc lbs@@ -3556,7 +3653,7 @@ Just PktParseError { pktParseErrorOffset = offset + parseOffset- , pktParseErrorMessage = msg+ , pktParseErrorReason = PktParseErrorReasonGeneric msg } armorPayloads :: [Armor] -> [ByteString]
Codec/Encryption/OpenPGP/SerializeForSigs.hs view
@@ -50,6 +50,9 @@ ( TextNormalizationMode (..) ) import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( PacketCoercionError (..)+ ) data SignatureSerializationCase where SignatureSerializationCaseV4@@ -223,9 +226,13 @@ payloadForSig :: SigType -> PktStreamContext -> ByteString payloadForSig BinarySig state =- case (fromPktEither (lastLD state) :: Either String LiteralData) of+ case ( fromPktEither (lastLD state)+ :: Either PacketCoercionError LiteralData+ ) of Right ld -> ld ^. literalDataPayload- Left err -> error ("payloadForSig expected literal data packet: " ++ err)+ Left err ->+ error+ ("payloadForSig expected literal data packet: " ++ show err) payloadForSig CanonicalTextSig state = stripTrailingWhitespacePerLine (canonicalizeLineEndings (payloadForSig BinarySig state))
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -14,12 +14,8 @@ module Codec.Encryption.OpenPGP.Signatures ( -- * Verification- SignError (..)- , renderSignError- , CertificationState (..)+ CertificationState (..) , certificationStateAt- , VerificationError (..)- , renderVerificationError , verifySigWith , verifyAgainstKeyring , verifyAgainstKeys@@ -169,141 +165,21 @@ 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.Errors+ ( KeyIdError+ , SignError (..)+ , VerificationError (..)+ , renderSignError+ , renderVerificationError+ ) import Data.Conduit.OpenPGP.Keyring.Instances () -data VerificationError- = IssuerSubpacketMismatch- | IssuerSubpacketUncheckable String- | IssuerKeyIdProhibitedInV6Signature- | IssuerFingerprintSubpacketMismatch- | UnsupportedCriticalSubpacket SigType- | UnknownCriticalPacketInStream Word8- | BrokenCriticalPacketInStream Word8 String- | ExternalVerificationError String- | NonSignaturePacket- | UnexpectedSignaturePayloadShape- | MissingHashAlgorithm- | HashComputationFailed String- | UnexpectedKeyVersion- | SignatureHashUnsupportedByAlgorithm HashAlgorithm PubKeyAlgorithm- | KeyRevoked- | SigningKeyUnavailableAtSignatureTime- | MissingIssuer- | SigningKeyNotFound (Maybe EightOctetKeyId) (Maybe Fingerprint)- | MultipleVerificationSuccesses Int- | UnsupportedKeyType PubKeyAlgorithm- | SignatureMismatch PubKeyAlgorithm Fingerprint- | SignatureShapeMismatch PubKeyAlgorithm- | SignatureEncodingInvalid PubKeyAlgorithm String- | SignaturePolicyHashUnsupported HashAlgorithm- | SignaturePolicyPKAMismatch PubKeyAlgorithm PubKeyAlgorithm- | SignatureExpired- | CandidateKeyFailures [VerificationError]- | {- | An embedded primary-key back-signature (type 0x19) in a subkey- binding signature failed to verify.- -}- InvalidSubkeyBackSignature VerificationError- deriving (Eq, Show)- data CertificationState = CertificationNotYetKnown | CertificationActive | CertificationRevoked deriving (Eq, Show) -renderVerificationError :: VerificationError -> String-renderVerificationError IssuerSubpacketMismatch =- "verification failed: issuer subpacket does not match the actual signer"-renderVerificationError (IssuerSubpacketUncheckable err) =- "verification failed: issuer subpacket cannot be checked ("- ++ err- ++ ")"-renderVerificationError IssuerKeyIdProhibitedInV6Signature =- "verification failed: Issuer Key ID subpacket is prohibited in v6 signatures"-renderVerificationError IssuerFingerprintSubpacketMismatch =- "verification failed: issuer fingerprint subpacket does not match the actual signer"-renderVerificationError (UnsupportedCriticalSubpacket sigType) =- "verification failed: unsupported critical hashed subpacket in "- ++ show sigType- ++ " signature"-renderVerificationError (UnknownCriticalPacketInStream t) =- "verification failed: unknown critical packet type in packet sequence ("- ++ show t- ++ ")"-renderVerificationError (BrokenCriticalPacketInStream t err) =- "verification failed: broken critical packet type "- ++ show t- ++ ": "- ++ err-renderVerificationError (ExternalVerificationError err) = err-renderVerificationError NonSignaturePacket =- "verification failed: non-signature packet encountered where signature was expected"-renderVerificationError UnexpectedSignaturePayloadShape =- "verification failed: unexpected signature payload shape"-renderVerificationError MissingHashAlgorithm =- "verification failed: signature payload is missing hash algorithm"-renderVerificationError (HashComputationFailed err) =- "verification failed: hash computation error (" ++ err ++ ")"-renderVerificationError UnexpectedKeyVersion =- "verification failed: signing key has unexpected version (only v4 and v6 are supported)"-renderVerificationError (SignatureHashUnsupportedByAlgorithm ha pka) =- "verification failed: hash algorithm "- ++ show ha- ++ " is not supported by "- ++ show pka- ++ " signing backend"-renderVerificationError KeyRevoked =- "verification failed: signing key is revoked"-renderVerificationError SigningKeyUnavailableAtSignatureTime =- "verification failed: signing key was not valid at the signature creation time"-renderVerificationError MissingIssuer =- "verification failed: signature is missing issuer information"-renderVerificationError (SigningKeyNotFound meoki mfp) =- "verification failed: signing key not found in keyring"- ++ issuerContext meoki mfp-renderVerificationError (MultipleVerificationSuccesses n) =- "verification failed: multiple successful key matches ("- ++ show n- ++ ")"-renderVerificationError (UnsupportedKeyType pka) =- "verification failed: unsupported public key algorithm for verification ("- ++ show pka- ++ ")"-renderVerificationError (SignatureMismatch pka fpr) =- "verification failed: "- ++ show pka- ++ " signature mismatch (signer "- ++ show fpr- ++ ")"-renderVerificationError (SignatureShapeMismatch pka) =- "verification failed: malformed "- ++ show pka- ++ " signature encoding"-renderVerificationError (SignatureEncodingInvalid pka err) =- "verification failed: invalid "- ++ show pka- ++ " key/signature encoding ("- ++ err- ++ ")"-renderVerificationError (SignaturePolicyHashUnsupported ha) =- "verification failed: unsupported signature hash policy ("- ++ show ha- ++ ")"-renderVerificationError (SignaturePolicyPKAMismatch sigPka keyPka) =- "verification failed: signature public-key algorithm "- ++ show sigPka- ++ " does not match key algorithm "- ++ show keyPka-renderVerificationError SignatureExpired =- "verification failed: signature expired"-renderVerificationError (CandidateKeyFailures errs) =- "verification failed: no candidate key validated the signature ("- ++ intercalate "; " (nubOrd $ map renderVerificationError errs)- ++ ")"-renderVerificationError (InvalidSubkeyBackSignature err) =- "verification failed: embedded primary-key back-signature verification failed: "- ++ renderVerificationError err- issuerContext :: Maybe EightOctetKeyId -> Maybe Fingerprint -> String issuerContext meoki mfp =@@ -320,40 +196,6 @@ :: VerificationError -> Either VerificationError a verificationError = Left -data SignError- = SignBackendError String- | SignUnsupportedCertificationType SigType- | SignUnsupportedKeySignatureType SigType- | SignV6SaltSizeMismatch HashAlgorithm Word8 Int- | SignProducedWrongLength String Int Int- deriving (Eq, Show)--renderSignError :: SignError -> String-renderSignError (SignBackendError err) =- "signature backend error: " ++ err-renderSignError (SignUnsupportedCertificationType st) =- "unsupported certification signature type: "- ++ show st- ++ " (expected one of GenericCert/PersonaCert/CasualCert/PositiveCert)"-renderSignError (SignUnsupportedKeySignatureType st) =- "unsupported key signature type: "- ++ show st- ++ " (expected DirectKeySignature or KeyRevocationSig)"-renderSignError (SignV6SaltSizeMismatch ha expected actual) =- "v6 signature salt size mismatch for "- ++ show ha- ++ ": expected "- ++ show expected- ++ ", got "- ++ show actual-renderSignError (SignProducedWrongLength algo expected actual) =- algo- ++ " produced a non-"- ++ show expected- ++ "-byte signature (got "- ++ show actual- ++ ")"- data VerifiableSignatureV where VerifiableSignatureV4 :: SignaturePayloadV 'SigPayloadV4 -> VerifiableSignatureV@@ -623,7 +465,7 @@ isBindingSignatureType _ = False checkIssuerSubpacket- :: Either String EightOctetKeyId+ :: Either KeyIdError EightOctetKeyId -> SigSubPacketPayload -> Either VerificationError Bool checkIssuerSubpacket (Right signer) (Issuer i)@@ -646,6 +488,15 @@ verificationError IssuerFingerprintSubpacketMismatch checkIssuerFingerprintSubpacket _ _ _ = Right True +{- | Internal encoding-validation outcome for @edPointToRawPublic@, used+only within 'verifyTKWith' to distinguish the two literal-text failure+modes so they can be converted to typed 'VerificationError' constructors+without ever routing through a rendered 'String'.+-}+data EdEncodingError+ = BadPrefix+ | BadLength !String !Int !Int+ verifyTKWith :: ( Pkt -> PktStreamContext@@ -1279,7 +1130,7 @@ enforceLeft16Prefix sigClass sigHash signedPayload = do expectedLeft16 <- either- (verificationError . HashComputationFailed)+ (verificationError . left16ErrorToVerificationError) Right (left16FromSignedPayload sigHash signedPayload) actualLeft16 <- signatureLeft16FromClass sigClass@@ -1358,19 +1209,22 @@ ecdsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch ECDSA) ed25519Verify sigPka pub (r :| [s]) hd pkey bs = case edPointToRawPublic 32 pkey of- Left err ->- verificationError (SignatureEncodingInvalid sigPka err)+ Left BadPrefix ->+ verificationError (SignatureEncodingInvalidBadPrefix sigPka)+ Left (BadLength label expected actual) ->+ verificationError+ (SignatureEncodingInvalidLength sigPka label expected actual) Right rawPub -> case cf2es (Ed25519.publicKey rawPub) of Left err ->- verificationError (SignatureEncodingInvalid sigPka err)+ verificationError (SignatureEncodingInvalidCrypto sigPka err) Right ep -> case cf2es ( Ed25519.signature (pad32 (i2osp (unMPI r)) <> pad32 (i2osp (unMPI s))) ) of Left err ->- verificationError (SignatureEncodingInvalid sigPka err)+ verificationError (SignatureEncodingInvalidCrypto sigPka err) Right es -> let prehash = crazyHash hd bs :: B.ByteString in if Ed25519.verify ep prehash es@@ -1381,19 +1235,22 @@ verificationError (SignatureShapeMismatch sigPka) ed448Verify sigPka pub (r :| [s]) hd pkey bs = case edPointToRawPublic 57 pkey of- Left err ->- verificationError (SignatureEncodingInvalid sigPka err)+ Left BadPrefix ->+ verificationError (SignatureEncodingInvalidBadPrefix sigPka)+ Left (BadLength label expected actual) ->+ verificationError+ (SignatureEncodingInvalidLength sigPka label expected actual) Right rawPub -> case cf2es (Ed448.publicKey rawPub) of Left err ->- verificationError (SignatureEncodingInvalid sigPka err)+ verificationError (SignatureEncodingInvalidCrypto sigPka err) Right ep -> case cf2es ( Ed448.signature (padN 57 (i2osp (unMPI r)) <> padN 57 (i2osp (unMPI s))) ) of Left err ->- verificationError (SignatureEncodingInvalid sigPka err)+ verificationError (SignatureEncodingInvalidCrypto sigPka err) Right es -> let prehash = crazyHash hd bs :: B.ByteString in if Ed448.verify ep prehash es@@ -1408,21 +1265,11 @@ prefixed <- exactLengthPublic (expectedLen + 1) "prefixed-native" (i2osp x) if B.head prefixed /= 0x40- then- Left- "prefixed-native EdDSA public key is missing the 0x40 prefix"+ then Left BadPrefix else Right (B.tail prefixed) exactLengthPublic expectedLen label bs | B.length bs == expectedLen = Right bs- | otherwise =- Left- ( "invalid "- ++ label- ++ " EdDSA public key length: expected "- ++ show expectedLen- ++ " octets, got "- ++ show (B.length bs)- )+ | otherwise = Left (BadLength label expectedLen (B.length bs)) pad32 bs = let l = B.length bs in if l >= 32@@ -1433,7 +1280,7 @@ in if l >= n then bs else B.replicate (n - l) 0 <> bs- cf2es = either (Left . show) return . eitherCryptoError+ cf2es = eitherCryptoError rsaVerify pub mpis hd pkey bs = if P15.verify (Just hd) pkey bs (rsaMPItoSig pkey mpis) then Right pub@@ -1506,8 +1353,18 @@ hashWithSHA512 :: B.ByteString -> B.ByteString hashWithSHA512 = BA.convert . hashWith CHA.SHA512 +{- | Internal outcome type shared by 'hashForSignatureAlgorithm' and+'left16FromHashPrefix', consumed by both the verification path (mapped to+'HashComputationUnsupportedAlgorithm'/'HashComputationOutputTooShort') and+the signing path (mapped to 'SignBackendErrorUnsupportedHash'/+'SignBackendErrorHashTooShort'), so neither ever needs a rendered 'String'.+-}+data Left16Error+ = Left16UnsupportedHashAlgorithm !HashAlgorithm+ | Left16HashTooShort+ hashForSignatureAlgorithm- :: HashAlgorithm -> B.ByteString -> Either String B.ByteString+ :: HashAlgorithm -> B.ByteString -> Either Left16Error B.ByteString hashForSignatureAlgorithm ha bs = case ha of SHA1 -> Right (BA.convert (hashWith CHA.SHA1 bs))@@ -1519,25 +1376,36 @@ SHA3_256 -> Right (BA.convert (hashWith CHA.SHA3_256 bs)) SHA3_512 -> Right (BA.convert (hashWith CHA.SHA3_512 bs)) DeprecatedMD5 -> Right (BA.convert (hashWith CHA.MD5 bs))- _ ->- Left- ("unsupported hash algorithm for left16 derivation: " ++ show ha)+ _ -> Left (Left16UnsupportedHashAlgorithm ha) -left16FromHashPrefix :: B.ByteString -> Either String Word16+left16FromHashPrefix :: B.ByteString -> Either Left16Error Word16 left16FromHashPrefix bs | B.length bs >= 2 = Right (fromIntegral (os2ip (B.take 2 bs)))- | otherwise = Left "hash output too short to derive left16"+ | otherwise = Left Left16HashTooShort left16FromSignedPayload- :: HashAlgorithm -> B.ByteString -> Either String Word16+ :: HashAlgorithm -> B.ByteString -> Either Left16Error Word16 left16FromSignedPayload ha signedPayload = do digest <- hashForSignatureAlgorithm ha signedPayload left16FromHashPrefix digest +left16ErrorToSignBackendError :: Left16Error -> SignError+left16ErrorToSignBackendError (Left16UnsupportedHashAlgorithm ha) =+ SignBackendErrorUnsupportedHash ha+left16ErrorToSignBackendError Left16HashTooShort =+ SignBackendErrorHashTooShort++left16ErrorToVerificationError+ :: Left16Error -> VerificationError+left16ErrorToVerificationError (Left16UnsupportedHashAlgorithm ha) =+ HashComputationUnsupportedAlgorithm ha+left16ErrorToVerificationError Left16HashTooShort =+ HashComputationOutputTooShort+ left16FromSignedPayloadForSign :: HashAlgorithm -> B.ByteString -> Either SignError Word16 left16FromSignedPayloadForSign ha =- first SignBackendError . left16FromSignedPayload ha+ first left16ErrorToSignBackendError . left16FromSignedPayload ha ed25519Signer :: Ed25519.SecretKey -> B.ByteString -> B.ByteString@@ -1575,31 +1443,26 @@ case ha of SHA1 -> first- (SignBackendError . show)+ SignBackendErrorRSA (P15.sign Nothing (Just CHA.SHA1) prv bytes) SHA224 -> first- (SignBackendError . show)+ SignBackendErrorRSA (P15.sign Nothing (Just CHA.SHA224) prv bytes) SHA256 -> first- (SignBackendError . show)+ SignBackendErrorRSA (P15.sign Nothing (Just CHA.SHA256) prv bytes) SHA384 -> first- (SignBackendError . show)+ SignBackendErrorRSA (P15.sign Nothing (Just CHA.SHA384) prv bytes) SHA512 -> first- (SignBackendError . show)+ SignBackendErrorRSA (P15.sign Nothing (Just CHA.SHA512) prv bytes) _ ->- Left- ( SignBackendError- ( "signature hash algorithm is not supported by RSA PKCS#1 v1.5 backend: "- ++ show ha- )- )+ Left (SignBackendErrorUnsupportedHash ha) validateV6SaltSize :: HashAlgorithm -> SignatureSalt -> Either SignError ()@@ -1608,12 +1471,7 @@ actualSaltLen = B.length saltBytes in case signatureV6SaltSizeForHashAlgorithm ha of Nothing ->- Left- ( SignBackendError- ( "signature hash algorithm does not define a V6 salt size: "- ++ show ha- )- )+ Left (SignBackendErrorNoV6SaltSize ha) Just expectedSaltLen -> if actualSaltLen == fromIntegral expectedSaltLen then Right ()@@ -1667,7 +1525,9 @@ left16 (NE.fromList [MPI (os2ip r), MPI (os2ip s)]) )- <$> first SignBackendError (left16FromHashPrefix prehash)+ <$> first+ left16ErrorToSignBackendError+ (left16FromHashPrefix prehash) signEdDSAV6 :: String@@ -1709,7 +1569,9 @@ left16 (NE.fromList [MPI (os2ip r), MPI (os2ip s)]) )- <$> first SignBackendError (left16FromHashPrefix prehash)+ <$> first+ left16ErrorToSignBackendError+ (left16FromHashPrefix prehash) signUserId :: (MonadRandom m, SignablePrivateKey key, SignablePrivateKeyV6 key)
Codec/Encryption/OpenPGP/Signing.hs view
@@ -23,18 +23,10 @@ ( -- * SigningT transformer SigningT , runSigningT- , SigningError (..)- , renderSigningError -- * Signing target selection , SigningTarget (..) , AvailableSigner (..)- , asKeyId- , asFingerprint- , asKeyPacket- , asSKey- , asIsPrimary- , asUsage , listAvailableSigners , filterSigningCapable , filterByKeyId@@ -70,7 +62,7 @@ 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 Crypto.Random.Types (MonadRandom) import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL@@ -87,63 +79,23 @@ ( signatureHashedSubpacketsKnown ) import Codec.Encryption.OpenPGP.Signatures- ( SignError (..)- , payloadForCertRevocation+ ( payloadForCertRevocation , payloadForDirectKey- , payloadForPrimaryKeyBinding , payloadForSubkeyBinding , payloadForSubkeyRevocation , payloadForUat , payloadForUserId , randomSignatureSalt- , renderSignError- , signCertRevocation , signDataWithEd25519 , signDataWithEd25519V6 , signDataWithEd448 , signDataWithEd448V6 , signDataWithRSA , signDataWithRSAV6- , signDirectKey- , signSubkeyBinding- , signSubkeyRevocation )-import qualified Codec.Encryption.OpenPGP.Signatures as S-import Codec.Encryption.OpenPGP.Subpackets- ( TextNormalizationMode (..)- ) import Codec.Encryption.OpenPGP.Types import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA-import Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes- ( RSA_PrivateKey (..)- )-import Codec.Encryption.OpenPGP.Types.Internal.TK- ( TK (..)- , TKKind (..)- , _tkPrimaryKey- , _tkSubs- ) --- | Signing-specific errors.-data SigningError- = SigningSignError !SignError- | SigningNoSignersAvailable- | SigningInvalidTarget !ByteString- | SigningKeyNotSigningCapable !ByteString- | SigningKeyExpired !ByteString- | SigningKeyNotYetValid !ByteString- | SigningSKeyInitFailed !String- deriving (Eq, Show)--renderSigningError :: SigningError -> String-renderSigningError (SigningSignError e) = renderSignError e-renderSigningError SigningNoSignersAvailable = "no signing-capable keys available"-renderSigningError (SigningInvalidTarget kid) = "invalid signing target: " ++ show kid-renderSigningError (SigningKeyNotSigningCapable kid) = "key is not signing-capable: " ++ show kid-renderSigningError (SigningKeyExpired kid) = "key has expired: " ++ show kid-renderSigningError (SigningKeyNotYetValid kid) = "key is not yet valid: " ++ show kid-renderSigningError (SigningSKeyInitFailed msg) = "failed to initialize secret key: " ++ msg- -- | The signing monad transformer. newtype SigningT (tk :: TKKind) m a = SigningT { unSigningT@@ -210,7 +162,7 @@ (map sigFlags (_tkDirectKeySigs tk ++ _tkRevs tk)) primary = AvailableSigner- { asKeyId = either error id (eightOctetKeyID primaryPkp)+ { asKeyId = either (error . show) id (eightOctetKeyID primaryPkp) , asFingerprint = fingerprint primaryPkp , asKeyPacket = primaryKp , asSKey = case primarySka of@@ -227,7 +179,7 @@ guard (isSigningCapable subUsage) pure AvailableSigner- { asKeyId = either error id (eightOctetKeyID subPkp)+ { asKeyId = either (error . show) id (eightOctetKeyID subPkp) , asFingerprint = fingerprint subPkp , asKeyPacket = subKp , asSKey = case subSka of@@ -301,7 +253,7 @@ signEd448V4 ts kp bs payload _ -> pure $- Left (SignBackendError "unsupported signing key type for V4")+ Left (SignBackendErrorUnsupportedKeyTypeV4 pka) goV6 pka = case (pka, ska) of (RSA, RSAPrivateKey rsaPriv) -> signRSA ts kp (unRSA_PrivateKey rsaPriv) payload (Ed25519, EdDSAPrivateKey EdSigningCurve25519 bs) ->@@ -314,7 +266,7 @@ signEd448V6 ts kp bs payload _ -> pure $- Left (SignBackendError "unsupported signing key type for V6")+ Left (SignBackendErrorUnsupportedKeyTypeV6 pka) signRSA :: MonadRandom m@@ -346,7 +298,7 @@ -> m (Either SignError SignaturePayload) signEd25519V4 ts kp bs payload = case eitherCryptoError (Ed25519.secretKey bs) of- Left err -> pure $ Left (SignBackendError (show err))+ Left err -> pure $ Left (SignBackendErrorCrypto err) Right sk -> let ha = SHA512 hashed = [SigSubPacket True (SigCreationTime ts)]@@ -364,7 +316,7 @@ let ha = SHA512 salt <- randomSignatureSalt ha case eitherCryptoError (Ed25519.secretKey bs) of- Left err -> pure $ Left (SignBackendError (show err))+ Left err -> pure $ Left (SignBackendErrorCrypto err) Right sk -> let hashed = [SigSubPacket True (SigCreationTime ts)] unhashed = []@@ -380,7 +332,7 @@ -> m (Either SignError SignaturePayload) signEd448V4 ts kp bs payload = case eitherCryptoError (Ed448.secretKey bs) of- Left err -> pure $ Left (SignBackendError (show err))+ Left err -> pure $ Left (SignBackendErrorCrypto err) Right sk -> let ha = SHA512 hashed = [SigSubPacket True (SigCreationTime ts)]@@ -398,7 +350,7 @@ let ha = SHA512 salt <- randomSignatureSalt ha case eitherCryptoError (Ed448.secretKey bs) of- Left err -> pure $ Left (SignBackendError (show err))+ Left err -> pure $ Left (SignBackendErrorCrypto err) Right sk -> let hashed = [SigSubPacket True (SigCreationTime ts)] unhashed = []
Codec/Encryption/OpenPGP/Types.hs view
@@ -9,6 +9,7 @@ import Codec.Encryption.OpenPGP.Types.Internal.Base as X import Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes as X+import Codec.Encryption.OpenPGP.Types.Internal.Errors as X import Codec.Encryption.OpenPGP.Types.Internal.PKITypes as X import Codec.Encryption.OpenPGP.Types.Internal.PacketClass as X import Codec.Encryption.OpenPGP.Types.Internal.Pkt as X
Codec/Encryption/OpenPGP/Types/Internal/Base.hs view
@@ -63,6 +63,7 @@ , _SigVOther , Fingerprint (..) , SessionKey (..)+ , EncryptedSessionKey (..) , SigType (..) , SignatureSalt (..) , Salt (..)@@ -1845,8 +1846,17 @@ = DeprecatedV3 | V4 | V6- deriving (Data, Eq, Generic, Ord, Show, Typeable)+ deriving (Bounded, Data, Eq, Generic, Ord, Show, Typeable) +instance Enum KeyVersion where+ toEnum 3 = DeprecatedV3+ toEnum 4 = V4+ toEnum 6 = V6+ toEnum _ = error "invalid KeyVersion"+ fromEnum DeprecatedV3 = 3+ fromEnum V4 = 4+ fromEnum V6 = 6+ instance Hashable KeyVersion instance Pretty KeyVersion where@@ -1938,6 +1948,12 @@ instance Ord SessionKey where compare (SessionKey b1) (SessionKey b2) = compare b1 b2++newtype EncryptedSessionKey+ = EncryptedSessionKey+ { unEncryptedSessionKey :: B.ByteString+ }+ deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) newtype Salt = Salt
Codec/Encryption/OpenPGP/Types/Internal/CryptonNewtypes.hs view
@@ -2,14 +2,11 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes where -import GHC.Generics (Generic)- import Control.Monad (mzero) import qualified Crypto.PubKey.DSA as DSA import qualified Crypto.PubKey.ECC.ECDSA as ECDSA@@ -17,222 +14,239 @@ import qualified Crypto.PubKey.RSA as RSA import qualified Data.Aeson as A import Data.Data (Data)-import Data.Hashable (Hashable(..))+import Data.Hashable (Hashable (..)) import Data.Typeable (Typeable)-import Prettyprinter (Pretty(..), (<+>), tupled)+import GHC.Generics (Generic)+import Prettyprinter (Pretty (..), tupled, (<+>)) -newtype DSA_PublicKey =- DSA_PublicKey+newtype DSA_PublicKey+ = DSA_PublicKey { unDSA_PublicKey :: DSA.PublicKey }- deriving (Data, Eq, Generic, Show, Typeable)+ deriving (Data, Eq, Generic, Show, Typeable) instance Ord DSA_PublicKey where- compare (DSA_PublicKey (DSA.PublicKey p1 y1)) (DSA_PublicKey (DSA.PublicKey p2 y2)) =- compare (DSA_Params p1) (DSA_Params p2) <> compare y1 y2+ compare (DSA_PublicKey (DSA.PublicKey p1 y1)) (DSA_PublicKey (DSA.PublicKey p2 y2)) =+ compare (DSA_Params p1) (DSA_Params p2) <> compare y1 y2 instance A.ToJSON DSA_PublicKey where- toJSON (DSA_PublicKey (DSA.PublicKey p y)) = A.toJSON (DSA_Params p, y)+ toJSON (DSA_PublicKey (DSA.PublicKey p y)) = A.toJSON (DSA_Params p, y) instance Pretty DSA_PublicKey where- pretty (DSA_PublicKey (DSA.PublicKey p y)) =- pretty (DSA_Params p) <+> pretty y+ pretty (DSA_PublicKey (DSA.PublicKey p y)) =+ pretty (DSA_Params p) <+> pretty y -newtype RSA_PublicKey =- RSA_PublicKey+newtype RSA_PublicKey+ = RSA_PublicKey { unRSA_PublicKey :: RSA.PublicKey }- deriving (Data, Eq, Generic, Show, Typeable)+ deriving (Data, Eq, Generic, Show, Typeable) instance Ord RSA_PublicKey where- compare (RSA_PublicKey (RSA.PublicKey size1 n1 e1)) (RSA_PublicKey (RSA.PublicKey size2 n2 e2)) =- compare size1 size2 <> compare n1 n2 <> compare e1 e2+ compare (RSA_PublicKey (RSA.PublicKey size1 n1 e1)) (RSA_PublicKey (RSA.PublicKey size2 n2 e2)) =+ compare size1 size2 <> compare n1 n2 <> compare e1 e2 instance A.ToJSON RSA_PublicKey where- toJSON (RSA_PublicKey (RSA.PublicKey size n e)) = A.toJSON (size, n, e)+ toJSON (RSA_PublicKey (RSA.PublicKey size n e)) = A.toJSON (size, n, e) instance Pretty RSA_PublicKey where- pretty (RSA_PublicKey (RSA.PublicKey size n e)) =- pretty size <+> pretty n <+> pretty e+ pretty (RSA_PublicKey (RSA.PublicKey size n e)) =+ pretty size <+> pretty n <+> pretty e -newtype ECDSA_PublicKey =- ECDSA_PublicKey+newtype ECDSA_PublicKey+ = ECDSA_PublicKey { unECDSA_PublicKey :: ECDSA.PublicKey }- deriving (Data, Eq, Generic, Show, Typeable)+ deriving (Data, Eq, Generic, Show, Typeable) instance Ord ECDSA_PublicKey where- compare (ECDSA_PublicKey (ECDSA.PublicKey curve1 q1)) (ECDSA_PublicKey (ECDSA.PublicKey curve2 q2)) =- compareCurve curve1 curve2 <> compareECPoint q1 q2+ compare (ECDSA_PublicKey (ECDSA.PublicKey curve1 q1)) (ECDSA_PublicKey (ECDSA.PublicKey curve2 q2)) =+ compareCurve curve1 curve2 <> compareECPoint q1 q2 instance A.ToJSON ECDSA_PublicKey where- toJSON (ECDSA_PublicKey (ECDSA.PublicKey curve q)) =- A.toJSON (show curve, show q)+ toJSON (ECDSA_PublicKey (ECDSA.PublicKey curve q)) =+ A.toJSON (show curve, show q) instance Pretty ECDSA_PublicKey where- pretty (ECDSA_PublicKey (ECDSA.PublicKey curve q)) =- pretty (show curve, show q)+ pretty (ECDSA_PublicKey (ECDSA.PublicKey curve q)) =+ pretty (show curve, show q) -newtype DSA_PrivateKey =- DSA_PrivateKey+newtype DSA_PrivateKey+ = DSA_PrivateKey { unDSA_PrivateKey :: DSA.PrivateKey }- deriving (Data, Eq, Generic, Show, Typeable)+ deriving (Data, Eq, Generic, Show, Typeable) instance Ord DSA_PrivateKey where- compare (DSA_PrivateKey (DSA.PrivateKey p1 x1)) (DSA_PrivateKey (DSA.PrivateKey p2 x2)) =- compare (DSA_Params p1) (DSA_Params p2) <> compare x1 x2+ compare (DSA_PrivateKey (DSA.PrivateKey p1 x1)) (DSA_PrivateKey (DSA.PrivateKey p2 x2)) =+ compare (DSA_Params p1) (DSA_Params p2) <> compare x1 x2 instance A.ToJSON DSA_PrivateKey where- toJSON (DSA_PrivateKey (DSA.PrivateKey p x)) = A.toJSON (DSA_Params p, x)+ toJSON (DSA_PrivateKey (DSA.PrivateKey p x)) = A.toJSON (DSA_Params p, x) instance Pretty DSA_PrivateKey where- pretty (DSA_PrivateKey (DSA.PrivateKey p x)) = pretty (DSA_Params p, x)+ pretty (DSA_PrivateKey (DSA.PrivateKey p x)) = pretty (DSA_Params p, x) -newtype RSA_PrivateKey =- RSA_PrivateKey+newtype RSA_PrivateKey+ = RSA_PrivateKey { unRSA_PrivateKey :: RSA.PrivateKey }- deriving (Data, Eq, Generic, Show, Typeable)+ deriving (Data, Eq, Generic, Show, Typeable) instance Ord RSA_PrivateKey where- compare (RSA_PrivateKey (RSA.PrivateKey pub1 d1 p1 q1 dP1 dQ1 qinv1))- (RSA_PrivateKey (RSA.PrivateKey pub2 d2 p2 q2 dP2 dQ2 qinv2)) =- compare (RSA_PublicKey pub1) (RSA_PublicKey pub2) <>- compare d1 d2 <> compare p1 p2 <> compare q1 q2 <>- compare dP1 dP2 <> compare dQ1 dQ2 <> compare qinv1 qinv2+ compare+ (RSA_PrivateKey (RSA.PrivateKey pub1 d1 p1 q1 dP1 dQ1 qinv1))+ (RSA_PrivateKey (RSA.PrivateKey pub2 d2 p2 q2 dP2 dQ2 qinv2)) =+ compare (RSA_PublicKey pub1) (RSA_PublicKey pub2)+ <> compare d1 d2+ <> compare p1 p2+ <> compare q1 q2+ <> compare dP1 dP2+ <> compare dQ1 dQ2+ <> compare qinv1 qinv2 instance A.ToJSON RSA_PrivateKey where- toJSON (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) =- A.toJSON (RSA_PublicKey pub, d, p, q, dP, dQ, qinv)+ toJSON (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) =+ A.toJSON (RSA_PublicKey pub, d, p, q, dP, dQ, qinv) instance Pretty RSA_PrivateKey where- pretty (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) =- pretty (RSA_PublicKey pub) <+> tupled (map pretty [d, p, q, dP, dQ, qinv])+ pretty (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) =+ pretty (RSA_PublicKey pub)+ <+> tupled (map pretty [d, p, q, dP, dQ, qinv]) -newtype ECDSA_PrivateKey =- ECDSA_PrivateKey+newtype ECDSA_PrivateKey+ = ECDSA_PrivateKey { unECDSA_PrivateKey :: ECDSA.PrivateKey }- deriving (Data, Eq, Generic, Show, Typeable)+ deriving (Data, Eq, Generic, Show, Typeable) instance Ord ECDSA_PrivateKey where- compare (ECDSA_PrivateKey (ECDSA.PrivateKey curve1 d1)) (ECDSA_PrivateKey (ECDSA.PrivateKey curve2 d2)) =- compareCurve curve1 curve2 <> compare d1 d2+ compare (ECDSA_PrivateKey (ECDSA.PrivateKey curve1 d1)) (ECDSA_PrivateKey (ECDSA.PrivateKey curve2 d2)) =+ compareCurve curve1 curve2 <> compare d1 d2 instance A.ToJSON ECDSA_PrivateKey where- toJSON (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) =- A.toJSON (show curve, show d)+ toJSON (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) =+ A.toJSON (show curve, show d) instance Pretty ECDSA_PrivateKey where- pretty (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) =- pretty (show curve, show d)+ pretty (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) =+ pretty (show curve, show d) -newtype DSA_Params =- DSA_Params+newtype DSA_Params+ = DSA_Params { unDSA_Params :: DSA.Params }- deriving (Data, Eq, Generic, Show, Typeable)+ deriving (Data, Eq, Generic, Show, Typeable) instance Ord DSA_Params where- compare (DSA_Params (DSA.Params p1 g1 q1)) (DSA_Params (DSA.Params p2 g2 q2)) =- compare p1 p2 <> compare g1 g2 <> compare q1 q2+ compare (DSA_Params (DSA.Params p1 g1 q1)) (DSA_Params (DSA.Params p2 g2 q2)) =+ compare p1 p2 <> compare g1 g2 <> compare q1 q2 instance A.ToJSON DSA_Params where- toJSON (DSA_Params (DSA.Params p g q)) = A.toJSON (p, g, q)+ toJSON (DSA_Params (DSA.Params p g q)) = A.toJSON (p, g, q) instance Pretty DSA_Params where- pretty (DSA_Params (DSA.Params p g q)) = pretty (p, g, q)+ pretty (DSA_Params (DSA.Params p g q)) = pretty (p, g, q) instance Hashable DSA_Params where- hashWithSalt s (DSA_Params (DSA.Params p g q)) =- s `hashWithSalt` p `hashWithSalt` g `hashWithSalt` q+ hashWithSalt s (DSA_Params (DSA.Params p g q)) =+ s `hashWithSalt` p `hashWithSalt` g `hashWithSalt` q instance Hashable DSA_PublicKey where- hashWithSalt s (DSA_PublicKey (DSA.PublicKey p y)) =- s `hashWithSalt` DSA_Params p `hashWithSalt` y+ hashWithSalt s (DSA_PublicKey (DSA.PublicKey p y)) =+ s `hashWithSalt` DSA_Params p `hashWithSalt` y instance Hashable DSA_PrivateKey where- hashWithSalt s (DSA_PrivateKey (DSA.PrivateKey p x)) =- s `hashWithSalt` DSA_Params p `hashWithSalt` x+ hashWithSalt s (DSA_PrivateKey (DSA.PrivateKey p x)) =+ s `hashWithSalt` DSA_Params p `hashWithSalt` x instance Hashable RSA_PublicKey where- hashWithSalt s (RSA_PublicKey (RSA.PublicKey size n e)) =- s `hashWithSalt` size `hashWithSalt` n `hashWithSalt` e+ hashWithSalt s (RSA_PublicKey (RSA.PublicKey size n e)) =+ s `hashWithSalt` size `hashWithSalt` n `hashWithSalt` e instance Hashable RSA_PrivateKey where- hashWithSalt s (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) =- s `hashWithSalt` RSA_PublicKey pub `hashWithSalt` d `hashWithSalt` p `hashWithSalt`- q `hashWithSalt`- dP `hashWithSalt`- dQ `hashWithSalt`- qinv+ hashWithSalt s (RSA_PrivateKey (RSA.PrivateKey pub d p q dP dQ qinv)) =+ s+ `hashWithSalt` RSA_PublicKey pub+ `hashWithSalt` d+ `hashWithSalt` p+ `hashWithSalt` q+ `hashWithSalt` dP+ `hashWithSalt` dQ+ `hashWithSalt` qinv instance Hashable ECDSA_PublicKey where- hashWithSalt s (ECDSA_PublicKey (ECDSA.PublicKey curve q)) =- hashWithCurve s curve `hashWithECPoint` q+ hashWithSalt s (ECDSA_PublicKey (ECDSA.PublicKey curve q)) =+ hashWithCurve s curve `hashWithECPoint` q instance Hashable ECDSA_PrivateKey where- hashWithSalt s (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) =- hashWithCurve s curve `hashWithSalt` d+ hashWithSalt s (ECDSA_PrivateKey (ECDSA.PrivateKey curve d)) =+ hashWithCurve s curve `hashWithSalt` d -- Structural helpers for ECCT types that lack Hashable/Ord instances. hashWithECPoint :: Int -> ECCT.Point -> Int-hashWithECPoint s ECCT.PointO = s `hashWithSalt` (0 :: Int)-hashWithECPoint s (ECCT.Point x y) = s `hashWithSalt` (1 :: Int) `hashWithSalt` x `hashWithSalt` y+hashWithECPoint s ECCT.PointO = s `hashWithSalt` (0 :: Int)+hashWithECPoint s (ECCT.Point x y) =+ s `hashWithSalt` (1 :: Int) `hashWithSalt` x `hashWithSalt` y hashWithCurveCommon :: Int -> ECCT.CurveCommon -> Int hashWithCurveCommon s cc =- hashWithECPoint- (s `hashWithSalt` ECCT.ecc_a cc `hashWithSalt` ECCT.ecc_b cc)- (ECCT.ecc_g cc)- `hashWithSalt` ECCT.ecc_n cc `hashWithSalt` ECCT.ecc_h cc+ hashWithECPoint+ (s `hashWithSalt` ECCT.ecc_a cc `hashWithSalt` ECCT.ecc_b cc)+ (ECCT.ecc_g cc)+ `hashWithSalt` ECCT.ecc_n cc+ `hashWithSalt` ECCT.ecc_h cc hashWithCurve :: Int -> ECCT.Curve -> Int-hashWithCurve s (ECCT.CurveFP (ECCT.CurvePrime p cc)) =- hashWithCurveCommon (s `hashWithSalt` (0 :: Int) `hashWithSalt` p) cc+hashWithCurve s (ECCT.CurveFP (ECCT.CurvePrime p cc)) =+ hashWithCurveCommon+ (s `hashWithSalt` (0 :: Int) `hashWithSalt` p)+ cc hashWithCurve s (ECCT.CurveF2m (ECCT.CurveBinary poly cc)) =- hashWithCurveCommon (s `hashWithSalt` (1 :: Int) `hashWithSalt` poly) cc+ hashWithCurveCommon+ (s `hashWithSalt` (1 :: Int) `hashWithSalt` poly)+ cc compareECPoint :: ECCT.Point -> ECCT.Point -> Ordering-compareECPoint ECCT.PointO ECCT.PointO = EQ-compareECPoint ECCT.PointO _ = LT-compareECPoint _ ECCT.PointO = GT+compareECPoint ECCT.PointO ECCT.PointO = EQ+compareECPoint ECCT.PointO _ = LT+compareECPoint _ ECCT.PointO = GT compareECPoint (ECCT.Point x1 y1) (ECCT.Point x2 y2) =- compare x1 x2 <> compare y1 y2+ compare x1 x2 <> compare y1 y2 -compareCurveCommon :: ECCT.CurveCommon -> ECCT.CurveCommon -> Ordering+compareCurveCommon+ :: ECCT.CurveCommon -> ECCT.CurveCommon -> Ordering compareCurveCommon cc1 cc2 =- compare (ECCT.ecc_a cc1) (ECCT.ecc_a cc2) <>- compare (ECCT.ecc_b cc1) (ECCT.ecc_b cc2) <>- compareECPoint (ECCT.ecc_g cc1) (ECCT.ecc_g cc2) <>- compare (ECCT.ecc_n cc1) (ECCT.ecc_n cc2) <>- compare (ECCT.ecc_h cc1) (ECCT.ecc_h cc2)+ compare (ECCT.ecc_a cc1) (ECCT.ecc_a cc2)+ <> compare (ECCT.ecc_b cc1) (ECCT.ecc_b cc2)+ <> compareECPoint (ECCT.ecc_g cc1) (ECCT.ecc_g cc2)+ <> compare (ECCT.ecc_n cc1) (ECCT.ecc_n cc2)+ <> compare (ECCT.ecc_h cc1) (ECCT.ecc_h cc2) compareCurve :: ECCT.Curve -> ECCT.Curve -> Ordering-compareCurve (ECCT.CurveFP (ECCT.CurvePrime p1 cc1)) (ECCT.CurveFP (ECCT.CurvePrime p2 cc2)) =- compare p1 p2 <> compareCurveCommon cc1 cc2+compareCurve (ECCT.CurveFP (ECCT.CurvePrime p1 cc1)) (ECCT.CurveFP (ECCT.CurvePrime p2 cc2)) =+ compare p1 p2 <> compareCurveCommon cc1 cc2 compareCurve (ECCT.CurveF2m (ECCT.CurveBinary poly1 cc1)) (ECCT.CurveF2m (ECCT.CurveBinary poly2 cc2)) =- compare poly1 poly2 <> compareCurveCommon cc1 cc2-compareCurve (ECCT.CurveFP _) (ECCT.CurveF2m _) = LT-compareCurve (ECCT.CurveF2m _) (ECCT.CurveFP _) = GT+ compare poly1 poly2 <> compareCurveCommon cc1 cc2+compareCurve (ECCT.CurveFP _) (ECCT.CurveF2m _) = LT+compareCurve (ECCT.CurveF2m _) (ECCT.CurveFP _) = GT -newtype ECurvePoint =- ECurvePoint+newtype ECurvePoint+ = ECurvePoint { unECurvepoint :: ECCT.Point }- deriving (Data, Eq, Generic, Show, Typeable)+ deriving (Data, Eq, Generic, Show, Typeable) instance A.ToJSON ECurvePoint where- toJSON (ECurvePoint (ECCT.Point x y)) = A.toJSON (x, y)- toJSON (ECurvePoint ECCT.PointO) = A.toJSON "point at infinity"+ toJSON (ECurvePoint (ECCT.Point x y)) = A.toJSON (x, y)+ toJSON (ECurvePoint ECCT.PointO) = A.toJSON "point at infinity" instance A.FromJSON ECurvePoint where- parseJSON v =- case A.fromJSON v :: A.Result (Integer, Integer) of- A.Success (x, y) -> pure (ECurvePoint (ECCT.Point x y))- A.Error _ ->- case A.fromJSON v :: A.Result String of- A.Success "point at infinity" -> pure (ECurvePoint ECCT.PointO)- _ -> mzero+ parseJSON v =+ case A.fromJSON v :: A.Result (Integer, Integer) of+ A.Success (x, y) -> pure (ECurvePoint (ECCT.Point x y))+ A.Error _ ->+ case A.fromJSON v :: A.Result String of+ A.Success "point at infinity" -> pure (ECurvePoint ECCT.PointO)+ _ -> mzero
+ Codec/Encryption/OpenPGP/Types/Internal/Errors.hs view
@@ -0,0 +1,1332 @@+-- Errors.hs: centralized error types for hOpenPGP+-- 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 #-}++module Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( -- * Low-level cryptographic errors+ CipherError (..)+ , renderCipherError+ , EncodedSessionKeyError (..)+ , renderEncodedSessionKeyError+ , MDCFailure (..)+ , renderMDCFailure+ , CurveConversionError (..)+ , renderCurveConversionError+ , ECPointError (..)+ , renderECPointError+ , X25519OctetError (..)+ , renderX25519OctetError+ , ECDHOctetError (..)+ , renderECDHOctetError+ , KeyPktCoercionError (..)+ , renderKeyPktCoercionError+ , PacketCoercionError (..)+ , KeyringChunkParseError (..)+ , renderChunkParseError+ , KeyIdError (..)+ , renderKeyIdError+ , KeyInfoError (..)+ , KeySelectionError (..)+ , TKConversionError (..)+ , renderTKConversionError++ -- * Mid-level errors+ , S2KError (..)+ , renderS2KError+ , SecretKeyError (..)+ , renderSecretKeyError+ , SigningError (..)+ , renderSigningError+ , SignError (..)+ , renderSignError+ , VerificationError (..)+ , CriticalPacketError (..)+ , renderCriticalPacketError+ , renderVerificationError+ , OPSBuildError (..)+ , renderOPSBuildError+ , RecipientCapabilityError (..)+ , renderRecipientCapabilityError+ , PKESKEncryptError (..)+ , renderPKESKEncryptError+ , CompressionError (..)+ , renderCompressionError+ , PktParseErrorReason (..)+ , renderPktParseReason+ , PktValidationError (..)+ , renderPktValidationError+ , SKeyError (..)+ , renderSKeyError+ , PktParseError (..)+ , renderPktParseError+ , SerializeError (..)+ , renderSerializeError++ -- * AEAD / SEIPDv2 unified auth failures+ , AEADAuthFailure (..)+ , renderAEADAuthFailure+ , SEIPDv2Failure (..)+ , renderSEIPDv2Failure++ -- * Message-level errors+ , MessageParseFailure (..)+ , renderMessageParseFailure+ , MessageDecryptFailure (..)+ , renderMessageDecryptFailure+ , MessageEncryptFailure (..)+ , renderMessageEncryptFailure+ , PayloadDecryptFailure (..)+ , renderPayloadDecryptFailure++ -- * Decrypt-level errors+ , DecryptStructureError (..)+ , renderDecryptStructureError+ , DecryptOutcome (..)+ , renderDecryptOutcome+ , DecryptSessionKeyResolutionReport (..)+ , renderDecryptSessionKeyResolutionReport+ , DecryptReport (..)+ , renderDecryptReport+ , SKESKSessionKeyResolutionError (..)+ , renderSKESKSessionKeyResolutionError+ , PKESKX25519V3UnwrapError (..)+ , renderPKESKX25519V3UnwrapError+ , PKESKAttemptFailureKind (..)+ , PKESKAttemptFailure (..)+ , PKESKResolverAttemptAction (..)+ , PKESKResolverAttempt (..)+ , DecryptSessionKeyResolutionPath (..)++ -- * Top-level message error+ , MessageError (..)+ , renderMessageError+ ) where++import qualified Crypto.Error as CE+import qualified Crypto.PubKey.RSA.Types as RSA+import Data.ByteString (ByteString)+import Data.Containers.ListUtils (nubOrd)+import Data.Int (Int64)+import Data.List (intercalate)+import qualified Data.Set as Set+import Data.Text (Text)+import Data.Word (Word8)++import Codec.Encryption.OpenPGP.Types.Internal.Base+ ( AEADAlgorithm (..)+ , CompressionAlgorithm (..)+ , EightOctetKeyId (..)+ , Fingerprint (..)+ , HashAlgorithm (..)+ , KeyFlag (..)+ , KeyVersion (..)+ , PubKeyAlgorithm (..)+ , SigType (..)+ , SymmetricAlgorithm (..)+ )+import Codec.Encryption.OpenPGP.Types.Internal.PKITypes++-------------------------------------------------------------------------------+-- Low-level cryptographic errors+-------------------------------------------------------------------------------++-- | Errors that can arise from block-cipher operations in this library.+data CipherError+ = -- | The algorithm is not supported or not implemented.+ UnsupportedAlgorithm !SymmetricAlgorithm+ | -- | Cipher initialization failed (bad key material).+ CipherInitFailed !SymmetricAlgorithm !String+ | -- | A CFB or other block-cipher operation failed.+ CipherOperationFailed !String+ deriving (Eq, Show)++renderCipherError :: CipherError -> String+renderCipherError (UnsupportedAlgorithm sa) =+ "unsupported symmetric algorithm: " ++ show sa+renderCipherError (CipherInitFailed sa err) =+ "could not initialize cipher for " ++ show sa ++ ": " ++ err+renderCipherError (CipherOperationFailed err) = err++-------------------------------------------------------------------------------++data EncodedSessionKeyError+ = EncodedSessionKeyTooShort+ | EncodedSessionKeyUnsupportedAlgorithm !SymmetricAlgorithm+ | EncodedSessionKeyLengthMismatch !SymmetricAlgorithm !Int !Int+ | EncodedSessionKeyChecksumMismatch+ deriving (Eq, Show)++renderEncodedSessionKeyError :: EncodedSessionKeyError -> String+renderEncodedSessionKeyError EncodedSessionKeyTooShort =+ "encoded session key is too short"+renderEncodedSessionKeyError (EncodedSessionKeyUnsupportedAlgorithm sa) =+ "unsupported algorithm in encoded session key: " ++ show sa+renderEncodedSessionKeyError (EncodedSessionKeyLengthMismatch sa expected actual) =+ "invalid session key length for "+ ++ show sa+ ++ ": expected "+ ++ show expected+ ++ ", got "+ ++ show actual+renderEncodedSessionKeyError EncodedSessionKeyChecksumMismatch =+ "encoded session key checksum mismatch"++-------------------------------------------------------------------------------++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"++-------------------------------------------------------------------------------++-- | EC point encoding errors+data ECPointError+ = ECPointErrorReasonEmpty+ | ECPointErrorReasonUnknownType+ { ecPointFirstOctet :: Word8+ }+ | ECPointErrorReasonOddCoordinateLength+ deriving (Eq, Show)++renderECPointError :: ECPointError -> String+renderECPointError ECPointErrorReasonEmpty = "empty EC point encoding"+renderECPointError (ECPointErrorReasonUnknownType firstOctet) =+ "unknown type of point: " ++ show firstOctet+renderECPointError ECPointErrorReasonOddCoordinateLength =+ "malformed EC point encoding: odd coordinate payload length"++-- | X25519 v3 octet layout errors+data X25519OctetError+ = X25519OctetErrorReasonTooShort+ | X25519OctetErrorReasonInconsistentESKLength+ | X25519OctetErrorReasonMissingSymmetricAlgorithm+ | X25519OctetErrorReasonUnsupportedSymmetricAlgorithm+ { x25519SymmetricAlgorithmOctet :: Word8+ }+ deriving (Eq, Show)++renderX25519OctetError :: X25519OctetError -> String+renderX25519OctetError X25519OctetErrorReasonTooShort =+ "X25519 v3 PKESK octet layout is too short"+renderX25519OctetError X25519OctetErrorReasonInconsistentESKLength =+ "X25519 v3 PKESK octet layout has inconsistent ESK length"+renderX25519OctetError X25519OctetErrorReasonMissingSymmetricAlgorithm =+ "X25519 v3 PKESK octet layout must include a symmetric algorithm octet"+renderX25519OctetError (X25519OctetErrorReasonUnsupportedSymmetricAlgorithm algo) =+ "X25519 v3 PKESK octet layout has unsupported symmetric algorithm octet "+ ++ show algo++-- | ECDH RFC6637 octet layout errors+data ECDHOctetError+ = ECDHOctetErrorReasonMissingWrappedKeyLength+ | ECDHOctetErrorReasonWrappedKeyLengthMismatch+ { ecdhDeclaredLength :: Int+ , ecdhActualLength :: Int+ }+ | ECDHOctetErrorReasonInvalidWrappedKeySize+ { ecdhWrappedKeySize :: Int+ }+ deriving (Eq, Show)++renderECDHOctetError :: ECDHOctetError -> String+renderECDHOctetError ECDHOctetErrorReasonMissingWrappedKeyLength =+ "ECDH v3 PKESK RFC6637 octet layout: missing wrapped-key length octet after ephemeral MPI"+renderECDHOctetError (ECDHOctetErrorReasonWrappedKeyLengthMismatch declared actual) =+ "ECDH v3 PKESK RFC6637 octet layout: wrapped key length field "+ ++ show declared+ ++ " does not match body length "+ ++ show actual+renderECDHOctetError (ECDHOctetErrorReasonInvalidWrappedKeySize sz) =+ "ECDH v3 PKESK RFC6637 octet layout: wrapped key length "+ ++ show sz+ ++ " is not a valid RFC 3394 wrapped key size"++-------------------------------------------------------------------------------++data KeyPktCoercionError pkt+ = NotAKeyPacket pkt+ | ExpectedPublicKeyPacket pkt+ | ExpectedSecretKeyPacket pkt+ deriving (Eq, Show)++renderKeyPktCoercionError+ :: Show pkt => KeyPktCoercionError pkt -> String+renderKeyPktCoercionError (NotAKeyPacket pkt) =+ "not a key packet: " ++ show pkt+renderKeyPktCoercionError (ExpectedPublicKeyPacket pkt) =+ "expected a public key packet, got: " ++ show pkt+renderKeyPktCoercionError (ExpectedSecretKeyPacket pkt) =+ "expected a secret key packet, got: " ++ show pkt++-------------------------------------------------------------------------------++data PacketCoercionError+ = PacketCoercionError+ { pceExpected :: !String+ , pceActualTag :: !Word8+ }+ deriving (Eq, Show)++-------------------------------------------------------------------------------++data KeyringChunkParseError+ = ChunkFailureBeforeInput !String+ | ChunkUnexpectedFinalizationFailure+ | ChunkParserFailure !String+ deriving (Eq, Show)++renderChunkParseError :: KeyringChunkParseError -> String+renderChunkParseError (ChunkFailureBeforeInput err) = err+renderChunkParseError ChunkUnexpectedFinalizationFailure =+ "unexpected finalization of keyring chunk"+renderChunkParseError (ChunkParserFailure err) = err++-------------------------------------------------------------------------------++data KeyIdError+ = KeyIdUnsupportedNonRSAV3+ | KeyIdFingerprintLengthMismatch !Int+ deriving (Eq, Show)++renderKeyIdError :: KeyIdError -> String+renderKeyIdError KeyIdUnsupportedNonRSAV3 =+ "unsupported non-RSA v3 public key algorithm for eight-octet key ID"+renderKeyIdError (KeyIdFingerprintLengthMismatch fpLen) =+ "cannot derive an eight-octet key ID from a "+ ++ show fpLen+ ++ "-octet fingerprint (expected 20)"++-------------------------------------------------------------------------------++data KeyInfoError+ = KeyInfoUnsupportedAlgorithm !PKey+ deriving (Eq, Show)++-------------------------------------------------------------------------------++data KeySelectionError+ = KeySelectionParseError !Text+ deriving (Eq, Show)++-------------------------------------------------------------------------------++data TKConversionError+ = PublicSubkeyHasPrimaryRole+ | SecretSubkeyHasPrimaryRole+ | ExpectedPublicSubkeyPacket !Word8+ | ExpectedSecretSubkeyPacket !Word8+ | ExpectedPublicPrimaryKeyPacket !Word8+ | ExpectedSecretPrimaryKeyPacket !Word8+ deriving (Eq, Show)++renderTKConversionError :: TKConversionError -> String+renderTKConversionError PublicSubkeyHasPrimaryRole =+ "expected subkey, got primary key"+renderTKConversionError SecretSubkeyHasPrimaryRole =+ "expected subkey, got primary key"+renderTKConversionError (ExpectedPublicSubkeyPacket tag) =+ "expected public subkey packet (tag " ++ show tag ++ ")"+renderTKConversionError (ExpectedSecretSubkeyPacket tag) =+ "expected secret subkey packet (tag " ++ show tag ++ ")"+renderTKConversionError (ExpectedPublicPrimaryKeyPacket tag) =+ "expected public primary key packet (tag " ++ show tag ++ ")"+renderTKConversionError (ExpectedSecretPrimaryKeyPacket tag) =+ "expected secret primary key packet (tag " ++ show tag ++ ")"++-------------------------------------------------------------------------------+-- Mid-level errors+-------------------------------------------------------------------------------++data S2KError+ = S2KUnsupportedAlgorithm !CipherError+ | S2KUnsupportedSpecifier !Word8+ | S2KUnsupportedHashAlgorithm !HashAlgorithm+ | S2KArgon2ParamError !String+ | S2KArgon2Failed !String+ | S2KEncryptedSessionKeyCipherError !CipherError+ | S2KEncryptedSessionKeyDecodeError !EncodedSessionKeyError+ deriving (Eq, Show)++renderS2KError :: S2KError -> String+renderS2KError (S2KUnsupportedAlgorithm err) = "S2K: " ++ renderCipherError err+renderS2KError (S2KUnsupportedSpecifier t) =+ "S2K: unsupported S2K type " ++ show t+renderS2KError (S2KUnsupportedHashAlgorithm ha) =+ "S2K: unsupported hash algorithm for S2K: " ++ show ha+renderS2KError (S2KArgon2ParamError msg) =+ "S2K: Argon2 parameter error: " ++ msg+renderS2KError (S2KArgon2Failed msg) =+ "S2K: Argon2 KDF failed: " ++ msg+renderS2KError (S2KEncryptedSessionKeyCipherError err) =+ "S2K: encrypted session key decrypt failed: "+ ++ renderCipherError err+renderS2KError (S2KEncryptedSessionKeyDecodeError err) =+ "S2K: encrypted session key decode failed: "+ ++ renderEncodedSessionKeyError err++-------------------------------------------------------------------------------++data SecretKeyError+ = SecretKeyDecryptNotUnencrypted+ | SecretKeyEncryptOptionsInconsistent+ | SecretKeyDecryptCipherError !CipherError+ | SecretKeyEncryptCipherError !CipherError+ | SecretKeyDecryptAddendumError !SKAddendumKeyVersionError+ | SecretKeyEncryptAddendumError !SKAddendumKeyVersionError+ | SecretKeyPolicyCipherError !CipherError+ | SecretKeyPolicySaltLengthMismatch !Int !Int+ | SecretKeyPolicyNonceLengthMismatch !Int !Int+ | SecretKeyUnsupportedLegacyProtection+ | SecretKeyDecodeError !String+ | SecretKeyChecksumError !String+ | SecretKeyAEADError !String+ | SecretKeyAuthError !String+ | SecretKeyInvalidS2KMode !S2KError+ | SecretKeyAEADModeCrypto !CE.CryptoError+ | SecretKeyAEADModeUnsupportedAlgo !AEADAlgorithm+ | SecretKeyAEADModeUnsupportedCipher !SymmetricAlgorithm+ | SecretKeyInvalidNonceSize !String+ | SecretKeyPayloadTooShort !String+ | SecretKeyTrailingBytes !String+ | SecretKeyRSAInverseError+ | SecretKeyEncodeError !SerializeError+ deriving (Eq, Show)++renderSecretKeyError :: SecretKeyError -> String+renderSecretKeyError SecretKeyDecryptNotUnencrypted =+ "decrypted secret key material was not in unencrypted form"+renderSecretKeyError SecretKeyEncryptOptionsInconsistent =+ "skeoGenerateSaltAndIV is False but skeoSalt or skeoIV are Nothing"+renderSecretKeyError (SecretKeyDecryptCipherError err) = renderCipherError err+renderSecretKeyError (SecretKeyEncryptCipherError err) = renderCipherError err+renderSecretKeyError (SecretKeyDecryptAddendumError err) =+ renderSKAddendumKeyVersionError err+renderSecretKeyError (SecretKeyEncryptAddendumError err) =+ renderSKAddendumKeyVersionError err+renderSecretKeyError (SecretKeyPolicyCipherError err) = renderCipherError err+renderSecretKeyError (SecretKeyPolicySaltLengthMismatch expected _actual) =+ "secret key S2K salt must be " ++ show expected ++ " octets"+renderSecretKeyError (SecretKeyPolicyNonceLengthMismatch expected _actual) =+ "v6 secret key AEAD nonce must be " ++ show expected ++ " octets"+renderSecretKeyError SecretKeyUnsupportedLegacyProtection =+ "unsupported legacy secret key protection"+renderSecretKeyError (SecretKeyDecodeError err) = err+renderSecretKeyError (SecretKeyChecksumError err) = err+renderSecretKeyError (SecretKeyAEADError err) = err+renderSecretKeyError (SecretKeyAuthError err) = err+renderSecretKeyError (SecretKeyInvalidS2KMode err) = renderS2KError err+renderSecretKeyError (SecretKeyAEADModeCrypto err) = show err+renderSecretKeyError (SecretKeyAEADModeUnsupportedAlgo aa) =+ "unsupported AEAD mode: " ++ show aa+renderSecretKeyError (SecretKeyAEADModeUnsupportedCipher sa) =+ "unsupported secret-key AEAD symmetric algorithm: " ++ show sa+renderSecretKeyError (SecretKeyInvalidNonceSize err) = err+renderSecretKeyError (SecretKeyPayloadTooShort err) = err+renderSecretKeyError (SecretKeyTrailingBytes err) = err+renderSecretKeyError SecretKeyRSAInverseError =+ "could not derive RSA multiplicative inverse while encrypting secret key"+renderSecretKeyError (SecretKeyEncodeError err) = renderSerializeError err++-------------------------------------------------------------------------------++data SigningError+ = SigningSignError !SignError+ | SigningNoSignersAvailable+ | SigningInvalidTarget !ByteString+ | SigningKeyNotSigningCapable !ByteString+ | SigningKeyExpired !ByteString+ | SigningKeyNotYetValid !ByteString+ deriving (Eq, Show)++renderSigningError :: SigningError -> String+renderSigningError (SigningSignError e) = renderSignError e+renderSigningError SigningNoSignersAvailable =+ "no signing-capable keys available"+renderSigningError (SigningInvalidTarget target) =+ "invalid signing target: " ++ show target+renderSigningError (SigningKeyNotSigningCapable keyId) =+ "key is not signing-capable: " ++ show keyId+renderSigningError (SigningKeyExpired keyId) =+ "key has expired: " ++ show keyId+renderSigningError (SigningKeyNotYetValid keyId) =+ "key is not yet valid: " ++ show keyId++-------------------------------------------------------------------------------++data SignError+ = SignBackendErrorRSA !RSA.Error+ | SignBackendErrorCrypto !CE.CryptoError+ | SignBackendErrorUnsupportedHash !HashAlgorithm+ | SignBackendErrorHashTooShort+ | SignBackendErrorNoV6SaltSize !HashAlgorithm+ | SignBackendErrorUnsupportedKeyTypeV4 !PubKeyAlgorithm+ | SignBackendErrorUnsupportedKeyTypeV6 !PubKeyAlgorithm+ | SignBackendErrorOPSBuild !OPSBuildError+ | SignBackendErrorKeyId !KeyIdError+ | SignUnsupportedCertificationType !SigType+ | SignUnsupportedKeySignatureType !SigType+ | SignV6SaltSizeMismatch !HashAlgorithm !Word8 !Int+ | SignProducedWrongLength !String !Int !Int+ deriving (Eq, Show)++renderSignError :: SignError -> String+renderSignError (SignBackendErrorRSA err) =+ "signing backend error: " ++ show err+renderSignError (SignBackendErrorCrypto err) =+ "signing backend error: " ++ show err+renderSignError (SignBackendErrorUnsupportedHash ha) =+ "signing backend error: unsupported hash algorithm for left16 derivation: "+ ++ show ha+renderSignError SignBackendErrorHashTooShort =+ "signing backend error: hash output too short to derive left16"+renderSignError (SignBackendErrorNoV6SaltSize ha) =+ "signing backend error: signature hash algorithm does not define a V6 salt size: "+ ++ show ha+renderSignError (SignBackendErrorUnsupportedKeyTypeV4 pka) =+ "signing backend error: unsupported signing key type for V4 ("+ ++ show pka+ ++ ")"+renderSignError (SignBackendErrorUnsupportedKeyTypeV6 pka) =+ "signing backend error: unsupported signing key type for V6 ("+ ++ show pka+ ++ ")"+renderSignError (SignBackendErrorOPSBuild err) =+ "signing backend error: " ++ renderOPSBuildError err+renderSignError (SignBackendErrorKeyId err) =+ "signing backend error: " ++ renderKeyIdError err+renderSignError (SignUnsupportedCertificationType t) =+ "unsupported certification signature type: "+ ++ show t+ ++ " (expected one of GenericCert/PersonaCert/CasualCert/PositiveCert)"+renderSignError (SignUnsupportedKeySignatureType t) =+ "unsupported key signature type: "+ ++ show t+ ++ " (expected DirectKeySignature or KeyRevocationSig)"+renderSignError (SignV6SaltSizeMismatch ha expected actual) =+ "v6 signature salt size mismatch for "+ ++ show ha+ ++ ": expected "+ ++ show expected+ ++ ", got "+ ++ show actual+renderSignError (SignProducedWrongLength algo expected actual) =+ algo+ ++ " produced a non-"+ ++ show expected+ ++ "-byte signature (got "+ ++ show actual+ ++ ")"++-------------------------------------------------------------------------------++data CriticalPacketError+ = UnknownCriticalPacket !Word8+ | BrokenCriticalPacket !Word8 !String+ deriving (Eq, Show)++renderCriticalPacketError :: CriticalPacketError -> String+renderCriticalPacketError (UnknownCriticalPacket t) =+ "unknown critical packet type (" ++ show t ++ ")"+renderCriticalPacketError (BrokenCriticalPacket t err) =+ "broken critical packet type " ++ show t ++ ": " ++ err++-------------------------------------------------------------------------------++data VerificationError+ = IssuerSubpacketMismatch+ | IssuerSubpacketUncheckable !KeyIdError+ | IssuerKeyIdProhibitedInV6Signature+ | IssuerFingerprintSubpacketMismatch+ | UnsupportedCriticalSubpacket !SigType+ | VerificationCriticalPacketError !CriticalPacketError+ | NonSignaturePacket+ | UnexpectedSignaturePayloadShape+ | MissingHashAlgorithm+ | HashComputationUnsupportedAlgorithm !HashAlgorithm+ | HashComputationOutputTooShort+ | UnexpectedKeyVersion+ | SignatureHashUnsupportedByAlgorithm+ !HashAlgorithm+ !PubKeyAlgorithm+ | KeyRevoked+ | SigningKeyUnavailableAtSignatureTime+ | MissingIssuer+ | SigningKeyNotFound (Maybe EightOctetKeyId) (Maybe Fingerprint)+ | MultipleVerificationSuccesses !Int+ | UnsupportedKeyType !PubKeyAlgorithm+ | SignatureMismatch !PubKeyAlgorithm !Fingerprint+ | SignatureShapeMismatch !PubKeyAlgorithm+ | SignatureEncodingInvalidCrypto !PubKeyAlgorithm !CE.CryptoError+ | SignatureEncodingInvalidBadPrefix !PubKeyAlgorithm+ | SignatureEncodingInvalidLength !PubKeyAlgorithm !String !Int !Int+ | SignaturePolicyHashUnsupported !HashAlgorithm+ | SignaturePolicyPKAMismatch !PubKeyAlgorithm !PubKeyAlgorithm+ | SignatureExpired+ | CandidateKeyFailures [VerificationError]+ | InvalidSubkeyBackSignature !VerificationError+ deriving (Eq, Show)++renderVerificationError :: VerificationError -> String+renderVerificationError IssuerSubpacketMismatch =+ "verification failed: issuer subpacket does not match the actual signer"+renderVerificationError (IssuerSubpacketUncheckable err) =+ "verification failed: issuer subpacket cannot be checked ("+ ++ renderKeyIdError err+ ++ ")"+renderVerificationError IssuerKeyIdProhibitedInV6Signature =+ "verification failed: Issuer Key ID subpacket is prohibited in v6 signatures"+renderVerificationError IssuerFingerprintSubpacketMismatch =+ "verification failed: issuer fingerprint subpacket does not match the actual signer"+renderVerificationError (UnsupportedCriticalSubpacket sigType) =+ "verification failed: unsupported critical hashed subpacket in "+ ++ show sigType+ ++ " signature"+renderVerificationError (VerificationCriticalPacketError err) =+ "verification failed: " ++ renderCriticalPacketError err+renderVerificationError NonSignaturePacket =+ "verification failed: non-signature packet encountered where signature was expected"+renderVerificationError UnexpectedSignaturePayloadShape =+ "verification failed: unexpected signature payload shape"+renderVerificationError MissingHashAlgorithm =+ "verification failed: signature payload is missing hash algorithm"+renderVerificationError (HashComputationUnsupportedAlgorithm ha) =+ "verification failed: hash computation error (unsupported hash algorithm for left16 derivation: "+ ++ show ha+ ++ ")"+renderVerificationError HashComputationOutputTooShort =+ "verification failed: hash computation error (hash output too short to derive left16)"+renderVerificationError UnexpectedKeyVersion =+ "verification failed: signing key has unexpected version (only v4 and v6 are supported)"+renderVerificationError (SignatureHashUnsupportedByAlgorithm ha pka) =+ "verification failed: hash algorithm "+ ++ show ha+ ++ " is not supported by "+ ++ show pka+ ++ " signing backend"+renderVerificationError KeyRevoked =+ "verification failed: signing key is revoked"+renderVerificationError SigningKeyUnavailableAtSignatureTime =+ "verification failed: signing key was not valid at the signature creation time"+renderVerificationError MissingIssuer =+ "verification failed: signature is missing issuer information"+renderVerificationError (SigningKeyNotFound meoki mfp) =+ "verification failed: signing key not found in keyring"+ ++ issuerContext meoki mfp+renderVerificationError (MultipleVerificationSuccesses n) =+ "verification failed: multiple successful key matches ("+ ++ show n+ ++ ")"+renderVerificationError (UnsupportedKeyType pka) =+ "verification failed: unsupported public key algorithm for verification ("+ ++ show pka+ ++ ")"+renderVerificationError (SignatureMismatch pka fpr) =+ "verification failed: "+ ++ show pka+ ++ " signature mismatch (signer "+ ++ show fpr+ ++ ")"+renderVerificationError (SignatureShapeMismatch pka) =+ "verification failed: malformed "+ ++ show pka+ ++ " signature encoding"+renderVerificationError (SignatureEncodingInvalidCrypto pka err) =+ "verification failed: invalid "+ ++ show pka+ ++ " key/signature encoding ("+ ++ show err+ ++ ")"+renderVerificationError (SignatureEncodingInvalidBadPrefix pka) =+ "verification failed: invalid "+ ++ show pka+ ++ " key/signature encoding (prefixed-native EdDSA public key is missing the 0x40 prefix)"+renderVerificationError (SignatureEncodingInvalidLength pka label expected actual) =+ "verification failed: invalid "+ ++ show pka+ ++ " key/signature encoding (invalid "+ ++ label+ ++ " EdDSA public key length: expected "+ ++ show expected+ ++ " octets, got "+ ++ show actual+ ++ ")"+renderVerificationError (SignaturePolicyHashUnsupported ha) =+ "verification failed: unsupported signature hash policy ("+ ++ show ha+ ++ ")"+renderVerificationError (SignaturePolicyPKAMismatch sigPka keyPka) =+ "verification failed: signature public-key algorithm "+ ++ show sigPka+ ++ " does not match key algorithm "+ ++ show keyPka+renderVerificationError SignatureExpired =+ "verification failed: signature expired"+renderVerificationError (CandidateKeyFailures errs) =+ "verification failed: no candidate key validated the signature ("+ ++ intercalate "; " (nubOrd $ map renderVerificationError errs)+ ++ ")"+renderVerificationError (InvalidSubkeyBackSignature err) =+ "verification failed: embedded primary-key back-signature verification failed: "+ ++ renderVerificationError err++issuerContext+ :: Maybe EightOctetKeyId -> Maybe Fingerprint -> String+issuerContext meoki mfp =+ case (meoki, mfp) of+ (Nothing, Nothing) -> ""+ _ ->+ " (issuer-keyid="+ ++ maybe "unknown" show meoki+ ++ ", issuer-fingerprint="+ ++ maybe "unknown" show mfp+ ++ ")"++-------------------------------------------------------------------------------++data OPSBuildError+ = OPSBuildMissingIssuerKeyId+ | OPSBuildMissingIssuerFingerprint+ | OPSBuildFingerprintWrongLength !Int64+ | OPSBuildUnsupportedSigVersion !Word8+ | OPSBuildIssuerKeyIdProhibitedInV6+ deriving (Eq, Show)++renderOPSBuildError :: OPSBuildError -> String+renderOPSBuildError OPSBuildMissingIssuerKeyId =+ "cannot build OPS3 packet from v4 signature without issuer metadata"+renderOPSBuildError OPSBuildMissingIssuerFingerprint =+ "cannot build OPS6 packet from v6 signature without issuer fingerprint"+renderOPSBuildError (OPSBuildFingerprintWrongLength fpLen) =+ "cannot build OPS6 packet: issuer fingerprint must be 32 octets, got "+ ++ show fpLen+renderOPSBuildError (OPSBuildUnsupportedSigVersion v) =+ "cannot build one-pass signature packet for unsupported signature version "+ ++ show v+renderOPSBuildError OPSBuildIssuerKeyIdProhibitedInV6 =+ "cannot build OPS3 packet: Issuer Key ID subpacket is prohibited in v6 signatures"++-------------------------------------------------------------------------------++data RecipientCapabilityError+ = RecipientCapabilityMissingEncryptionFlags+ !SomePKPayload+ !(Set.Set KeyFlag)+ | RecipientCapabilityNoEncryptableKeyMaterialInTK+ | RecipientCapabilityMissingSEIPDv1Support ![SomePKPayload]+ | RecipientCapabilityMissingSEIPDv2Support ![SomePKPayload]+ | RecipientCapabilityNoCommonSymmetricAlgorithms+ ![SymmetricAlgorithm]+ | RecipientCapabilityNoCommonAEADAlgorithms ![AEADAlgorithm]+ deriving (Eq, Show)++renderRecipientCapabilityError+ :: RecipientCapabilityError -> String+renderRecipientCapabilityError (RecipientCapabilityMissingEncryptionFlags _ flags) =+ "key material missing required encryption flags: " ++ show flags+renderRecipientCapabilityError RecipientCapabilityNoEncryptableKeyMaterialInTK =+ "no encryptable key material in target key"+renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv1Support _) =+ "no recipient supports SEIPDv1"+renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv2Support _) =+ "no recipient supports SEIPDv2"+renderRecipientCapabilityError (RecipientCapabilityNoCommonSymmetricAlgorithms algos) =+ "no common symmetric algorithms: " ++ show algos+renderRecipientCapabilityError (RecipientCapabilityNoCommonAEADAlgorithms algos) =+ "no common AEAD algorithms: " ++ show algos++-------------------------------------------------------------------------------++data PKESKEncryptError+ = UnsupportedSessionKeyAlgorithm !SymmetricAlgorithm !CipherError+ | InvalidSessionKeyLength !SymmetricAlgorithm !Int !Int+ | UnsupportedRecipientAlgorithm !PubKeyAlgorithm+ | InvalidRecipientKeyMaterial !PubKeyAlgorithm !String+ | InvalidRecipientKeyMaterialKeyId !PubKeyAlgorithm !KeyIdError+ | RecipientKdfFailure !PubKeyAlgorithm !String+ | RecipientKeyWrapFailure !PubKeyAlgorithm !String+ | RecipientKeyWrapFailureCipher !PubKeyAlgorithm !CipherError+ | RecipientKeyWrapFailureRSA !PubKeyAlgorithm !RSA.Error+ | RecipientKeyWrapFailureCrypto !PubKeyAlgorithm !CE.CryptoError+ | RecipientCapabilitySelectionFailure !RecipientCapabilityError+ | PayloadBuildFailureCipher !CipherError+ | PayloadBuildFailureS2K !S2KError+ | PayloadBuildFailureOPSBuild !OPSBuildError+ | PayloadBuildFailureSEIPDv2 !SEIPDv2Failure+ | NoRecipientsProvided+ deriving (Eq, Show)++renderPKESKEncryptError :: PKESKEncryptError -> String+renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm algo reason) =+ "unsupported session key algorithm "+ ++ show algo+ ++ ": "+ ++ renderCipherError reason+renderPKESKEncryptError (InvalidSessionKeyLength algo expected actual) =+ "invalid session key length for "+ ++ show algo+ ++ ": expected "+ ++ show expected+ ++ ", got "+ ++ show actual+renderPKESKEncryptError (UnsupportedRecipientAlgorithm algo) =+ "unsupported recipient public-key algorithm: " ++ show algo+renderPKESKEncryptError (InvalidRecipientKeyMaterial algo reason) =+ "invalid recipient key material for "+ ++ show algo+ ++ ": "+ ++ reason+renderPKESKEncryptError (InvalidRecipientKeyMaterialKeyId algo err) =+ "invalid recipient key material for "+ ++ show algo+ ++ ": failed to derive PKESKv3 recipient key ID: "+ ++ renderKeyIdError err+renderPKESKEncryptError (RecipientKdfFailure algo reason) =+ "KDF failure for recipient algorithm "+ ++ show algo+ ++ ": "+ ++ reason+renderPKESKEncryptError (RecipientKeyWrapFailure algo reason) =+ "key wrap failure for recipient algorithm "+ ++ show algo+ ++ ": "+ ++ reason+renderPKESKEncryptError (RecipientKeyWrapFailureCipher algo err) =+ "key wrap failure for recipient algorithm "+ ++ show algo+ ++ ": "+ ++ renderCipherError err+renderPKESKEncryptError (RecipientKeyWrapFailureRSA algo err) =+ "key wrap failure for recipient algorithm "+ ++ show algo+ ++ ": "+ ++ show err+renderPKESKEncryptError (RecipientKeyWrapFailureCrypto algo err) =+ "key wrap failure for recipient algorithm "+ ++ show algo+ ++ ": "+ ++ show err+renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) =+ renderRecipientCapabilityError err+renderPKESKEncryptError (PayloadBuildFailureCipher err) =+ "payload build failure: " ++ renderCipherError err+renderPKESKEncryptError (PayloadBuildFailureS2K err) =+ "payload build failure: " ++ renderS2KError err+renderPKESKEncryptError (PayloadBuildFailureOPSBuild err) =+ "payload build failure: " ++ renderOPSBuildError err+renderPKESKEncryptError (PayloadBuildFailureSEIPDv2 err) =+ "payload build failure: " ++ renderSEIPDv2Failure err+renderPKESKEncryptError NoRecipientsProvided =+ "no recipients provided"++-------------------------------------------------------------------------------++data CompressionError+ = EmptyCompressedPayload !CompressionAlgorithm+ | InnerPacketParseFailed !CompressionAlgorithm !String+ | ZeroLengthDecompressedPayload !CompressionAlgorithm+ | MarkerOnlyPayload !CompressionAlgorithm+ deriving (Eq, Show)++renderCompressionError :: CompressionError -> String+renderCompressionError (EmptyCompressedPayload algo) =+ "Compressed Data packet ("+ ++ show algo+ ++ "): empty compressed payload"+renderCompressionError (InnerPacketParseFailed algo err) =+ "Compressed Data packet ("+ ++ show algo+ ++ "): inner packet parse failed: "+ ++ err+renderCompressionError (ZeroLengthDecompressedPayload algo) =+ "Compressed Data packet ("+ ++ show algo+ ++ "): zero-length decompressed payload"+renderCompressionError (MarkerOnlyPayload algo) =+ "Compressed Data packet ("+ ++ show algo+ ++ "): decompressed content contains only Marker packets"++-------------------------------------------------------------------------------++-------------------------------------------------------------------------------++-- | Packet validation errors+data PktValidationError+ = PktValidationErrorReasonPKESKv6RecipientKeyIdentifierTooLong+ | PktValidationErrorReasonHashAlgorithmNoV6SaltSize HashAlgorithm+ | PktValidationErrorReasonOPSv6SaltSizeMismatch+ { saltSizeExpected :: Word8+ , saltSizeActual :: Word8+ }+ | PktValidationErrorReasonOPSv6SignerFingerprintWrongLength+ | PktValidationErrorReasonSEIPDv2SaltWrongLength+ | PktValidationErrorReasonSEIPDv2ChunkSizeTooLarge+ | PktValidationErrorReasonSEIPDv2SymmetricAlgorithmUnknown+ | PktValidationErrorReasonSEIPDv2SymmetricAlgorithmPlaintext+ | PktValidationErrorReasonSEIPDv2AEADAlgorithmUnknown+ | PktValidationErrorReasonOtherPacketTagTooLarge+ { otherPacketTag :: Word8+ }+ deriving (Eq, Show)++renderPktValidationError :: PktValidationError -> String+renderPktValidationError PktValidationErrorReasonPKESKv6RecipientKeyIdentifierTooLong =+ "PKESK v6 recipient key identifier must fit in one octet (max 255 bytes)"+renderPktValidationError (PktValidationErrorReasonHashAlgorithmNoV6SaltSize ha) =+ "signature hash algorithm does not define a V6 salt size: "+ ++ show ha+renderPktValidationError (PktValidationErrorReasonOPSv6SaltSizeMismatch expected actual) =+ "OPS v6 salt size mismatch: expected "+ ++ show expected+ ++ ", got "+ ++ show actual+renderPktValidationError PktValidationErrorReasonOPSv6SignerFingerprintWrongLength =+ "OPS v6 signer fingerprint must be exactly 32 octets"+renderPktValidationError PktValidationErrorReasonSEIPDv2SaltWrongLength =+ "SEIPD v2 salt must be exactly 32 octets"+renderPktValidationError PktValidationErrorReasonSEIPDv2ChunkSizeTooLarge =+ "SEIPD v2 chunk size octet must be between 0 and 16"+renderPktValidationError PktValidationErrorReasonSEIPDv2SymmetricAlgorithmUnknown =+ "SEIPD v2 requires a known symmetric algorithm"+renderPktValidationError PktValidationErrorReasonSEIPDv2SymmetricAlgorithmPlaintext =+ "SEIPD v2 cannot use plaintext cipher"+renderPktValidationError PktValidationErrorReasonSEIPDv2AEADAlgorithmUnknown =+ "SEIPD v2 requires a known AEAD algorithm"+renderPktValidationError (PktValidationErrorReasonOtherPacketTagTooLarge tag) =+ "cannot serialize OtherPacket packet tag > 63: " ++ show tag++-------------------------------------------------------------------------------++-- | Secret key errors+data SKeyError+ = SKeyErrorReasonInvalidRSAKey+ deriving (Eq, Show)++renderSKeyError :: SKeyError -> String+renderSKeyError SKeyErrorReasonInvalidRSAKey =+ "putSKey: invalid RSA key - q has no multiplicative inverse mod p (key is mathematically broken)"++-------------------------------------------------------------------------------++-------------------------------------------------------------------------------++data SerializeError+ = SerializeErrorReasonValidation !PktValidationError+ | SerializeErrorReasonPutSKey !SKeyError+ | SerializeErrorReasonSymEncBlockSize !SymmetricAlgorithm+ | SerializeErrorReasonECPoint !ECPointError+ deriving (Eq, Show)++renderSerializeError :: SerializeError -> String+renderSerializeError (SerializeErrorReasonValidation e) = renderPktValidationError e+renderSerializeError (SerializeErrorReasonPutSKey e) = renderSKeyError e+renderSerializeError (SerializeErrorReasonSymEncBlockSize sa) =+ "unsupported symmetric algorithm for secret-key IV sizing: "+ ++ show sa+renderSerializeError (SerializeErrorReasonECPoint e) = renderECPointError e++-------------------------------------------------------------------------------+-- AEAD / SEIPDv2 unified auth failures+-------------------------------------------------------------------------------++-- | Unified AEAD authentication failures shared between legacy AEAD and SEIPDv2.+data AEADAuthFailure+ = AEADChunkAuthFailed !AEADAlgorithm !Int+ | AEADFinalTagFailed !AEADAlgorithm+ | AEADInitFailed !CipherError+ deriving (Eq, Show)++renderAEADAuthFailure :: AEADAuthFailure -> String+renderAEADAuthFailure (AEADChunkAuthFailed algo chunk) =+ "AEAD chunk authentication failed for "+ ++ show algo+ ++ " at chunk "+ ++ show chunk+renderAEADAuthFailure (AEADFinalTagFailed algo) =+ "AEAD final tag verification failed for " ++ show algo+renderAEADAuthFailure (AEADInitFailed err) =+ "AEAD initialization failed: " ++ renderCipherError err++-------------------------------------------------------------------------------++data SEIPDv2Failure+ = SEIPDv2UnsupportedAEADAlgorithm !AEADAlgorithm+ | SEIPDv2UnsupportedSymmetricAlgorithm !SymmetricAlgorithm+ | SEIPDv2InvalidSaltLength+ | SEIPDv2InvalidIVLength+ | SEIPDv2InvalidChunkSize+ | SEIPDv2CiphertextTooShort+ | SEIPDv2MalformedChunkLengths+ | SEIPDv2MissingFinalTag+ | SEIPDv2AuthFailure !AEADAuthFailure+ | SEIPDv2AuthFailed+ | 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 (SEIPDv2AuthFailure auth) = renderAEADAuthFailure auth+renderSEIPDv2Failure SEIPDv2AuthFailed =+ "AEAD authentication failed"+renderSEIPDv2Failure (SEIPDv2CipherFailed err) =+ "AEAD/cipher operation failed: " ++ renderCipherError err+renderSEIPDv2Failure (SEIPDv2SessionKeyError err) = renderS2KError err++-------------------------------------------------------------------------------+-- Message-level errors+-------------------------------------------------------------------------------++data MessageParseFailure+ = MissingEncryptedMessage+ | ExpectedSKESKThenEncryptedData+ | SKESKSEIPDAlgorithmMismatch+ | UnsupportedEncryptedSKESK+ | MissingLiteralDataPacket+ | MessageParseCriticalPacketError !CriticalPacketError+ deriving (Eq, Show)++renderMessageParseFailure :: MessageParseFailure -> String+renderMessageParseFailure MissingEncryptedMessage =+ "Could not parse encrypted OpenPGP message"+renderMessageParseFailure ExpectedSKESKThenEncryptedData =+ "Expected an SKESK packet followed by symmetrically encrypted data or SEIPD v2 data"+renderMessageParseFailure SKESKSEIPDAlgorithmMismatch =+ "SKESK and SEIPD v2 algorithms do not match"+renderMessageParseFailure UnsupportedEncryptedSKESK =+ "Cannot decrypt SKESK packets with encrypted session keys"+renderMessageParseFailure MissingLiteralDataPacket =+ "Decrypted message does not contain a literal data packet"+renderMessageParseFailure (MessageParseCriticalPacketError err) =+ renderCriticalPacketError err++-------------------------------------------------------------------------------++data MessageDecryptFailure+ = SessionMaterialDerivationFailed !S2KError+ | PayloadDecryptFailed !PayloadDecryptFailure+ deriving (Eq, Show)++renderMessageDecryptFailure :: MessageDecryptFailure -> String+renderMessageDecryptFailure (SessionMaterialDerivationFailed err) = renderS2KError err+renderMessageDecryptFailure (PayloadDecryptFailed err) = renderPayloadDecryptFailure err++-------------------------------------------------------------------------------++data MessageEncryptFailure+ = MessageEncryptSEIPDv2Failed !SEIPDv2Failure+ | MessageEncryptCipherFailed !CipherError+ | MessageEncryptS2KFailed !S2KError+ | MessageEncryptDeprecatedS2KHash !HashAlgorithm+ | MessageEncryptUnsupportedSymmetricAlgorithm !SymmetricAlgorithm+ deriving (Eq, Show)++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++-------------------------------------------------------------------------------++data PayloadDecryptFailure+ = PayloadDecryptCipherFailed !CipherError+ | PayloadDecryptMDCFailed !MDCFailure+ | PayloadDecryptAEADFailed !AEADAuthFailure+ | PayloadDecryptSEIPDv2Failed !SEIPDv2Failure+ deriving (Eq, Show)++renderPayloadDecryptFailure :: PayloadDecryptFailure -> String+renderPayloadDecryptFailure (PayloadDecryptCipherFailed err) = renderCipherError err+renderPayloadDecryptFailure (PayloadDecryptMDCFailed err) = renderMDCFailure err+renderPayloadDecryptFailure (PayloadDecryptAEADFailed err) = renderAEADAuthFailure err+renderPayloadDecryptFailure (PayloadDecryptSEIPDv2Failed err) = renderSEIPDv2Failure err++-------------------------------------------------------------------------------+-- Decrypt-level errors+-------------------------------------------------------------------------------++data DecryptStructureError+ = DecryptStructureESKSEIPDMismatch+ | DecryptStructureESKOrder+ | DecryptStructureTrailingData+ deriving (Eq, Show)++renderDecryptStructureError :: DecryptStructureError -> String+renderDecryptStructureError DecryptStructureESKSEIPDMismatch =+ "expected exactly one SKESK packet and exactly one SEIPDv2 packet"+renderDecryptStructureError DecryptStructureESKOrder =+ "expected the SKESK packet to precede the SEIPDv2 packet"+renderDecryptStructureError DecryptStructureTrailingData =+ "trailing data after SEIPDv2 payload"++-------------------------------------------------------------------------------++data DecryptOutcome+ = DecryptClean+ | DecryptTruncated+ | DecryptTrailingData+ | DecryptMalformedStructure !DecryptStructureError+ deriving (Eq, Show)++renderDecryptOutcome :: DecryptOutcome -> String+renderDecryptOutcome DecryptClean = "clean"+renderDecryptOutcome DecryptTruncated = "truncated"+renderDecryptOutcome DecryptTrailingData = "trailing data"+renderDecryptOutcome (DecryptMalformedStructure err) =+ "malformed structure: " ++ renderDecryptStructureError err++-------------------------------------------------------------------------------++data DecryptSessionKeyResolutionPath+ = DecryptResolvedViaSKESK+ | DecryptResolvedViaPKESK+ | DecryptResolvedViaManualPKESKInput+ deriving (Eq, Show)++-------------------------------------------------------------------------------++data PKESKResolverAttemptAction+ = ResolverAttemptResolveWith (Maybe (KeyVersion, PubKeyAlgorithm))+ | ResolverAttemptSkip+ | ResolverAttemptExhausted+ deriving (Eq, Show)++-------------------------------------------------------------------------------++data PKESKResolverAttempt+ = PKESKResolverAttempt+ { pkeskResolverAttemptPreviousFailures :: [PKESKAttemptFailure]+ , pkeskResolverAttemptAction :: PKESKResolverAttemptAction+ }+ deriving (Eq, Show)++-------------------------------------------------------------------------------++data DecryptSessionKeyResolutionReport+ = DecryptSessionKeyResolutionReport+ { decryptSessionResolutionPath :: DecryptSessionKeyResolutionPath+ , decryptSessionResolutionSKESKErrors+ :: [SKESKSessionKeyResolutionError]+ , decryptSessionResolutionPKESKErrors :: [PKESKAttemptFailure]+ , decryptSessionResolutionResolverAttempts+ :: [PKESKResolverAttempt]+ }+ deriving (Eq, Show)++-------------------------------------------------------------------------------++data DecryptReport+ = DecryptReport+ { decryptReportOutcome :: DecryptOutcome+ , decryptReportSessionKeyResolutions+ :: [DecryptSessionKeyResolutionReport]+ }+ deriving (Eq, Show)++-- FIXME: this is suboptimal+renderDecryptSessionKeyResolutionReport+ :: DecryptSessionKeyResolutionReport -> String+renderDecryptSessionKeyResolutionReport+ ( DecryptSessionKeyResolutionReport+ _path+ _skeskErrors+ _pkeskErrors+ _resolverAttempts+ ) =+ "decrypt session key resolution report"++renderDecryptReport :: DecryptReport -> String+renderDecryptReport (DecryptReport outcome resolutions) =+ "decrypt report: "+ ++ show outcome+ ++ ", "+ ++ show (length resolutions)+ ++ " resolutions"++-------------------------------------------------------------------------------++data SKESKSessionKeyResolutionError+ = SKESKSessionKeyS2KError !S2KError+ | SKESKSessionKeySEIPDv2Error !SEIPDv2Failure+ | SKESKSessionKeyOtherError !String+ deriving (Eq, Show)++renderSKESKSessionKeyResolutionError+ :: SKESKSessionKeyResolutionError -> String+renderSKESKSessionKeyResolutionError (SKESKSessionKeyS2KError err) = renderS2KError err+renderSKESKSessionKeyResolutionError (SKESKSessionKeySEIPDv2Error err) =+ renderSEIPDv2Failure err+renderSKESKSessionKeyResolutionError (SKESKSessionKeyOtherError err) = err++-------------------------------------------------------------------------------++data PKESKX25519V3UnwrapError+ = PKESKX25519V3ParseError !String+ | PKESKX25519V3CipherError !CipherError+ | PKESKX25519V3KeySizeError !CipherError+ | PKESKX25519V3KeyLengthMismatch !SymmetricAlgorithm !Int !Int+ deriving (Eq, Show)++renderPKESKX25519V3UnwrapError+ :: PKESKX25519V3UnwrapError -> String+renderPKESKX25519V3UnwrapError (PKESKX25519V3ParseError err) = err+renderPKESKX25519V3UnwrapError (PKESKX25519V3CipherError 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++-------------------------------------------------------------------------------+-- Top-level message error+-------------------------------------------------------------------------------++data MessageError+ = MessageEncryptFailureError !MessageEncryptFailure+ | MessageSignError !SignError+ | MessageParseFailureError !MessageParseFailure+ | MessageDecryptFailureError !MessageDecryptFailure+ deriving (Eq, Show)++renderMessageError :: MessageError -> String+renderMessageError (MessageEncryptFailureError err) = renderMessageEncryptFailure err+renderMessageError (MessageSignError err) = renderSignError err+renderMessageError (MessageParseFailureError err) = renderMessageParseFailure err+renderMessageError (MessageDecryptFailureError err) = renderMessageDecryptFailure err++-------------------------------------------------------------------------------+-- PKESK / packet-parse errors (parameterized by pkt)+-------------------------------------------------------------------------------++data CurveConversionError+ = CurveConversionUnsupportedCurve !ByteString+ | CurveConversionUnsupportedEdCurve !ByteString+ deriving (Eq, Show)++renderCurveConversionError :: CurveConversionError -> String+renderCurveConversionError (CurveConversionUnsupportedCurve bs) =+ "unsupported curve OID: " ++ show bs+renderCurveConversionError (CurveConversionUnsupportedEdCurve bs) =+ "unsupported Ed signing curve OID: " ++ show bs++-- | Reasons for packet parse errors+data PktParseErrorReason+ = PktParseErrorReasonPKESKv6RecipientIdentifierInvalid+ { pkeskRecipientIdLength :: Int+ }+ | PktParseErrorReasonPKESKv6KeyVersionInvalid+ { pkeskKeyVersion :: Word8+ }+ | PktParseErrorReasonPKESKv6FingerprintLengthMismatch+ { pkeskKeyVersion :: Word8+ , pkeskExpectedFingerprintLength :: Int+ , pkeskActualFingerprintLength :: Int+ }+ | PktParseErrorReasonUnexpectedTrailingPKESKData+ { pkeskAlgorithm :: PubKeyAlgorithm+ }+ | PktParseErrorReasonX25519V3OctetLayoutInvalid X25519OctetError+ | PktParseErrorReasonECDHOctetLayoutInvalid ECDHOctetError+ | PktParseErrorReasonCurveConversionFailed CurveConversionError+ | PktParseErrorReasonInvalidECPoint ECPointError+ | PktParseErrorReasonGeneric String+ deriving (Eq, Show)++renderPktParseReason :: PktParseErrorReason -> String+renderPktParseReason (PktParseErrorReasonPKESKv6RecipientIdentifierInvalid len) =+ "invalid PKESK v6 recipient identifier length: "+ ++ show len+ ++ " (expected 0, 20, 21, 32, or 33)"+renderPktParseReason (PktParseErrorReasonPKESKv6KeyVersionInvalid ver) =+ "invalid PKESK v6 recipient key version: "+ ++ show ver+ ++ " (expected 4 or 6)"+renderPktParseReason+ ( PktParseErrorReasonPKESKv6FingerprintLengthMismatch+ ver+ expected+ got+ ) =+ "PKESK v6 recipient identifier length/version mismatch: key version "+ ++ show ver+ ++ " requires fingerprint length "+ ++ show expected+ ++ ", got "+ ++ show got+renderPktParseReason (PktParseErrorReasonUnexpectedTrailingPKESKData pka) =+ "unexpected trailing PKESK MPI data for algorithm " ++ show pka+renderPktParseReason (PktParseErrorReasonX25519V3OctetLayoutInvalid e) =+ renderX25519OctetError e+renderPktParseReason (PktParseErrorReasonECDHOctetLayoutInvalid e) =+ renderECDHOctetError e+renderPktParseReason (PktParseErrorReasonCurveConversionFailed e) =+ renderCurveConversionError e+renderPktParseReason (PktParseErrorReasonInvalidECPoint e) =+ renderECPointError e+renderPktParseReason (PktParseErrorReasonGeneric msg) = msg++-- | Packet parse errors with typed reason+data PktParseError+ = PktParseError+ { pktParseErrorOffset :: Int64+ , pktParseErrorReason :: PktParseErrorReason+ }+ deriving (Eq, Show)++renderPktParseError :: PktParseError -> String+renderPktParseError (PktParseError off reason) =+ "parse error at offset "+ ++ show off+ ++ ": "+ ++ renderPktParseReason reason++data PKESKAttemptFailureKind+ = PKESKAttemptUnwrapFailed+ | PKESKAttemptSessionMaterialDecodeFailed+ deriving (Eq, Show)++data PKESKAttemptFailure+ = PKESKAttemptFailure+ { pkeskAttemptFailureKeyContext+ :: Maybe (KeyVersion, PubKeyAlgorithm)+ , pkeskAttemptFailureKind :: PKESKAttemptFailureKind+ , pkeskAttemptFailureReason :: String+ }+ deriving (Eq, Show)
Codec/Encryption/OpenPGP/Types/Internal/PKITypes.hs view
@@ -324,25 +324,6 @@ | SUSUnprotected SKey Word16 deriving (Data, Eq, Generic, Show, Typeable) -{-# DEPRECATED SUS16bit "Use SUSMalleableCFB" #-}-pattern SUS16bit- :: SymmetricAlgorithm -> S2K -> IV -> ByteString -> SKAddendum-pattern SUS16bit sa s2k iv bs = SUSMalleableCFB sa s2k iv bs--{-# DEPRECATED SUSSHA1 "Use SUSCFB" #-}-pattern SUSSHA1- :: SymmetricAlgorithm -> S2K -> IV -> ByteString -> SKAddendum-pattern SUSSHA1 sa s2k iv bs = SUSCFB sa s2k iv bs--{-# DEPRECATED SUSym "Use SUSLegacyCFB" #-}-pattern SUSym- :: SymmetricAlgorithm -> IV -> ByteString -> SKAddendum-pattern SUSym sa iv bs = SUSLegacyCFB sa iv bs--{-# DEPRECATED SUUnencrypted "Use SUSUnprotected" #-}-pattern SUUnencrypted :: SKey -> Word16 -> SKAddendum-pattern SUUnencrypted sk ck = SUSUnprotected sk ck- instance Ord SKAddendum where compare (SUSMalleableCFB sa1 s2k1 iv1 bs1) (SUSMalleableCFB sa2 s2k2 iv2 bs2) = compare sa1 sa2@@ -499,10 +480,26 @@ toSKAddendum (SKAUnprotectedLegacy sk checksum) = SUSUnprotected sk checksum toSKAddendum (SKAUnprotectedV6 sk) = SUSUnprotected sk 0 +{- | Errors from attempting to interpret an untyped 'SKAddendum' for a+specific key version (see 'fromSKAddendumForKeyVersion' /+'fromSKAddendumForPKPayload').+-}+data SKAddendumKeyVersionError+ = SKAddendumV6MalleableCFBProhibited+ | SKAddendumV6LegacyCFBProhibited+ deriving (Data, Eq, Generic, Show, Typeable)++renderSKAddendumKeyVersionError+ :: SKAddendumKeyVersionError -> String+renderSKAddendumKeyVersionError SKAddendumV6MalleableCFBProhibited =+ "v6 secret keys must not use 16-bit checksum protected secret key addendums"+renderSKAddendumKeyVersionError SKAddendumV6LegacyCFBProhibited =+ "v6 secret keys must not use legacy CFB (known symmetric cipher algo ID in S2K usage octet)"+ fromSKAddendumForKeyVersion :: KeyVersion -> SKAddendum- -> Either String SomeSKAddendumV+ -> Either SKAddendumKeyVersionError SomeSKAddendumV fromSKAddendumForKeyVersion DeprecatedV3 (SUSMalleableCFB sa s2k iv bs) = Right ( SomeSKAddendumV@@ -548,11 +545,9 @@ (SKAAEADLegacy sa aa s2k iv bs :: SKAddendumV 'V4) ) fromSKAddendumForKeyVersion V6 (SUSMalleableCFB _ _ _ _) =- Left- "v6 secret keys must not use 16-bit checksum protected secret key addendums"+ Left SKAddendumV6MalleableCFBProhibited fromSKAddendumForKeyVersion V6 (SUSLegacyCFB _ _ _) =- Left- "v6 secret keys must not use legacy CFB (known symmetric cipher algo ID in S2K usage octet)"+ Left SKAddendumV6LegacyCFBProhibited fromSKAddendumForKeyVersion V6 (SUSCFB sa s2k iv bs) = Right (SomeSKAddendumV (SKACFBV6 sa s2k iv bs)) fromSKAddendumForKeyVersion V6 (SUSAEAD sa aa s2k iv bs) =@@ -563,6 +558,6 @@ fromSKAddendumForPKPayload :: SomePKPayload -> SKAddendum- -> Either String SomeSKAddendumV+ -> Either SKAddendumKeyVersionError SomeSKAddendumV fromSKAddendumForPKPayload pkp = fromSKAddendumForKeyVersion (_keyVersion pkp)
Codec/Encryption/OpenPGP/Types/Internal/PacketClass.hs view
@@ -17,9 +17,9 @@ import Control.Error.Util (hush) import Control.Lens (makeLenses)+import Data.Bifunctor (first) import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString)-import qualified Data.ByteString.Lazy as BL import Data.Data (Data) import qualified Data.Kind import Data.List.NonEmpty (NonEmpty)@@ -29,6 +29,9 @@ import Prettyprinter (Pretty (..)) import Codec.Encryption.OpenPGP.Types.Internal.Base+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( PacketCoercionError (..)+ ) import Codec.Encryption.OpenPGP.Types.Internal.PKITypes import Codec.Encryption.OpenPGP.Types.Internal.Pkt @@ -39,19 +42,18 @@ dynamicPacketCode :: a -> Word8 toPkt :: a -> Pkt fromPktMaybe :: Pkt -> Maybe a- fromPktEither :: Pkt -> Either String a+ fromPktEither :: Pkt -> Either PacketCoercionError a fromPktMaybe = hush . fromPktEither dynamicPacketCode = packetCode . packetType -coercionError :: String -> Pkt -> Either String a+coercionError :: String -> Pkt -> Either PacketCoercionError a coercionError expected pkt = Left- ( "Cannot coerce non-"- ++ expected- ++ " packet (tag "- ++ show (pktTag pkt)- ++ ")"+ ( PacketCoercionError+ { pceExpected = "Cannot coerce non-" ++ expected ++ " packet"+ , pceActualTag = pktTag pkt+ } ) data PKESK (v :: PKESKPayloadVersion) where@@ -62,9 +64,9 @@ -> NonEmpty MPI -> PKESK 'PKESKV3 PKESK6Packet- :: B.ByteString+ :: Maybe (KeyVersion, Fingerprint) -> PubKeyAlgorithm- -> B.ByteString+ -> EncryptedSessionKey -> PKESK 'PKESKV6 deriving instance Eq (PKESK v)@@ -80,8 +82,12 @@ (PKESKPayloadV3Packet (PKESKPayloadV3 version keyid pka mpis)) fromPktEither (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ keyid pka mpis))) = Right (PKESK3Packet 3 keyid pka mpis)- fromPktEither (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ _ _))) =- Left "Cannot coerce PKESKv6 packet to PKESKv3"+ fromPktEither pkt@(PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ _ _))) =+ Left+ ( PacketCoercionError+ "Cannot coerce PKESKv6 packet to PKESKv3"+ (pktTag pkt)+ ) fromPktEither pkt = coercionError "PKESK" pkt instance Pretty (PKESK 'PKESKV3) where@@ -92,20 +98,24 @@ deriving (Eq, Show) packetType _ = PKESK6Type packetCode _ = 1- toPkt (PKESK6Packet recipientKeyIdentifier pka esk) =+ toPkt (PKESK6Packet mKvFp pka esk) = PKESKPkt ( PKESKPayloadV6Packet- (PKESKPayloadV6 recipientKeyIdentifier pka esk)+ (PKESKPayloadV6 mKvFp pka esk) ) fromPktEither ( PKESKPkt ( PKESKPayloadV6Packet- (PKESKPayloadV6 recipientKeyIdentifier pka esk)+ (PKESKPayloadV6 mKvFp pka esk) ) ) =- Right (PKESK6Packet recipientKeyIdentifier pka esk)- fromPktEither (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ _ _))) =- Left "Cannot coerce PKESKv3 packet to PKESKv6"+ Right (PKESK6Packet mKvFp pka esk)+ fromPktEither pkt@(PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ _ _))) =+ Left+ ( PacketCoercionError+ "Cannot coerce PKESKv3 packet to PKESKv6"+ (pktTag pkt)+ ) fromPktEither pkt = coercionError "PKESKv6" pkt instance Pretty (PKESK 'PKESKV6) where@@ -156,7 +166,7 @@ signaturePayloadFromSignatureV (SignatureVOtherPacket payload) = toSignaturePayload payload fromPktEitherSomeSignatureV- :: Pkt -> Either String SomeSignatureV+ :: Pkt -> Either PacketCoercionError SomeSignatureV fromPktEitherSomeSignatureV (SignaturePkt payload) = Right (someSignatureVFromPayload payload) fromPktEitherSomeSignatureV pkt =@@ -181,7 +191,9 @@ packetCode _ = 2 toPkt = SignaturePkt . signaturePayloadFromSignatureV fromPktEither (SignaturePkt payload) =- SignatureV3Packet <$> asSignaturePayloadV3 payload+ first+ (\msg -> PacketCoercionError msg 2)+ (SignatureV3Packet <$> asSignaturePayloadV3 payload) fromPktEither pkt = coercionError "SignatureV3" pkt instance Pretty (SignatureV 'SigPayloadV3) where@@ -194,7 +206,9 @@ packetCode _ = 2 toPkt = SignaturePkt . signaturePayloadFromSignatureV fromPktEither (SignaturePkt payload) =- SignatureV4Packet <$> asSignaturePayloadV4 payload+ first+ (\msg -> PacketCoercionError msg 2)+ (SignatureV4Packet <$> asSignaturePayloadV4 payload) fromPktEither pkt = coercionError "SignatureV4" pkt instance Pretty (SignatureV 'SigPayloadV4) where@@ -207,7 +221,9 @@ packetCode _ = 2 toPkt = SignaturePkt . signaturePayloadFromSignatureV fromPktEither (SignaturePkt payload) =- SignatureV6Packet <$> asSignaturePayloadV6 payload+ first+ (\msg -> PacketCoercionError msg 2)+ (SignatureV6Packet <$> asSignaturePayloadV6 payload) fromPktEither pkt = coercionError "SignatureV6" pkt instance Pretty (SignatureV 'SigPayloadV6) where@@ -220,7 +236,9 @@ packetCode _ = 2 toPkt = SignaturePkt . signaturePayloadFromSignatureV fromPktEither (SignaturePkt payload) =- SignatureVOtherPacket <$> asSignaturePayloadOther payload+ first+ (\msg -> PacketCoercionError msg 2)+ (SignatureVOtherPacket <$> asSignaturePayloadOther payload) fromPktEither pkt = coercionError "SignatureVOther" pkt instance Pretty (SignatureV 'SigPayloadVOther) where@@ -253,8 +271,12 @@ SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 symalgo s2k esk)) fromPktEither (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 symalgo s2k esk))) = Right (SKESK4Packet symalgo s2k esk)- fromPktEither (SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ _ _ _ _))) =- Left "Cannot coerce SKESKv6 packet to SKESKv4"+ fromPktEither pkt@(SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 _ _ _ _ _ _))) =+ Left+ ( PacketCoercionError+ "Cannot coerce SKESKv6 packet to SKESKv4"+ (pktTag pkt)+ ) fromPktEither pkt = coercionError "SKESK" pkt instance Pretty (SKESK 'SKESKV4) where@@ -273,8 +295,12 @@ (SKESKPayloadV6Packet (SKESKPayloadV6 symalgo aead s2k iv esk tag)) ) = Right (SKESK6Packet symalgo aead s2k iv esk tag)- fromPktEither (SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ _ _))) =- Left "Cannot coerce SKESKv4 packet to SKESKv6"+ fromPktEither pkt@(SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 _ _ _))) =+ Left+ ( PacketCoercionError+ "Cannot coerce SKESKv4 packet to SKESKv6"+ (pktTag pkt)+ ) fromPktEither pkt = coercionError "SKESKv6" pkt instance Pretty (SKESK 'SKESKV6) where
Codec/Encryption/OpenPGP/Types/Internal/Pkt.hs view
@@ -45,6 +45,9 @@ import Prettyprinter (Pretty (..), (<+>)) import Codec.Encryption.OpenPGP.Types.Internal.Base+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( KeyPktCoercionError (..)+ ) import Codec.Encryption.OpenPGP.Types.Internal.PKITypes import Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils ( prettyBS@@ -64,9 +67,9 @@ data PKESKPayloadV6 = PKESKPayloadV6- B.ByteString+ (Maybe (KeyVersion, Fingerprint)) PubKeyAlgorithm- B.ByteString+ EncryptedSessionKey deriving (Data, Eq, Generic, Hashable, Ord, Show, Typeable) data PKESKPayload@@ -204,13 +207,6 @@ someKeyPktToPkt (SomeKeyPkt left) == someKeyPktToPkt (SomeKeyPkt right) -data KeyPktCoercionError- = NotAKeyPacket Pkt- | ExpectedPublicKeyPacket Pkt- | ExpectedSecretKeyPacket Pkt- deriving (Eq, Show)---- data Pkt = forall a. (Packet a, Show a, Eq a) => Pkt a data Pkt = PKESKPkt PKESKPayload | SignaturePkt SignaturePayload@@ -320,12 +316,17 @@ pretty ( PKESKPkt ( PKESKPayloadV6Packet- (PKESKPayloadV6 recipientKeyIdentifier pka esk)+ (PKESKPayloadV6 mKvFp pka (EncryptedSessionKey esk)) ) ) = pretty "PKESK v6:"- <+> pretty "recipient key identifier"- <+> pretty (bsToHexUpper recipientKeyIdentifier)+ <+> pretty "recipient"+ <+> pretty+ ( maybe+ "anonymous"+ (\(kv, fp) -> show kv ++ "/" ++ bsToHexUpper (unFingerprint fp))+ mKvFp+ ) <+> pretty pka <+> pretty (bsToHexUpper esk) pretty (SignaturePkt sp) = pretty sp@@ -435,15 +436,20 @@ toJSON ( PKESKPkt ( PKESKPayloadV6Packet- (PKESKPayloadV6 recipientKeyIdentifier pka esk)+ (PKESKPayloadV6 mKvFp pka (EncryptedSessionKey esk)) ) ) = object [ AK.fromString "pkesk" .= object [ AK.fromString "version" .= (6 :: PacketVersion)- , AK.fromString "recipient_key_identifier"- .= B.unpack recipientKeyIdentifier+ , AK.fromString "recipient" .= case mKvFp of+ Nothing -> A.Null+ Just (kv, fp) ->+ object+ [ AK.fromString "key_version" .= kv+ , AK.fromString "fingerprint" .= B.unpack (unFingerprint fp)+ ] , AK.fromString "pkalgo" .= pka , AK.fromString "esk" .= B.unpack esk ]@@ -608,14 +614,6 @@ pktTag (OtherPacketPkt t _) = t pktTag (BrokenPacketPkt _ t _) = t -- is this the right thing to do? -renderKeyPktCoercionError :: KeyPktCoercionError -> String-renderKeyPktCoercionError (NotAKeyPacket pkt) =- "Expected a key packet, got tag " ++ show (pktTag pkt)-renderKeyPktCoercionError (ExpectedPublicKeyPacket pkt) =- "Expected a public key packet, got tag " ++ show (pktTag pkt)-renderKeyPktCoercionError (ExpectedSecretKeyPacket pkt) =- "Expected a secret key packet, got tag " ++ show (pktTag pkt)- keyPktRole :: KeyPkt k -> KeyPktRole keyPktRole KeyPktPublicPrimary {} = KeyPktPrimary keyPktRole KeyPktPublicSubkey {} = KeyPktSubkey@@ -664,7 +662,7 @@ someKeyPktToPkt (SomeKeyPkt keyPkt) = keyPktToPkt keyPkt pktToSomeKeyPktEither- :: Pkt -> Either KeyPktCoercionError SomeKeyPkt+ :: Pkt -> Either (KeyPktCoercionError Pkt) SomeKeyPkt pktToSomeKeyPktEither (PublicKeyPkt pkp) = Right (SomeKeyPkt (KeyPktPublicPrimary pkp)) pktToSomeKeyPktEither (PublicSubkeyPkt pkp) = Right (SomeKeyPkt (KeyPktPublicSubkey pkp)) pktToSomeKeyPktEither (SecretKeyPkt pkp ska) = Right (SomeKeyPkt (KeyPktSecretPrimary pkp ska))@@ -675,7 +673,7 @@ pktToSomeKeyPkt = hush . pktToSomeKeyPktEither pktToPublicKeyPktEither- :: Pkt -> Either KeyPktCoercionError (KeyPkt 'PublicPkt)+ :: Pkt -> Either (KeyPktCoercionError Pkt) (KeyPkt 'PublicPkt) pktToPublicKeyPktEither (PublicKeyPkt pkp) = Right (KeyPktPublicPrimary pkp) pktToPublicKeyPktEither (PublicSubkeyPkt pkp) = Right (KeyPktPublicSubkey pkp) pktToPublicKeyPktEither pkt = Left (ExpectedPublicKeyPacket pkt)@@ -684,7 +682,7 @@ pktToPublicKeyPkt = hush . pktToPublicKeyPktEither pktToSecretKeyPktEither- :: Pkt -> Either KeyPktCoercionError (KeyPkt 'SecretPkt)+ :: Pkt -> Either (KeyPktCoercionError Pkt) (KeyPkt 'SecretPkt) pktToSecretKeyPktEither (SecretKeyPkt pkp ska) = Right (KeyPktSecretPrimary pkp ska) pktToSecretKeyPktEither (SecretSubkeyPkt pkp ska) = Right (KeyPktSecretSubkey pkp ska) pktToSecretKeyPktEither pkt = Left (ExpectedSecretKeyPacket pkt)
Codec/Encryption/OpenPGP/Types/Internal/PrettyUtils.hs view
@@ -8,7 +8,7 @@ import qualified Data.ByteString.Lazy as BL import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)-import Prettyprinter (Doc, Pretty(..))+import Prettyprinter (Doc, Pretty (..)) prettyBS :: B.ByteString -> Doc ann prettyBS = pretty . decodeUtf8With lenientDecode
Codec/Encryption/OpenPGP/Types/Internal/TK.hs view
@@ -20,7 +20,6 @@ , TK (..) , SomeTK (..) , TKKind (..)- , TKConversionError (..) , PacketZipper (..) , TKKindToKeyPktKind , KeyringIxs@@ -167,10 +166,10 @@ import qualified Data.Set as Set import Data.Text (Text) import Data.Typeable (Typeable)-import Data.Word (Word8) import GHC.Generics (Generic) import Codec.Encryption.OpenPGP.Types.Internal.Base+import Codec.Encryption.OpenPGP.Types.Internal.Errors import Codec.Encryption.OpenPGP.Types.Internal.PKITypes import Codec.Encryption.OpenPGP.Types.Internal.Pkt @@ -273,27 +272,6 @@ instance Eq SomeTK where left == right = someTKToUnknown left == someTKToUnknown right--data TKConversionError- = PublicSubkeyHasPrimaryRole- | SecretSubkeyHasPrimaryRole- | ExpectedPublicSubkeyPacket Word8- | ExpectedSecretSubkeyPacket Word8- | ExpectedPublicPrimaryKeyPacket Word8- | ExpectedSecretPrimaryKeyPacket Word8- deriving (Eq, Show)--renderTKConversionError :: TKConversionError -> String-renderTKConversionError PublicSubkeyHasPrimaryRole = "public subkey has primary-key role"-renderTKConversionError SecretSubkeyHasPrimaryRole = "secret subkey has primary-key role"-renderTKConversionError (ExpectedPublicSubkeyPacket tagValue) =- "expected public subkey, got packet tag " ++ show tagValue-renderTKConversionError (ExpectedSecretSubkeyPacket tagValue) =- "expected secret subkey, got packet tag " ++ show tagValue-renderTKConversionError (ExpectedPublicPrimaryKeyPacket tagValue) =- "expected primary key packet, got packet tag " ++ show tagValue-renderTKConversionError (ExpectedSecretPrimaryKeyPacket tagValue) =- "expected primary key packet, got packet tag " ++ show tagValue tkToUnknown :: TK k -> TKUnknown tkToUnknown tk =
Codec/Encryption/OpenPGP/Version.hs view
@@ -3,10 +3,11 @@ -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Version- ( version- ) where+ ( version+ ) where import Data.Version (showVersion)+ import qualified Paths_hOpenPGP as Paths version :: String
Data/Conduit/OpenPGP/Compression.hs view
@@ -4,24 +4,27 @@ -- (See the LICENSE file). module Data.Conduit.OpenPGP.Compression- ( conduitCompress- , conduitDecompress- ) where+ ( conduitCompress+ , conduitDecompress+ ) where -import Codec.Encryption.OpenPGP.Compression-import Codec.Encryption.OpenPGP.Types import Control.Monad.Trans.Resource (MonadThrow, throwM) import Data.Conduit import qualified Data.Conduit.List as CL -conduitCompress :: MonadThrow m => CompressionAlgorithm -> ConduitT Pkt Pkt m ()+import Codec.Encryption.OpenPGP.Compression+import Codec.Encryption.OpenPGP.Types++conduitCompress+ :: MonadThrow m => CompressionAlgorithm -> ConduitT Pkt Pkt m () conduitCompress algo = CL.consume >>= \ps -> yield (compressPkts algo ps) --- | Decompress OpenPGP Compressed Data packets. Decompression failures,--- empty payloads, zero-length results, and marker-only payloads are reported--- via 'MonadThrow' rather than silently dropped.+{- | Decompress OpenPGP Compressed Data packets. Decompression failures,+empty payloads, zero-length results, and marker-only payloads are reported+via 'MonadThrow' rather than silently dropped.+-} conduitDecompress :: MonadThrow m => ConduitT Pkt Pkt m () conduitDecompress = awaitForever $ \pkt ->- case decompressPkt pkt of- Left err -> throwM (userError (renderCompressionError err))- Right pkts -> mapM_ yield pkts+ case decompressPkt pkt of+ Left err -> throwM (userError (renderCompressionError err))+ Right pkts -> mapM_ yield pkts
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -77,9 +77,7 @@ import qualified "crypton" Crypto.Cipher.Types as CCT import Codec.Encryption.OpenPGP.BlockCipher- ( CipherError (..)- , keySize- , renderCipherError+ ( keySize ) import Codec.Encryption.OpenPGP.CFB ( decryptOpenPGPCfb@@ -112,25 +110,19 @@ , validateTable30PolicyForRecipient ) import Codec.Encryption.OpenPGP.S2K- ( S2KError (..)- , decodeOpenPGPEncodedSessionKey- , renderEncodedSessionKeyError- , renderS2KError+ ( decodeOpenPGPEncodedSessionKey , skesk2Key , skesk2SessionKey , string2Key ) import Codec.Encryption.OpenPGP.SEIPDv1 ( calculateMDC- , renderMDCFailure , validateSEIPD1MDC ) import Codec.Encryption.OpenPGP.SEIPDv2- ( SEIPDv2Failure (..)- , aeadModeAndNonceSizeForSEIPDv2+ ( aeadModeAndNonceSizeForSEIPDv2 , decryptSKESK6SessionKey , deriveSKESK6KEK- , renderSEIPDv2Failure , seipdv2SymmetricKeySize ) import Codec.Encryption.OpenPGP.SecretKey@@ -205,33 +197,6 @@ -- ^ Corresponding secret key. } -data PKESKAttemptFailure- = PKESKAttemptFailure- { pkeskAttemptFailureKeyContext- :: Maybe (KeyVersion, PubKeyAlgorithm)- , pkeskAttemptFailureKind :: PKESKAttemptFailureKind- , pkeskAttemptFailureReason :: String- }- deriving (Eq, Show)--data PKESKAttemptFailureKind- = PKESKAttemptUnwrapFailed- | PKESKAttemptSessionMaterialDecodeFailed- deriving (Eq, Show)--data PKESKResolverError- = ResolverPolicyDenied String- | ResolverBackendUnavailable String- | 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@@ -246,7 +211,6 @@ = ResolveWith PKESKRecipientKey | ResolveSkip | ResolveExhausted- | ResolveFail PKESKResolverError type PKESKResolver m = PKESKResolveRequest -> m PKESKResolveAction@@ -308,75 +272,7 @@ (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- well-formed end-to-end.- -}- DecryptClean- | {- | The input stream ended before any integrity-terminating marker was- seen. The ciphertext was incomplete.- -}- DecryptTruncated- | {- | An integrity-terminating marker was seen, but additional packets- followed it. Only possible with 'lenientDecryptPolicy' (strict- policy reports 'DecryptMalformedStructure' instead). The trailing- packets were forwarded downstream unchanged.- -}- DecryptTrailingData- | {- | A structural packet-sequencing violation was detected. Use- 'renderDecryptStructureError' to obtain a human-readable description.- -}- DecryptMalformedStructure DecryptStructureError- deriving (Eq, Show)--data DecryptSessionKeyResolutionPath- = DecryptResolvedViaSKESK- | DecryptResolvedViaPKESK- | DecryptResolvedViaManualPKESKInput- deriving (Eq, Show)--data PKESKResolverAttemptAction- = ResolverAttemptResolveWith (Maybe (KeyVersion, PubKeyAlgorithm))- | ResolverAttemptSkip- | ResolverAttemptExhausted- | ResolverAttemptFail PKESKResolverError- deriving (Eq, Show)--data PKESKResolverAttempt- = PKESKResolverAttempt- { pkeskResolverAttemptPreviousFailures :: [PKESKAttemptFailure]- -- ^ Failures from earlier attempts on the same PKESK packet.- , pkeskResolverAttemptAction :: PKESKResolverAttemptAction- }- deriving (Eq, Show)--data DecryptSessionKeyResolutionReport- = DecryptSessionKeyResolutionReport- { decryptSessionResolutionPath :: DecryptSessionKeyResolutionPath- , decryptSessionResolutionSKESKErrors- :: [SKESKSessionKeyResolutionError]- , decryptSessionResolutionPKESKErrors :: [PKESKAttemptFailure]- , decryptSessionResolutionResolverAttempts- :: [PKESKResolverAttempt]- }- deriving (Eq, Show)--data DecryptReport- = DecryptReport- { decryptReportOutcome :: DecryptOutcome- , decryptReportSessionKeyResolutions- :: [DecryptSessionKeyResolutionReport]- }- deriving (Eq, Show)- -- | AEAD decryption context (Reader monad eliminates parameter threading) data AEADDecryptContext cipher = AEADDecryptContext@@ -642,9 +538,10 @@ extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid _ _))) | isWildcardV3RecipientKeyId rid = KeyIdentifierWildcard | otherwise = KeyIdentifierEightOctet rid-extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)))- | B.null rid = KeyIdentifierWildcard- | otherwise = KeyIdentifierFingerprint (Fingerprint rid)+extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 mKvFp _ _))) =+ case mKvFp of+ Nothing -> KeyIdentifierWildcard+ Just (_, fp) -> KeyIdentifierFingerprint fp extractProbeKeyIdentifier _ = KeyIdentifierWildcard isWildcardV3RecipientKeyId :: EightOctetKeyId -> Bool@@ -1124,7 +1021,7 @@ -> Either SEIPDv2Failure B.ByteString decryptSEIPDv2WithKey symalgo aeadalgo mode chunkSize info noncePrefix sessionKey encrypted = withAESCipher- SEIPDv2CipherInitFailed+ (SEIPDv2CipherFailed . CipherInitFailed symalgo . show) (SEIPDv2UnsupportedSymmetricAlgorithm symalgo) symalgo sessionKey@@ -1191,7 +1088,8 @@ then lift $ decryptWithOCBRFC7253With- (\_ _ _ _ _ _ -> SEIPDv2ChunkAuthFailed aeadalgo idx)+ ( \_ _ _ _ _ _ -> SEIPDv2AuthFailure (AEADChunkAuthFailed aeadalgo idx)+ ) cipher' (noncePrefix' <> encodeWord64be (fromIntegral idx)) info@@ -1206,7 +1104,9 @@ chunkCiphertext (mkAuthTag chunkTag) case mPlain of- Nothing -> lift $ Left (SEIPDv2ChunkAuthFailed aeadalgo idx)+ Nothing ->+ lift $+ Left (SEIPDv2AuthFailure (AEADChunkAuthFailed aeadalgo idx)) Just p -> return p verifyFinalTagWithContext idx totalPlain finalTag = do@@ -1216,7 +1116,7 @@ plain <- lift $ decryptWithOCBRFC7253With- (\_ _ _ _ _ _ -> SEIPDv2FinalTagFailed aeadalgo)+ (\_ _ _ _ _ _ -> SEIPDv2AuthFailure (AEADFinalTagFailed aeadalgo)) cipher' (noncePrefix' <> encodeWord64be idx) (info <> encodeWord64be (fromIntegral totalPlain))@@ -1226,7 +1126,7 @@ then return () else lift $- Left (SEIPDv2FinalTagFailed aeadalgo)+ Left (SEIPDv2AuthFailure (AEADFinalTagFailed aeadalgo)) else do aead <- initAEADWithContext idx let mEmpty =@@ -1239,12 +1139,12 @@ Just p | B.null p -> return () _ -> lift $- Left (SEIPDv2FinalTagFailed aeadalgo)+ Left (SEIPDv2AuthFailure (AEADFinalTagFailed aeadalgo)) initAEADWithContext idx = do AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask lift- $ first SEIPDv2CipherInitFailed+ $ first (SEIPDv2CipherFailed . CipherOperationFailed . show) . CE.eitherCryptoError $ CCT.aeadInit mode' cipher' (noncePrefix' <> encodeWord64be idx) @@ -1305,74 +1205,6 @@ ClassifiedSKESKPayloadV4 _ -> Nothing ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ aa _ _ _ _) -> Just aa -data SKESKSessionKeyResolutionError- = SKESKSessionKeyS2KError S2KError- | SKESKSessionKeyOtherError String- deriving (Eq, Show)--renderSKESKSessionKeyResolutionError- :: SKESKSessionKeyResolutionError -> String-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 :: Passphrase -> ClassifiedSKESKPayload@@ -1396,10 +1228,10 @@ first SKESKSessionKeyS2KError (string2Key s2k keyLen passphrase) kek <- first- (SKESKSessionKeyOtherError . renderSEIPDv2Failure)+ SKESKSessionKeySEIPDv2Error (deriveSKESK6KEK sa aead ikm) first- (SKESKSessionKeyOtherError . renderSEIPDv2Failure)+ SKESKSessionKeySEIPDv2Error ( decryptSKESK6SessionKey sa aead@@ -1725,13 +1557,6 @@ (\pk -> (_keyVersion pk, _pkalgo pk)) (pkeskRecipientPKPayload keyInfo) - renderPKESKResolverError (ResolverPolicyDenied reason) =- "resolver policy denied candidate selection: " ++ reason- renderPKESKResolverError (ResolverBackendUnavailable reason) =- "resolver backend unavailable: " ++ reason- renderPKESKResolverError (ResolverInvalidResponse reason) =- "resolver returned an invalid response: " ++ reason- resolvePKESKRecipientKey payload previousFailures attemptIndex0 = probePacketVariants attemptIndex0@@ -1760,7 +1585,6 @@ ResolverAttemptResolveWith (recipientKeyContext keyInfo) ResolveSkip -> ResolverAttemptSkip ResolveExhausted -> ResolverAttemptExhausted- ResolveFail resolverErr -> ResolverAttemptFail resolverErr } case resolveAction of ResolveWith keyInfo ->@@ -1784,8 +1608,6 @@ , reverse (attemptRecord : attemptsAcc) ) )- ResolveFail resolverErr ->- pure (Left (renderPKESKResolverError resolverErr)) pkeskCallbackPackets payload = nub $@@ -1797,13 +1619,8 @@ (PKESKPayloadV3Packet (PKESKPayloadV3 v ridVariant pka mpis)) ) (recipientIdCallbackVariantsV3 rid)- PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk) ->- map- ( \ridVariant ->- PKESKPkt- (PKESKPayloadV6Packet (PKESKPayloadV6 ridVariant pka esk))- )- (recipientIdCallbackVariants rid)+ PKESKPayloadV6Packet (PKESKPayloadV6 mKvFp pka esk) ->+ [PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 mKvFp pka esk))] describeCallbackProbeSummary payload = intercalate@@ -1818,21 +1635,17 @@ ++ if isWildcardV3RecipientKeyId rid then " (wildcard)" else ""- describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) =- "PKESK6 " ++ show pka ++ " rid=" ++ show rid+ describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 mKvFp pka _))) =+ "PKESK6 "+ ++ show pka+ ++ " "+ ++ maybe "wildcard" (\(kv, fp) -> show kv ++ "/" ++ show fp) mKvFp describePKESKCallbackProbe pkt = show pkt recipientIdCallbackVariantsV3 rid | isWildcardV3RecipientKeyId rid = [rid] | otherwise = [rid, EightOctetKeyId (B.replicate 8 0)] - recipientIdCallbackVariants rid- | B.length rid == 20 = [rid, B.cons 0x04 rid]- | B.length rid == 21 && B.head rid == 0x04 = [rid, B.tail rid]- | B.length rid == 32 = [rid, B.cons 0x06 rid]- | B.length rid == 33 && B.head rid == 0x06 = [rid, B.tail rid]- | otherwise = [rid]- isWildcardPKESKPayload (PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _)) = isWildcardV3RecipientKeyId (EightOctetKeyId rid) isWildcardPKESKPayload _ = False@@ -1840,8 +1653,11 @@ case classifyPKESKPayload payload of ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ rid pka _) -> "PKESK3 " ++ show pka ++ " rid=" ++ show rid- ClassifiedPKESKPayloadV6 (PKESKPayloadV6 rid pka _) ->- "PKESK6 " ++ show pka ++ " rid=" ++ show rid+ ClassifiedPKESKPayloadV6 (PKESKPayloadV6 mKvFp pka _) ->+ "PKESK6 "+ ++ show pka+ ++ " "+ ++ maybe "wildcard" (\(kv, fp) -> show kv ++ "/" ++ show fp) mKvFp describeSKESK payload = case classifySKESKPayload payload of@@ -2029,18 +1845,21 @@ ) | pka == RSA || pka == DeprecatedRSAEncryptOnly -> Right (PKESKUnwrapV3RSA privateKey mpi)- ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)+ ( ClassifiedPKESKPayloadV6+ (PKESKPayloadV6 _ pka (EncryptedSessionKey esk)) , ClassifiedPKESKRecipientRSA _ privateKey ) | pka == RSA -> Right (PKESKUnwrapV6RSA privateKey esk)- ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)+ ( ClassifiedPKESKPayloadV6+ (PKESKPayloadV6 _ pka (EncryptedSessionKey esk)) , ClassifiedPKESKRecipientECDH recipientCtx privateKey ) | pka == ECDH || pka == X25519 -> Right (PKESKUnwrapV6ECDH recipientCtx pka esk privateKey)- ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)+ ( ClassifiedPKESKPayloadV6+ (PKESKPayloadV6 _ pka (EncryptedSessionKey esk)) , ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw ) | pka == X25519 ->@@ -2051,7 +1870,8 @@ esk privateKeyRaw )- ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)+ ( ClassifiedPKESKPayloadV6+ (PKESKPayloadV6 _ pka (EncryptedSessionKey esk)) , ClassifiedPKESKRecipientX448 recipientCtx privateKeyRaw ) | pka == X448 ->@@ -2494,7 +2314,7 @@ (parsePKESKv3X25519EskBytes eskBytes) rawKey <- first- PKESKX25519V3UnwrapError+ PKESKX25519V3CipherError (aesKeyUnwrapRFC3394 AES128 kek9580 wrappedKey) expectedLen <- first PKESKX25519V3KeySizeError (keySize sessionAlgorithm)
Data/Conduit/OpenPGP/Keyring.hs view
@@ -52,8 +52,7 @@ , signatureEffectiveAt ) import Codec.Encryption.OpenPGP.KeyringParser- ( KeyringChunkParseError (..)- , anyTK+ ( anyTK , anyTKWithWireRep , finalizeParsingEither , parseAChunkEither
Data/Conduit/OpenPGP/Message.hs view
@@ -4,92 +4,99 @@ -- (See the LICENSE file). module Data.Conduit.OpenPGP.Message- ( VerificationPolicy(..)- , VerificationOptions(..)- , defaultVerificationOptions- , verifyMessagePackets- , verifyMessage- , VerificationMode(..)- ) where+ ( VerificationPolicy (..)+ , VerificationOptions (..)+ , defaultVerificationOptions+ , verifyMessagePackets+ , verifyMessage+ , VerificationMode (..)+ ) where import qualified Data.ByteString.Lazy as BL-import Data.Conduit ((.|), runConduitPure)+import Data.Conduit (runConduitPure, (.|)) import qualified Data.Conduit.List as CL import Data.Time.Clock (UTCTime) import Codec.Encryption.OpenPGP.Compression (decompressPkt)-import Codec.Encryption.OpenPGP.Policy (defaultVerificationDefaults, verificationDefaultStreaming, verificationDefaultStrict)+import Codec.Encryption.OpenPGP.Policy+ ( defaultVerificationDefaults+ , verificationDefaultStreaming+ , verificationDefaultStrict+ ) import Codec.Encryption.OpenPGP.Serialize (parsePkts)-import Codec.Encryption.OpenPGP.Signatures (VerificationError) import Codec.Encryption.OpenPGP.Types import Data.Conduit.OpenPGP.Verify- ( VerificationMode(..)- , VerificationModeW(..)- , verifyPacketsWithModeTyped- , verifyPacketsBatch- )+ ( VerificationMode (..)+ , VerificationModeW (..)+ , verifyPacketsBatch+ , verifyPacketsWithModeTyped+ ) data VerificationPolicy- = VerifyInformational- | VerifyStrict- deriving (Eq, Show)+ = VerifyInformational+ | VerifyStrict+ deriving (Eq, Show) data VerificationOptions = VerificationOptions- { verificationPolicy :: VerificationPolicy- , verificationMode :: VerificationMode- , verificationTime :: Maybe UTCTime- }- deriving (Eq, Show)+ { verificationPolicy :: VerificationPolicy+ , verificationMode :: VerificationMode+ , verificationTime :: Maybe UTCTime+ }+ deriving (Eq, Show) defaultVerificationOptions :: VerificationOptions defaultVerificationOptions =- VerificationOptions- { verificationPolicy =- if verificationDefaultStrict defaultVerificationDefaults- then VerifyStrict- else VerifyInformational- , verificationMode =- if verificationDefaultStreaming defaultVerificationDefaults- then VerificationStreaming- else VerificationBatch- , verificationTime = Nothing- }+ VerificationOptions+ { verificationPolicy =+ if verificationDefaultStrict defaultVerificationDefaults+ then VerifyStrict+ else VerifyInformational+ , verificationMode =+ if verificationDefaultStreaming defaultVerificationDefaults+ then VerificationStreaming+ else VerificationBatch+ , verificationTime = Nothing+ } -verifyMessagePackets ::- VerificationOptions- -> PublicKeyring- -> [Pkt]- -> [Either VerificationError Verification]+verifyMessagePackets+ :: VerificationOptions+ -> PublicKeyring+ -> [Pkt]+ -> [Either VerificationError Verification] verifyMessagePackets options keyring packets =- applyVerificationPolicy (verificationPolicy options) rawResults+ applyVerificationPolicy (verificationPolicy options) rawResults where rawResults =- case verificationMode options of- VerificationBatch ->- verifyPacketsBatch keyring (verificationTime options) packets- VerificationStreaming ->- runConduitPure $- CL.sourceList packets .|- verifyPacketsWithModeTyped VerificationStreamingW- keyring- (verificationTime options) .|- CL.consume+ case verificationMode options of+ VerificationBatch ->+ verifyPacketsBatch keyring (verificationTime options) packets+ VerificationStreaming ->+ runConduitPure $+ CL.sourceList packets+ .| verifyPacketsWithModeTyped+ VerificationStreamingW+ keyring+ (verificationTime options)+ .| CL.consume -verifyMessage ::- VerificationOptions- -> PublicKeyring- -> BL.ByteString- -> [Either VerificationError Verification]+verifyMessage+ :: VerificationOptions+ -> PublicKeyring+ -> BL.ByteString+ -> [Either VerificationError Verification] verifyMessage options keyring signedMessage =- verifyMessagePackets- options- keyring- (concatMap (either (const []) id . decompressPkt) (parsePkts signedMessage))+ verifyMessagePackets+ options+ keyring+ ( concatMap+ (either (const []) id . decompressPkt)+ (parsePkts signedMessage)+ ) -applyVerificationPolicy ::- VerificationPolicy- -> [Either VerificationError Verification]- -> [Either VerificationError Verification]+applyVerificationPolicy+ :: VerificationPolicy+ -> [Either VerificationError Verification]+ -> [Either VerificationError Verification] applyVerificationPolicy VerifyInformational results = results applyVerificationPolicy VerifyStrict results =- either (pure . Left) (Right <$>) (sequence results)+ either (pure . Left) (Right <$>) (sequence results)
Data/Conduit/OpenPGP/Verify.hs view
@@ -27,8 +27,7 @@ ( defaultVerificationPolicy ) import Codec.Encryption.OpenPGP.Signatures- ( VerificationError (..)- , verifyAgainstKeyring+ ( verifyAgainstKeyring , verifySigWith ) import Codec.Encryption.OpenPGP.Types@@ -124,10 +123,19 @@ Nothing -> (state, []) pushPacketTyped _ _ (OtherPacketPkt t _) state | t < 40 =- (state, [Left (UnknownCriticalPacketInStream t)])+ ( state+ ,+ [ Left (VerificationCriticalPacketError (UnknownCriticalPacket t))+ ]+ ) pushPacketTyped _ _ (BrokenPacketPkt err t _) state | t < 40 =- (state, [Left (BrokenCriticalPacketInStream t err)])+ ( state+ ,+ [ Left+ (VerificationCriticalPacketError (BrokenCriticalPacket t err))+ ]+ ) pushPacketTyped _ _ pkt@(OnePassSignaturePkt _) state | isOpeningOnePassSignature pkt = (state, []) pushPacketTyped _ _ _ state = (state, [])
hOpenPGP.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP-Version: 3.5.1+Version: 3.6 Synopsis: native Haskell implementation of OpenPGP (RFC9580) Description: native Haskell implementation of OpenPGP (RFC9580), with some backwards compatibility Homepage: https://salsa.debian.org/clint/hOpenPGP@@ -258,11 +258,12 @@ , Codec.Encryption.OpenPGP.Internal.Whitespace , Codec.Encryption.OpenPGP.Types.Internal.Base , Codec.Encryption.OpenPGP.Types.Internal.CryptonNewtypes- , Codec.Encryption.OpenPGP.Types.Internal.PKITypes- , Codec.Encryption.OpenPGP.Types.Internal.PacketClass- , Codec.Encryption.OpenPGP.Types.Internal.Pkt- , Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils- , Codec.Encryption.OpenPGP.Types.Internal.TK+ , Codec.Encryption.OpenPGP.Types.Internal.PKITypes+ , Codec.Encryption.OpenPGP.Types.Internal.Errors+ , Codec.Encryption.OpenPGP.Types.Internal.PacketClass+ , Codec.Encryption.OpenPGP.Types.Internal.Pkt+ , Codec.Encryption.OpenPGP.Types.Internal.PrettyUtils+ , Codec.Encryption.OpenPGP.Types.Internal.TK , Codec.Encryption.OpenPGP.BlockCipher , Codec.Encryption.OpenPGP.SerializeForSigs , Paths_hOpenPGP@@ -345,4 +346,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v3.5.1+ tag: v3.6
tests/Tests/Common.hs view
@@ -82,7 +82,6 @@ , testDecryptWithDecryptPolicy , deriveECDHKekForTest , doPkeyAndSkeyMatch- , forceVersionedRecipientIdentifier , isPrecedingESK , mkPKESKSessionMaterialOrFail , readFixtureStrict@@ -151,9 +150,6 @@ ) import Codec.Encryption.OpenPGP.Arbitrary ()-import Codec.Encryption.OpenPGP.BlockCipher- ( renderCipherError- ) import Codec.Encryption.OpenPGP.Compression (decompressPkt) import Codec.Encryption.OpenPGP.Encrypt ( PKESKSessionMaterial@@ -181,7 +177,6 @@ ( ClearPayload , EncryptMessageOptions (..) , EncryptedPayload- , MessageError (..) , RecoveredSessionMaterial (..) , SessionMaterialExposure (..) , VersionedPKPayload@@ -202,10 +197,7 @@ ) import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig) import Codec.Encryption.OpenPGP.Signatures- ( VerificationError (..)- , renderSignError- , renderVerificationError- , signCertRevocation+ ( signCertRevocation , signDataWithEd25519 , signDataWithRSA , signDirectKey@@ -418,7 +410,7 @@ KeyIdentifierFingerprint rid -> PKESKPkt ( PKESKPayloadV6Packet- (PKESKPayloadV6 (unFingerprint rid) pka mempty)+ (PKESKPayloadV6 (Just (V6, rid)) pka (EncryptedSessionKey mempty)) ) readFixturePayload :: FilePath -> IO BL.ByteString@@ -558,15 +550,14 @@ _ -> False matchesRecipientIdentifier- :: B.ByteString -> PKESKRecipientKey -> Bool-matchesRecipientIdentifier rid keyInfo =+ :: Maybe (KeyVersion, Fingerprint) -> PKESKRecipientKey -> Bool+matchesRecipientIdentifier mKvFp keyInfo = case pkeskRecipientPKPayload keyInfo of Nothing -> False Just pkp ->- let fingerprintBytes = unFingerprint (fingerprint pkp)- in rid == fingerprintBytes- || rid == B.cons 0x04 fingerprintBytes- || rid == B.cons 0x06 fingerprintBytes+ case mKvFp of+ Nothing -> True+ Just (_, fp) -> fp == fingerprint pkp buildECDHKDFParamForTest :: SomePKPayload@@ -825,7 +816,7 @@ case eightOctetKeyID signer of Left err -> assertFailure- ("failed to derive issuer key id for timeline test: " ++ err)+ ("failed to derive issuer key id for timeline test: " ++ show err) >> fail "expected issuer key id" Right issuerKeyId -> pure@@ -1029,10 +1020,17 @@ >> fail "expected armored payload" let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload)) case packets of- [ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))+ [ PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 mKvFp pka _)) , SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize _ _) ] -> do- let ridHex = map toUpper (BLC8.unpack (B16L.encode (BL.fromStrict rid)))+ let ridHex =+ map+ toUpper+ ( BLC8.unpack+ ( B16L.encode+ (BL.fromStrict (maybe mempty (unFingerprint . snd) mKvFp))+ )+ ) if ridHex `elem` [ "C8263FC6D676044B6E973959C2F2C2CAE30DE908" , "04C8263FC6D676044B6E973959C2F2C2CAE30DE908"@@ -1078,27 +1076,14 @@ , passphrase ) -forceVersionedRecipientIdentifier :: Pkt -> Pkt-forceVersionedRecipientIdentifier pkt =- case pkt of- PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk))- | B.length rid == 20 ->- PKESKPkt- (PKESKPayloadV6Packet (PKESKPayloadV6 (B.cons 0x04 rid) pka esk))- | B.length rid == 32 ->- PKESKPkt- (PKESKPayloadV6Packet (PKESKPayloadV6 (B.cons 0x06 rid) pka esk))- | otherwise -> pkt- _ -> pkt- selectRecipientKeyInfoByRawRecipientId :: Pkt -> [PKESKRecipientKey] -> Maybe PKESKRecipientKey-selectRecipientKeyInfoByRawRecipientId (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) keyInfos =+selectRecipientKeyInfoByRawRecipientId (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 mKvFp pka _))) keyInfos = listToMaybe [ keyInfo | keyInfo <- keyInfos , supportsPKESKAlgorithm pka keyInfo- , matchesRawRecipientFingerprint rid keyInfo+ , matchesRecipientKeyIdentifier mKvFp keyInfo ] selectRecipientKeyInfoByRawRecipientId (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) keyInfos | isWildcardEightOctetKeyId rid =@@ -1114,13 +1099,15 @@ ] selectRecipientKeyInfoByRawRecipientId _ keyInfos = listToMaybe keyInfos -matchesRawRecipientFingerprint- :: B.ByteString -> PKESKRecipientKey -> Bool-matchesRawRecipientFingerprint rid keyInfo =+matchesRecipientKeyIdentifier+ :: Maybe (KeyVersion, Fingerprint) -> PKESKRecipientKey -> Bool+matchesRecipientKeyIdentifier mKvFp keyInfo = case pkeskRecipientPKPayload keyInfo of Nothing -> False Just pkp ->- rid == unFingerprint (fingerprint pkp)+ case mKvFp of+ Nothing -> False+ Just (_, fp) -> fp == fingerprint pkp testSEIPDv2TwoRecipientsArmor :: Assertion testSEIPDv2TwoRecipientsArmor =@@ -1160,18 +1147,24 @@ >> fail "expected armored payload" let packets = parsePkts (BL.fromStrict (BLC8.toStrict payload)) pkesks =- [ (rid, pka)- | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _)) <-+ [ (mKvFp, pka)+ | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 mKvFp pka _)) <- packets ] x25519Esks = [ esk- | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 esk)) <-+ | PKESKPkt+ ( PKESKPayloadV6Packet+ (PKESKPayloadV6 _ X25519 (EncryptedSessionKey esk))+ ) <- packets ] x448Esks = [ esk- | PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 esk)) <-+ | PKESKPkt+ ( PKESKPayloadV6Packet+ (PKESKPayloadV6 _ X448 (EncryptedSessionKey esk))+ ) <- packets ] seipdv2Packets =@@ -1203,9 +1196,12 @@ mapM_ (assertX25519EskShape file) x25519Esks mapM_ (assertX448EskShape file) x448Esks if all- ( \(rid, _) ->- let l = B.length rid- in l == 20 || l == 21 || l == 32 || l == 33+ ( \(mKvFp, _) ->+ case mKvFp of+ Nothing -> False+ Just (_, fp) ->+ let l = B.length (unFingerprint fp)+ in l == 20 || l == 32 ) pkesks then pure ()@@ -1260,10 +1256,12 @@ prependUnusableLatestPKESK :: [Pkt] -> [Pkt] prependUnusableLatestPKESK packets =- let bogusRid = B.pack (0x06 : replicate 32 0x99)+ let bogusRid = Just (V6, Fingerprint (B.pack (0x06 : replicate 32 0x99))) bogusPKESK = PKESKPkt- (PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk"))+ ( PKESKPayloadV6Packet+ (PKESKPayloadV6 bogusRid RSA (EncryptedSessionKey "bogus-esk"))+ ) (eskPrefix, encryptedSuffix) = span isPrecedingESK packets in eskPrefix ++ [bogusPKESK] ++ encryptedSuffix @@ -1481,7 +1479,7 @@ cgp = conduitGet (get :: Get Pkt) fp :: Text -> Fingerprint-fp = either error id . parseFingerprint+fp = either (error . show) id . parseFingerprint doPkeyAndSkeyMatch :: PKey -> SKey -> Assertion doPkeyAndSkeyMatch (RSAPubKey (RSA_PublicKey rpub)) (RSAPrivateKey (RSA_PrivateKey rpriv)) =
tests/Tests/Encryption.hs view
@@ -61,30 +61,15 @@ ) import Codec.Encryption.OpenPGP.CFB import Codec.Encryption.OpenPGP.Compression- ( CompressionError (..)- , compressPkts+ ( compressPkts , decompressPkt ) import Codec.Encryption.OpenPGP.Encrypt ( EncryptCompatibilityProfileW (..)- , PKESKEncryptError- ( InvalidRecipientIdentifier- , InvalidRecipientKeyMaterial- , PayloadBuildFailure- , RecipientCapabilitySelectionFailure- , RecipientKdfFailure- , UnsupportedRecipientAlgorithm- ) , PKESKVersionPolicy (..) , PassphraseEncryptRequest (..) , PassphraseSKESKVersionPolicy (..) , RecipientCapabilities (..)- , RecipientCapabilityError- ( RecipientCapabilityMissingSEIPDv1Support- , RecipientCapabilityNoCommonAEADAlgorithms- , RecipientCapabilityNoCommonSymmetricAlgorithms- , RecipientCapabilityNoEncryptableKeyMaterialInTK- ) , RecipientCapabilityNegotiationMode (..) , RecipientEncryptRequest (..) , RecipientEncryptRequestOverrides (..)@@ -99,7 +84,6 @@ , SomeRecipientPKESKVersionStrategyW (..) , buildPKESKPayloadForRecipient , buildPKESKv3PayloadForRecipient- , canonicalizePKESKRecipientId , defaultRecipientPayloadShape , deriveX25519Kek , deriveX448Kek@@ -142,22 +126,16 @@ , lenientDecryptPolicy ) import Codec.Encryption.OpenPGP.S2K- ( EncodedSessionKeyError (..)- , S2KError (..)- , decodeOpenPGPEncodedSessionKey- , renderS2KError+ ( decodeOpenPGPEncodedSessionKey , skesk2SessionKey , string2Key ) import Codec.Encryption.OpenPGP.SEIPDv1 ( mdcTrailerForSEIPDv1- , renderMDCFailure , seipdv1NonceFromIV , validateSEIPD1MDC )-import Codec.Encryption.OpenPGP.SEIPDv2- ( renderSEIPDv2Failure- )+import Codec.Encryption.OpenPGP.SEIPDv2 () import Codec.Encryption.OpenPGP.SecretKey ( SecretKeyEncryptOptions (..) , decryptSecretKeyAddendum@@ -165,6 +143,9 @@ ) import Codec.Encryption.OpenPGP.Serialize (parsePkts) import Codec.Encryption.OpenPGP.Types+import Codec.Encryption.OpenPGP.Types.Internal.Errors+ ( PacketCoercionError (..)+ ) import Data.Conduit.OpenPGP.Compression (conduitCompress) import Data.Conduit.OpenPGP.Decrypt ( DecryptKeyResolution (..)@@ -192,7 +173,6 @@ , doPkeyAndSkeyMatch , encryptMessageDefault , fixturePath- , forceVersionedRecipientIdentifier , isPrecedingESK , loadArmor , loadDeterministicEd25519Signer@@ -835,15 +815,9 @@ "encryptForRecipients with EncryptInteropLegacy produces SEIPDv1 and PKESKv3" testEncryptInteropLegacyProducesSEIPDv1 , testCase- "encrypt-side PKESK builder reports unsupported recipient algorithms"- testBuildPKESKPayloadUnsupportedRecipient- , testCase "encrypt-side ECDH PKESK builder rejects SHA1 KDF policy" testBuildPKESKPayloadRejectsECDHSHA1 , testCase- "encrypt-side canonicalize PKESK recipient id helper"- testCanonicalizePKESKRecipientIdHelper- , testCase "testDecrypt decrypts seipdv2 fixture with matching v6 secret key" testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey , testCase@@ -998,10 +972,13 @@ ) >> fail "empty fixture packet list" (firstPkt : _) ->- case (fromPktEither firstPkt :: Either String (SKESK 'SKESKV4)) of+ case ( fromPktEither firstPkt+ :: Either PacketCoercionError (SKESK 'SKESKV4)+ ) of Left err ->- assertFailure ("failed to coerce first packet to SKESK: " ++ err)- >> fail err+ assertFailure+ ("failed to coerce first packet to SKESK: " ++ show err)+ >> fail (show err) Right x -> pure x assertEqual "first packet should be SKESK"@@ -1031,11 +1008,13 @@ assertFailure ("decryption produced no packets for " ++ encfile) >> fail "expected decrypted literal packet" (firstDecrypted : _) ->- case (fromPktEither firstDecrypted :: Either String LiteralData) of+ case ( fromPktEither firstDecrypted+ :: Either PacketCoercionError LiteralData+ ) of Left err -> assertFailure- ("failed to coerce decrypted packet to literal data: " ++ err)- >> fail err+ ("failed to coerce decrypted packet to literal data: " ++ show err)+ >> fail (show err) Right x -> pure (_literalDataPayload x) assertEqual ("cleartext for " ++ encfile) cleartext payload where@@ -1113,10 +1092,13 @@ ) >> fail "empty fixture packet list" (firstPkt : _) ->- case (fromPktEither firstPkt :: Either String (SKESK 'SKESKV4)) of+ case ( fromPktEither firstPkt+ :: Either PacketCoercionError (SKESK 'SKESKV4)+ ) of Left err ->- assertFailure ("failed to coerce first packet to SKESK: " ++ err)- >> fail err+ assertFailure+ ("failed to coerce first packet to SKESK: " ++ show err)+ >> fail (show err) Right x -> pure x assertEqual "first packet should be SKESK"@@ -1154,11 +1136,13 @@ assertFailure ("decryption produced no packets for " ++ encfile) >> fail "expected decrypted literal packet" (firstDecrypted : _) ->- case (fromPktEither firstDecrypted :: Either String LiteralData) of+ case ( fromPktEither firstDecrypted+ :: Either PacketCoercionError LiteralData+ ) of Left err -> assertFailure- ("failed to coerce decrypted packet to literal data: " ++ err)- >> fail err+ ("failed to coerce decrypted packet to literal data: " ++ show err)+ >> fail (show err) Right x -> pure (_literalDataPayload x) assertEqual ("cleartext for " ++ encfile) cleartext payload where@@ -1497,11 +1481,11 @@ ("no packets found in secret key fixture " ++ keyfile) >> fail "empty secret key fixture" (firstPkt : _) ->- case (fromPktEither firstPkt :: Either String SecretKey) of+ case (fromPktEither firstPkt :: Either PacketCoercionError SecretKey) of Left err -> assertFailure- ("failed to coerce key packet to SecretKey: " ++ err)- >> fail err+ ("failed to coerce key packet to SecretKey: " ++ show err)+ >> fail (show err) Right x -> pure x decryptedSKey <- case decryptSecretKeyAddendum pkp ska (Passphrase passphrase) of@@ -1593,7 +1577,8 @@ SecretKey pkp ska <- case [ sk | pkt <- packets- , Right sk <- [fromPktEither pkt :: Either String SecretKey]+ , Right sk <-+ [fromPktEither pkt :: Either PacketCoercionError SecretKey] ] of (sk : _) -> pure sk [] ->@@ -1877,19 +1862,20 @@ >> fail "buildPKESKPayloadForRecipient failed" Right p -> pure p case pkeskPayload of- PKESKPayloadV6Packet (PKESKPayloadV6 _ RSA eskBytesLazy) -> do- let eskBytes = eskBytesLazy- assertBool- "PKESKv6 RSA ESK should include MPI framing"- (B.length eskBytes >= 2)- let mpiBits =- fromIntegral (B.index eskBytes 0) * 256- + fromIntegral (B.index eskBytes 1)- mpiLen = (mpiBits + 7) `div` 8- assertEqual- "PKESKv6 RSA ESK should be exactly one RFC9580 MPI"- (2 + mpiLen)- (B.length eskBytes)+ PKESKPayloadV6Packet+ (PKESKPayloadV6 _ RSA (EncryptedSessionKey eskBytesLazy)) -> do+ let eskBytes = eskBytesLazy+ assertBool+ "PKESKv6 RSA ESK should include MPI framing"+ (B.length eskBytes >= 2)+ let mpiBits =+ fromIntegral (B.index eskBytes 0) * 256+ + fromIntegral (B.index eskBytes 1)+ mpiLen = (mpiBits + 7) `div` 8+ assertEqual+ "PKESKv6 RSA ESK should be exactly one RFC9580 MPI"+ (2 + mpiLen)+ (B.length eskBytes) other -> assertFailure ("Expected PKESKv6 RSA payload, got " ++ show other)@@ -2015,7 +2001,7 @@ Left err -> assertFailure ( "Expected v6 key-id from fingerprint derivation to succeed: "- ++ err+ ++ show err ) >> fail "expected v6 key-id from fingerprint" Right keyId -> pure keyId@@ -2426,7 +2412,9 @@ ++ show err ) Right- (PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 eskBytesLazy)) -> do+ ( PKESKPayloadV6Packet+ (PKESKPayloadV6 _ X25519 (EncryptedSessionKey eskBytesLazy))+ ) -> do let eskBytes = eskBytesLazy assertX25519EskShape "v6 X25519 raw-key conformance" eskBytes let wrappedLen = fromIntegral (B.index eskBytes 32) :: Int@@ -2474,14 +2462,17 @@ Left err -> assertFailure ("buildPKESKPayloadForRecipient failed for v6 X448: " ++ show err)- Right (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 eskBytesLazy)) -> do- let eskBytes = eskBytesLazy- assertX448EskShape "v6 X448 raw-key conformance" eskBytes- let wrappedLen = fromIntegral (B.index eskBytes 56) :: Int- assertEqual- "v6 X448 wrapped session key (AES-KW RFC3394 of raw 32 bytes) must be 40 bytes"- 40- wrappedLen+ Right+ ( PKESKPayloadV6Packet+ (PKESKPayloadV6 _ X448 (EncryptedSessionKey eskBytesLazy))+ ) -> do+ let eskBytes = eskBytesLazy+ assertX448EskShape "v6 X448 raw-key conformance" eskBytes+ let wrappedLen = fromIntegral (B.index eskBytes 56) :: Int+ assertEqual+ "v6 X448 wrapped session key (AES-KW RFC3394 of raw 32 bytes) must be 40 bytes"+ 40+ wrappedLen Right other -> assertFailure ("Expected PKESKPayloadV6 with X448, got " ++ show other)@@ -3838,13 +3829,13 @@ } result <- encryptForRecipients request case result of- Left (PayloadBuildFailure err) ->+ Left (PayloadBuildFailureOPSBuild err) -> assertBool "missing issuer metadata should surface as payload build failure"- ("without issuer metadata" `isInfixOf` err)+ ("without issuer metadata" `isInfixOf` renderOPSBuildError err) Left err -> assertFailure- ( "Expected PayloadBuildFailure for missing OPS issuer metadata, got "+ ( "Expected PayloadBuildFailureOPSBuild for missing OPS issuer metadata, got " ++ show err ) Right _ ->@@ -3916,63 +3907,6 @@ assertFailure ("Expected [LiteralData] from legacy decrypt, got " ++ show other) -testCanonicalizePKESKRecipientIdHelper :: Assertion-testCanonicalizePKESKRecipientIdHelper = do- let rid = B.pack (0x04 : replicate 20 0x11)- payload = PKESKPayloadV6Packet (PKESKPayloadV6 rid RSA "esk")- case canonicalizePKESKRecipientId payload of- Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _))- | B.length normalized == 20 -> pure ()- | otherwise ->- assertFailure- ( "Expected canonicalized recipient id length 20, got "- ++ show (B.length normalized)- )- Left err ->- assertFailure- ("canonicalizePKESKRecipientId failed unexpectedly: " ++ show err)- Right other ->- assertFailure- ( "Expected PKESK6 payload after canonicalization, got "- ++ show other- )- case canonicalizePKESKRecipientId- ( PKESKPayloadV6Packet- (PKESKPayloadV6 (B.replicate 19 0x22) RSA "esk")- ) of- Left (InvalidRecipientIdentifier _) -> pure ()- other ->- assertFailure- ( "Expected InvalidRecipientIdentifier for malformed rid, got "- ++ show other- )- case canonicalizePKESKRecipientId- ( PKESKPayloadV6Packet- (PKESKPayloadV6 (B.pack (0x06 : replicate 32 0x33)) RSA "esk")- ) of- Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _))- | B.length normalized == 32 -> pure ()- | otherwise ->- assertFailure- ( "Expected canonicalized v6 recipient id length 32, got "- ++ show (B.length normalized)- )- other ->- assertFailure- ( "Expected 0x06-prefixed v6 recipient id to canonicalize, got "- ++ show other- )- case canonicalizePKESKRecipientId- ( PKESKPayloadV6Packet- (PKESKPayloadV6 (B.pack (0x04 : replicate 32 0x44)) RSA "esk")- ) of- Left (InvalidRecipientIdentifier _) -> pure ()- other ->- assertFailure- ( "Expected InvalidRecipientIdentifier for mismatched v4-prefixed v6-length rid, got "- ++ show other- )- testBuildPKESKPayloadUnsupportedRecipient :: Assertion testBuildPKESKPayloadUnsupportedRecipient = do let recipient =@@ -4158,10 +4092,16 @@ (messagePackets, encryptedSecretPackets, passphrase) <- loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa" let- bogusRid = B.pack (0x06 : replicate 32 0x99)+ bogusRid = B.replicate 32 0x99 bogusPKESK = PKESKPkt- (PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk"))+ ( PKESKPayloadV6Packet+ ( PKESKPayloadV6+ (Just (V6, Fingerprint bogusRid))+ RSA+ (EncryptedSessionKey "bogus-esk")+ )+ ) (eskPrefix, encryptedSuffix) = span isPrecedingESK messagePackets packetsWithBogusLatestPKESK = eskPrefix ++ [bogusPKESK] ++ encryptedSuffix passphraseCallback _ = pure B.empty@@ -4193,10 +4133,9 @@ testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations :: Assertion testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations = do- (messagePacketsRaw, encryptedSecretPackets, passphrase) <-+ (messagePackets, encryptedSecretPackets, passphrase) <- loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa"- let messagePackets = map forceVersionedRecipientIdentifier messagePacketsRaw- passphraseCallback _ = pure B.empty+ let passphraseCallback _ = pure B.empty keyInfos <- collectSecretKeyInfos encryptedSecretPackets passphrase let keyContextCallback pkt = pure (selectRecipientKeyInfoByRawRecipientId pkt keyInfos)@@ -4344,9 +4283,14 @@ [ PKESKPkt ( PKESKPayloadV6Packet ( PKESKPayloadV6- "\x01\x02\x03\x04\x05\x06\x07\x08"+ ( Just+ ( V4+ , Fingerprint+ "\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f\x10\x11\x12\x13\x14"+ )+ ) RSA- "\x99\x88\x77"+ (EncryptedSessionKey "\x99\x88\x77") ) ) , SymEncIntegrityProtectedDataPkt@@ -4399,9 +4343,14 @@ [ PKESKPkt ( PKESKPayloadV6Packet ( PKESKPayloadV6- "\x10\x11\x12\x13\x14\x15\x16\x17"+ ( Just+ ( V4+ , Fingerprint+ "\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22"+ )+ ) RSA- "\x01\x02\x03"+ (EncryptedSessionKey "\x01\x02\x03") ) ) , SymEncIntegrityProtectedDataPkt@@ -6856,7 +6805,11 @@ pkesk = PKESKPkt ( PKESKPayloadV6Packet- (PKESKPayloadV6 recipientRid X448 esk)+ ( PKESKPayloadV6+ (Just (V6, Fingerprint recipientRid))+ X448+ (EncryptedSessionKey esk)+ ) ) ciphertext <- case encryptSEIPDv2Payload@@ -6868,6 +6821,19 @@ (BL.toStrict (runPut (put literalBlock))) of Left err -> assertFailure+ ("encryptSEIPDv2Payload failed: " ++ show err)+ >> pure BL.empty+ Right _ -> pure BL.empty+ ciphertext <-+ case encryptSEIPDv2Payload+ AES256+ OCB+ 6+ salt+ (SessionKey sessionKey)+ (BL.toStrict (runPut (put literalBlock))) of+ Left err ->+ assertFailure ("encryptSEIPDv2Payload failed: " ++ renderSEIPDv2Failure err) >> pure mempty Right ct -> pure ct@@ -6962,8 +6928,25 @@ pkesk = PKESKPkt ( PKESKPayloadV6Packet- (PKESKPayloadV6 recipientRid X448 esk)+ ( PKESKPayloadV6+ (Just (V6, Fingerprint recipientRid))+ X448+ (EncryptedSessionKey esk)+ ) )+ ciphertext <-+ case encryptSEIPDv2Payload+ AES256+ OCB+ 6+ salt+ (SessionKey sessionKey)+ (BL.toStrict (runPut (put literalBlock))) of+ Left err ->+ assertFailure+ ("encryptSEIPDv2Payload failed: " ++ show err)+ >> pure BL.empty+ Right _ -> pure BL.empty ciphertext <- case encryptSEIPDv2Payload AES256
tests/Tests/KeyGeneration.hs view
@@ -108,7 +108,7 @@ roundTripAssertion label pkp skey = do put <- either- (assertFailure . ("serialize failed: " ++))+ (assertFailure . ("serialize failed: " ++) . renderSerializeError) pure (putSKeyForPKPayload pkp skey) let bs = runPut put
tests/Tests/Keys.hs view
@@ -811,7 +811,7 @@ builderRsaUnsupportedFinal signingKey "test payload" of- Left (SignBackendError _) -> pure ()+ Left (SignBackendErrorUnsupportedHash _) -> pure () Left err -> assertFailure ( "RSA builder API should reject unsupported hash with backend error, got "@@ -946,7 +946,7 @@ Left err -> assertFailure ( "failed to derive issuer key id for legal-subpacket builder test: "- ++ err+ ++ show err ) >> fail "expected issuer key id" Right i -> pure i@@ -2038,7 +2038,8 @@ issuerKeyId <- case eightOctetKeyID signer of Left err ->- assertFailure ("failed to derive RSA issuer key id: " ++ err)+ assertFailure+ ("failed to derive RSA issuer key id: " ++ show err) >> fail "expected issuer key id" Right i -> pure i let sigPayload =@@ -2077,7 +2078,8 @@ issuerKeyId <- case eightOctetKeyID signer of Left err ->- assertFailure ("failed to derive RSA issuer key id: " ++ err)+ assertFailure+ ("failed to derive RSA issuer key id: " ++ show err) >> fail "expected issuer key id" Right i -> pure i let sigPayload =@@ -2275,14 +2277,16 @@ case mkUnencryptedSKAddendum pkp sk of Left err -> assertFailure- ("mkUnencryptedSKAddendum should succeed for fixture key: " ++ err)+ ( "mkUnencryptedSKAddendum should succeed for fixture key: "+ ++ renderSecretKeyError err+ ) Right (SUSUnprotected _ actualChecksum) -> do skPayload <- case putSKeyForPKPayload pkp sk of Left err -> assertFailure ( "failed to serialize secret key payload for checksum expectation: "- ++ err+ ++ renderSerializeError err ) >> fail "expected serializable secret key payload" Right payload -> pure payload@@ -2312,7 +2316,9 @@ (RSAPrivateKey (RSA_PrivateKey rsaPrivateKey)) of Left err -> assertFailure- ("mkUnencryptedSKAddendum should support v6 key payloads: " ++ err)+ ( "mkUnencryptedSKAddendum should support v6 key payloads: "+ ++ renderSecretKeyError err+ ) Right (SUSUnprotected _ checksum) -> assertEqual "v6 unencrypted addendum checksum should be zero"
tests/Tests/MessageAndArmor.hs view
@@ -67,15 +67,11 @@ ( defaultVerificationPolicy , signatureV6SaltSizeForHashAlgorithm )-import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key)+import Codec.Encryption.OpenPGP.S2K (string2Key) import Codec.Encryption.OpenPGP.SEIPDv1- ( renderMDCFailure- , validateSEIPD1MDC- )-import Codec.Encryption.OpenPGP.SEIPDv2- ( SEIPDv2Failure (..)- , renderSEIPDv2Failure+ ( validateSEIPD1MDC )+import Codec.Encryption.OpenPGP.SEIPDv2 () import Codec.Encryption.OpenPGP.Serialize ( armorPayloadsOfType , parsePkts@@ -92,11 +88,7 @@ , putSigTrailer ) import Codec.Encryption.OpenPGP.Signatures- ( SignError (..)- , VerificationError (..)- , renderSignError- , renderVerificationError- , signCertRevocation+ ( signCertRevocation , signDataWithEd25519 , signDataWithEd25519V6 , signDataWithEd448@@ -1285,10 +1277,13 @@ mkEncryptedPayload . runPut . put $ Block [OtherPacketPkt 39 "unknown-critical"] case decryptMessage passphrase encrypted of- Left (MessageParseFailureError (UnknownCriticalPacketType 39)) -> pure ()+ Left+ ( MessageParseFailureError+ (MessageParseCriticalPacketError (UnknownCriticalPacket 39))+ ) -> pure () Left err -> assertFailure- ( "Expected UnknownCriticalPacketType 39 parse failure, got "+ ( "Expected UnknownCriticalPacket 39 parse failure, got " ++ show err ) Right clear ->@@ -2267,7 +2262,7 @@ issuerKeyId <- case eightOctetKeyID signer of Left err ->- assertFailure ("failed to derive issuer key id: " ++ err)+ assertFailure ("failed to derive issuer key id: " ++ show err) >> fail "expected issuer key id" Right i -> pure i let payload = "line with trailing space \nno trailing space\n"@@ -2393,7 +2388,7 @@ issuerKeyId <- case eightOctetKeyID signer of Left err ->- assertFailure ("failed to derive issuer key id: " ++ err)+ assertFailure ("failed to derive issuer key id: " ++ show err) >> fail "expected issuer key id" Right i -> pure i let mixedPayload = "line1 \nline2\t \r\nline3 \nline4 \t"@@ -2594,7 +2589,8 @@ edIssuerKeyId <- case eightOctetKeyID edSigner of Left err ->- assertFailure ("failed to derive Ed25519 issuer key id: " ++ err)+ assertFailure+ ("failed to derive Ed25519 issuer key id: " ++ show err) >> fail "expected Ed25519 issuer key id" Right i -> pure i let edPayload = "primitive Ed25519 payload"@@ -2646,7 +2642,8 @@ ed448IssuerKeyId <- case eightOctetKeyID ed448Signer of Left err ->- assertFailure ("failed to derive Ed448 issuer key id: " ++ err)+ assertFailure+ ("failed to derive Ed448 issuer key id: " ++ show err) >> fail "expected Ed448 issuer key id" Right i -> pure i let ed448Payload = "primitive Ed448 payload"@@ -2727,7 +2724,8 @@ sigOther = SigVOther 77 "opaque-signature-body" assertPacketRoundTrip label expected pkt = case fromPktEitherSomeSignatureV pkt of- Left err -> assertFailure (label ++ " packet coercion failed: " ++ err)+ Left err ->+ assertFailure (label ++ " packet coercion failed: " ++ show err) Right (SomeSignatureV typedSig) -> assertEqual (label ++ " packet coercion preserves payload")
tests/Tests/Properties.hs view
@@ -20,9 +20,6 @@ import Test.Tasty (TestTree, localOption, testGroup) import qualified Test.Tasty.QuickCheck as QC -import Codec.Encryption.OpenPGP.Encrypt- ( canonicalizePKESKRecipientId- ) import Codec.Encryption.OpenPGP.KeyringParser ( parseTKsWithWireRep )@@ -176,8 +173,8 @@ False ) , QC.testProperty- "canonicalizePKESKRecipientId idempotence on valid v4/v6 recipient ids"- propertyCanonicalizePKESKRecipientIdIdempotent+ "PKESKv6 typed recipient identifier preserves fingerprint"+ propertyPKESKv6TypedRecipientIdentifier , localOption (QC.QuickCheckTests 10) ( QC.testProperty@@ -195,26 +192,22 @@ propertyParsePktsEitherRejectsTruncatedPacketStream ] -propertyCanonicalizePKESKRecipientIdIdempotent- :: Bool -> Bool -> [Word8] -> QC.Property-propertyCanonicalizePKESKRecipientIdIdempotent useV6 prefixed seedBytes =- case canonicalizePKESKRecipientId payload of- Left err ->- QC.counterexample- ("canonicalizePKESKRecipientId unexpectedly failed: " ++ show err)- False- Right canonical ->- QC.counterexample- "canonicalizePKESKRecipientId should be idempotent"- (canonicalizePKESKRecipientId canonical == Right canonical)+propertyPKESKv6TypedRecipientIdentifier+ :: Bool -> [Word8] -> QC.Property+propertyPKESKv6TypedRecipientIdentifier _ seedBytes =+ QC.counterexample+ "PKESKv6 typed recipient identifier should preserve fingerprint"+ (fingerprintMatches) where- targetLen = if useV6 then 32 else 20- versionOctet = if useV6 then 0x06 else 0x04+ targetLen = 32 ridBody = B.pack (take targetLen (seedBytes ++ repeat 0x00))- rid- | prefixed = B.cons versionOctet ridBody- | otherwise = ridBody- payload = PKESKPayloadV6Packet (PKESKPayloadV6 rid RSA "esk")+ fp = Fingerprint ridBody+ payload =+ PKESKPayloadV6Packet+ (PKESKPayloadV6 (Just (V6, fp)) RSA (EncryptedSessionKey "esk"))+ fingerprintMatches = case payload of+ PKESKPayloadV6Packet (PKESKPayloadV6 (Just (_, fp')) _ _) -> fp == fp'+ _ -> False propertyCanonicalizeTKStructuredStableAcrossReordering :: QC.NonNegative Int
tests/Tests/Serialization.hs view
@@ -65,10 +65,7 @@ , parsePktsWithWireRep ) import Codec.Encryption.OpenPGP.Signatures- ( VerificationError (..)- , renderSignError- , renderVerificationError- , signDataWithEd25519V6+ ( signDataWithEd25519V6 , verifyAgainstKeys , verifySigWith )@@ -700,7 +697,8 @@ testPKESKv6ParsesAsV6WithoutLegacyFallback :: Assertion testPKESKv6ParsesAsV6WithoutLegacyFallback = do- let recipientKeyIdentifier = B.pack (0x04 : replicate 20 0)+ let recipientFingerprint = B.replicate 20 0+ recipientKeyIdentifier = B.pack (0x04 : B.unpack recipientFingerprint) esk = "\x00\x00" encoded = runPut $ do@@ -714,12 +712,14 @@ case runGetTest (get :: Get Pkt) encoded of Right ( PKESKPkt- (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka parsedEsk))+ ( PKESKPayloadV6Packet+ (PKESKPayloadV6 mKvFp pka (EncryptedSessionKey parsedEsk))+ ) ) -> do assertEqual "PKESKv6 recipient key identifier"- recipientKeyIdentifier- rid+ (Just (V4, Fingerprint recipientFingerprint))+ mKvFp assertEqual "PKESKv6 algorithm" RSA pka assertEqual "PKESKv6 ESK payload" esk parsedEsk other ->@@ -1200,7 +1200,9 @@ case eightOctetKeyID pkp of Left err -> assertFailure- ("Expected v6 eight-octet key-id derivation to succeed: " ++ err)+ ( "Expected v6 eight-octet key-id derivation to succeed: "+ ++ show err+ ) >> fail "expected v6 eight-octet key-id" Right keyId -> pure keyId expectedKeyId <-@@ -1208,7 +1210,7 @@ Left err -> assertFailure ( "Expected v6 key-id from fingerprint derivation to succeed: "- ++ err+ ++ show err ) >> fail "expected v6 key-id from fingerprint" Right keyId -> pure keyId
tests/Tests/Utilities.hs view
@@ -42,8 +42,7 @@ , parseTKsWithWireRep ) import Codec.Encryption.OpenPGP.Serialize- ( PktParseError (..)- , WireRepInput (..)+ ( WireRepInput (..) , conduitParsePktsWithWireRep , dearmorIfAsciiArmored , dearmorIfAsciiArmoredLenient@@ -249,7 +248,8 @@ lbs <- readFixtureLazy fn let truncated = BL.take (BL.length lbs - 1) lbs case parsePktsEither truncated of- Left (PktParseError off msg) -> do+ Left pktErr@(PktParseError off reason) -> do+ let msg = renderPktParseError pktErr assertBool "parsePktsEither reports non-empty parse error messages" (not (null msg))