hOpenPGP 3.7 → 3.7.1
raw patch · 13 files changed
+495/−224 lines, 13 files
Files
- Codec/Encryption/OpenPGP/Encrypt.hs +69/−11
- Codec/Encryption/OpenPGP/Internal.hs +67/−15
- Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs +3/−1
- Codec/Encryption/OpenPGP/Policy.hs +0/−3
- Codec/Encryption/OpenPGP/Serialize.hs +109/−55
- Codec/Encryption/OpenPGP/Signatures.hs +85/−49
- Codec/Encryption/OpenPGP/Types/Internal/Base.hs +6/−6
- Data/Conduit/OpenPGP/Decrypt.hs +48/−33
- hOpenPGP.cabal +2/−2
- tests/Tests/Common.hs +2/−2
- tests/Tests/Encryption.hs +91/−11
- tests/Tests/MessageAndArmor.hs +1/−2
- tests/Tests/Serialization.hs +12/−34
Codec/Encryption/OpenPGP/Encrypt.hs view
@@ -18,6 +18,8 @@ , RecipientCapabilities (..) , recipientCapabilitiesFromSubpacketPayloads , recipientCapabilitySupportsEncryption+ , recipientCapabilityAdvertisesSEIPDv1Support+ , recipientCapabilityAdvertisesSEIPDv2Support , RecipientTargetRejectionReason (..) , RecipientEncryptionTargetRejected (..) , RecipientEncryptionTargetsReport (..)@@ -115,6 +117,7 @@ import Data.Binary.Put (runPut) import Data.Bits (shiftL) import qualified Data.ByteArray as BA+import Data.ByteArray.Sized (unSizedByteArray) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Containers.ListUtils (nubOrd)@@ -154,7 +157,8 @@ , keyIdFromFingerprint ) import Codec.Encryption.OpenPGP.Internal- ( checksum16Bytes+ ( bsToFixedWidth+ , checksum16BE , chunksOf8 , edPointBytes , encodeWord64be@@ -414,8 +418,7 @@ recipientCapabilityAdvertisesSEIPDv2Support :: RecipientCapabilities -> Bool recipientCapabilityAdvertisesSEIPDv2Support caps =- recipientCapabilityAdvertisesSEIPDv1Support caps- && Set.member FeatureSEIPDv2 (recipientCapabilityFeatures caps)+ Set.member FeatureSEIPDv2 (recipientCapabilityFeatures caps) data RecipientTargetSelectionPolicy = RecipientTargetSelectionFirstValid@@ -738,7 +741,7 @@ PKESKV3SessionMaterial ( B.singleton (fromFVal symalgo) <> keyBytes- <> checksum16Bytes keyBytes+ <> checksum16BE keyBytes ) mkPKESKV6RawSessionMaterial@@ -2207,10 +2210,18 @@ do recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint)+ ephSecretBS <- case bsToFixedWidth @32 ephSecretRaw of+ Nothing ->+ Left+ ( InvalidRecipientKeyMaterial+ ECDH+ "bsToFixedWidth @32: input exceeds target"+ )+ Just fwb -> Right (unSizedByteArray fwb) ephSecret <- first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError- $ C25519.secretKey (leftPadTo 32 ephSecretRaw)+ $ C25519.secretKey ephSecretBS recipientPub <- first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError@@ -2294,10 +2305,17 @@ do recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint)+ ephSecretBS <-+ note+ ( InvalidRecipientKeyMaterial+ ECDH+ "leftPadTo: input exceeds target"+ )+ (leftPadTo 32 ephSecretRaw) ephSecret <- first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError- $ C25519.secretKey (leftPadTo 32 ephSecretRaw)+ $ C25519.secretKey ephSecretBS recipientPub <- first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError@@ -2319,10 +2337,18 @@ do recipientPublicBytes <- normalizeX448Public (edPointBytes recipientPoint)+ ephSecretBS <- case bsToFixedWidth @56 ephSecretRaw of+ Nothing ->+ Left+ ( InvalidRecipientKeyMaterial+ ECDH+ "bsToFixedWidth @56: input exceeds target"+ )+ Just fwb -> Right (unSizedByteArray fwb) ephSecret <- first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError- $ C448.secretKey (leftPadTo 56 ephSecretRaw)+ $ C448.secretKey ephSecretBS recipientPub <- first (RecipientKeyWrapFailureCrypto ECDH) . CE.eitherCryptoError@@ -2365,10 +2391,18 @@ pure $ do recipientPublic <- extractX25519RecipientPublic recipient+ ephSecretBS <- case bsToFixedWidth @32 ephSecretRaw of+ Nothing ->+ Left+ ( InvalidRecipientKeyMaterial+ X25519+ "bsToFixedWidth @32: input exceeds target"+ )+ Just fwb -> Right (unSizedByteArray fwb) ephSecret <- first (RecipientKeyWrapFailureCrypto X25519) . CE.eitherCryptoError- $ C25519.secretKey (leftPadTo 32 ephSecretRaw)+ $ C25519.secretKey ephSecretBS recipientPub <- first (RecipientKeyWrapFailureCrypto X25519) . CE.eitherCryptoError@@ -2398,10 +2432,18 @@ pure $ do recipientPublic <- extractX448RecipientPublic recipient+ ephSecretBS <- case bsToFixedWidth @56 ephSecretRaw of+ Nothing ->+ Left+ ( InvalidRecipientKeyMaterial+ X448+ "bsToFixedWidth @56: input exceeds target"+ )+ Just fwb -> Right (unSizedByteArray fwb) ephSecret <- first (RecipientKeyWrapFailureCrypto X448) . CE.eitherCryptoError- $ C448.secretKey (leftPadTo 56 ephSecretRaw)+ $ C448.secretKey ephSecretBS recipientPub <- first (RecipientKeyWrapFailureCrypto X448) . CE.eitherCryptoError@@ -2436,10 +2478,18 @@ pure $ do recipientPublic <- extractX25519RecipientPublic recipient+ ephSecretBS <- case bsToFixedWidth @32 ephSecretRaw of+ Nothing ->+ Left+ ( InvalidRecipientKeyMaterial+ X25519+ "bsToFixedWidth @32: input exceeds target"+ )+ Just fwb -> Right (unSizedByteArray fwb) ephSecret <- first (RecipientKeyWrapFailureCrypto X25519) . CE.eitherCryptoError- $ C25519.secretKey (leftPadTo 32 ephSecretRaw)+ $ C25519.secretKey ephSecretBS recipientPub <- first (RecipientKeyWrapFailureCrypto X25519) . CE.eitherCryptoError@@ -2485,10 +2535,18 @@ pure $ do recipientPublic <- extractX448RecipientPublic recipient+ ephSecretBS <- case bsToFixedWidth @56 ephSecretRaw of+ Nothing ->+ Left+ ( InvalidRecipientKeyMaterial+ X448+ "bsToFixedWidth @56: input exceeds target"+ )+ Just fwb -> Right (unSizedByteArray fwb) ephSecret <- first (RecipientKeyWrapFailureCrypto X448) . CE.eitherCryptoError- $ C448.secretKey (leftPadTo 56 ephSecretRaw)+ $ C448.secretKey ephSecretBS recipientPub <- first (RecipientKeyWrapFailureCrypto X448) . CE.eitherCryptoError
Codec/Encryption/OpenPGP/Internal.hs view
@@ -2,13 +2,18 @@ -- Copyright © 2012-2026 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file).+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} module Codec.Encryption.OpenPGP.Internal ( checksum16- , checksum16Bytes+ , checksum16BE , chunksOf8 , curve2Curve , curveFromCurve@@ -26,6 +31,14 @@ , point2MBS , pubkeyToMPIs , xorBS+ -- Fixed-width byte arrays+ , FixedWidthBytes+ , byteWidth+ , intToFixedWidth+ , bsToFixedWidth+ , unSizedByteArray+ , putFixedWidthBytes+ , KnownNat ) where import Crypto.Number.Serialize (i2osp, os2ip)@@ -33,12 +46,20 @@ import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import qualified Crypto.PubKey.ECC.Types as ECCT import qualified Crypto.PubKey.RSA as RSA-import Data.Binary.Put (putWord64be, runPut)+import Data.Binary.Put (Put, putByteString, putWord64be, runPut) import Data.Bits (shiftR, xor, (.&.))+import Data.ByteArray.Sized+ ( SizedByteArray+ , sizedByteArray+ , unSizedByteArray+ )+import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.List (find)+import Data.Proxy (Proxy (..)) import Data.Word (Word16, Word64)+import GHC.TypeLits (KnownNat, Nat, natVal) import Codec.Encryption.OpenPGP.Ontology ( isIssuerSSP@@ -63,17 +84,11 @@ (OtherPacketPkt 0 "lastPrimaryKey placeholder") (OtherPacketPkt 0 "lastSubkey placeholder") -leftPadTo :: Int -> B.ByteString -> B.ByteString+leftPadTo :: Int -> B.ByteString -> Maybe B.ByteString leftPadTo targetLen bs- | B.length bs > targetLen =- error- ( "byte string length "- ++ show (B.length bs)- ++ " exceeds target "- ++ show targetLen- )+ | B.length bs > targetLen = Nothing | otherwise =- B.replicate (targetLen - B.length bs) 0 <> bs+ Just (B.replicate (targetLen - B.length bs) 0 <> bs) checksum16 :: B.ByteString -> Word16 checksum16 =@@ -82,8 +97,8 @@ (\acc octet -> (acc + fromIntegral octet) .&. (0xffff :: Int)) (0 :: Int) -checksum16Bytes :: B.ByteString -> B.ByteString-checksum16Bytes bs = B.cons hi (B.singleton lo)+checksum16BE :: B.ByteString -> B.ByteString+checksum16BE bs = B.cons hi (B.singleton lo) where chk = checksum16 bs hi = fromIntegral (chk `shiftR` 8)@@ -223,9 +238,11 @@ curveToCurveoidBS Curve448 = Right $ B.pack [0x2B, 0x65, 0x6F] point2MBS :: ECCT.Curve -> ECCT.PublicPoint -> Maybe B.ByteString-point2MBS curve (ECCT.Point x y) = Just $ B.concat [B.singleton 0x04, pad x, pad y]+point2MBS curve (ECCT.Point x y) = do+ xb <- leftPadTo coordBytes (i2osp x)+ yb <- leftPadTo coordBytes (i2osp y)+ return $ B.concat [B.singleton 0x04, xb, yb] where- pad n = leftPadTo coordBytes (i2osp n) coordBytes = (ECCT.curveSizeBits curve + 7) `div` 8 point2MBS _ ECCT.PointO = Nothing @@ -263,7 +280,21 @@ curve2Curve NISTP256 = ECCT.getCurveByName ECCT.SEC_p256r1 curve2Curve NISTP384 = ECCT.getCurveByName ECCT.SEC_p384r1 curve2Curve NISTP521 = ECCT.getCurveByName ECCT.SEC_p521r1+-- FIXME: This is a band-aid+curve2Curve Curve25519 = noECDSACurve+curve2Curve Curve448 = noECDSACurve +{- | A deliberately degenerate ECDSA curve sentinel, used only as a placeholder+for the phantom curve parameter of an ECDSA.PrivateKey that wraps a scalar+for a non-ECDSA (EdDSA/X25519/X448) recipient. It is never used in any+computation. It is intentionally not any named curve (not a NIST curve, etc.)+so that it cannot be confused with a real curve.+-}+noECDSACurve :: ECCT.Curve+noECDSACurve =+ ECCT.CurveFP+ (ECCT.CurvePrime 0 (ECCT.CurveCommon 0 0 ECCT.PointO 0 0))+ curveFromCurve :: ECCT.Curve -> ECCCurve curveFromCurve c | c == ECCT.getCurveByName ECCT.SEC_p256r1 = NISTP256@@ -272,3 +303,24 @@ xorBS :: B.ByteString -> B.ByteString -> B.ByteString xorBS a b = B.pack (B.zipWith xor a b)++-- | Fixed-width byte arrays with size known at compile time.+type FixedWidthBytes (n :: Nat) = SizedByteArray n ByteString++-- | Get the byte width of a @FixedWidthBytes n@ at runtime.+byteWidth :: forall n. KnownNat n => Int+byteWidth = fromIntegral (natVal (Proxy @n))++-- | Convert an 'Integer' to a 'FixedWidthBytes n', left-padding with zeros if needed.+intToFixedWidth+ :: forall n. KnownNat n => Integer -> Maybe (FixedWidthBytes n)+intToFixedWidth i = sizedByteArray =<< leftPadTo (byteWidth @n) (i2osp i)++-- | Convert a 'ByteString' to a 'FixedWidthBytes n', left-padding with zeros if needed.+bsToFixedWidth+ :: forall n. KnownNat n => ByteString -> Maybe (FixedWidthBytes n)+bsToFixedWidth bs = sizedByteArray =<< leftPadTo (byteWidth @n) bs++-- | Serialize a 'FixedWidthBytes n' using 'Put'.+putFixedWidthBytes :: FixedWidthBytes n -> Put+putFixedWidthBytes = putByteString . unSizedByteArray
Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs view
@@ -10,6 +10,7 @@ , deriveECDHKek ) where +import Control.Error.Util (note) import qualified Crypto.PubKey.ECC.ECDSA as ECDSA import Data.Bifunctor (first) import qualified Data.ByteString as B@@ -36,7 +37,8 @@ -> Either String B.ByteString normalizeMontgomeryPublic targetLen label bs | B.length bs == targetLen = Right bs- | B.length bs < targetLen = Right (leftPadTo targetLen bs)+ | B.length bs < targetLen =+ note "leftPadTo: input exceeds target" (leftPadTo targetLen bs) | B.length bs == targetLen + 1 && B.head bs == 0x40 = Right (B.tail bs) | otherwise = Left (label ++ show (B.length bs))
Codec/Encryption/OpenPGP/Policy.hs view
@@ -79,9 +79,6 @@ ) import Codec.Encryption.OpenPGP.SignatureQualities (sigType) import Codec.Encryption.OpenPGP.Types-import Codec.Encryption.OpenPGP.Types.Internal.Errors- ( CipherError (..)- ) data OpenPGPRFC = RFC2440
Codec/Encryption/OpenPGP/Serialize.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeApplications #-} module Codec.Encryption.OpenPGP.Serialize ( -- * Serialization functions@@ -77,6 +78,7 @@ , runPut ) import Data.Bits (shiftL, shiftR, testBit, (.&.), (.|.))+import Data.ByteArray.Sized (unSizedByteArray) import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL@@ -98,14 +100,18 @@ import Network.URI (nullURI, parseURI, uriToString) import Codec.Encryption.OpenPGP.Internal- ( curve2Curve+ ( byteWidth+ , checksum16+ , curve2Curve , curveFromCurve , curveToCurveoidBS , curveoidBSToCurve , curveoidBSToEdSigningCurve , edSigningCurveToCurveoidBS+ , intToFixedWidth , leftPadTo , pubkeyToMPIs+ , putFixedWidthBytes ) import Codec.Encryption.OpenPGP.Policy ( signatureV6SaltSizeForHashAlgorithm@@ -1609,14 +1615,19 @@ putPKESKv3SessionKeyMaterial pka mpis | pka `elem` [X25519, X448] , (ephMPI NE.:| [wrappedMPI]) <- mpis = do- let ephLen =- case pka of- X25519 -> 32- X448 -> 56- _ ->- error $- "unsupported fixed-size octet algorithm: " ++ show pka- putByteString (leftPadTo ephLen (i2osp (unMPI ephMPI)))+ let ephBS = case pka of+ X25519 ->+ maybe+ (error "intToFixedWidth @32: input exceeds target")+ unSizedByteArray+ (intToFixedWidth @32 (unMPI ephMPI))+ X448 ->+ maybe+ (error "intToFixedWidth @56: input exceeds target")+ unSizedByteArray+ (intToFixedWidth @56 (unMPI ephMPI))+ _ -> error "unsupported fixed-size octet algorithm"+ putByteString ephBS let eskBytes = i2osp (unMPI wrappedMPI) putWord8 (fromIntegral (B.length eskBytes)) putByteString eskBytes@@ -1630,7 +1641,11 @@ headDef (B.length rawWrapped) (filter (>= B.length rawWrapped) [32, 40, 48])- paddedWrapped = leftPadTo targetLen rawWrapped+ paddedWrapped <-+ maybe+ (error "leftPadTo: input exceeds target")+ pure+ (leftPadTo targetLen rawWrapped) putWord8 (fromIntegral (B.length paddedWrapped)) putByteString paddedWrapped | otherwise = F.mapM_ put mpis@@ -2340,12 +2355,20 @@ putPubkeyV6 :: PKey -> Put putPubkeyV6 (EdDSAPubKey P.EdSigningCurve25519 (NativeEPoint (EPoint x))) = do- let bs = leftPadTo 32 (i2osp x)- putWord32be . fromIntegral . B.length $ bs+ let bs =+ maybe+ (error "intToFixedWidth @32: input exceeds target")+ unSizedByteArray+ (intToFixedWidth @32 x)+ putWord32be (fromIntegral (byteWidth @32)) putByteString bs putPubkeyV6 (EdDSAPubKey P.EdSigningCurve448 (NativeEPoint (EPoint x))) = do- let bs = leftPadTo 57 (i2osp x)- putWord32be . fromIntegral . B.length $ bs+ let bs =+ maybe+ (error "intToFixedWidth @57: input exceeds target")+ unSizedByteArray+ (intToFixedWidth @57 x)+ putWord32be (fromIntegral (byteWidth @57)) putByteString bs putPubkeyV6 ( ECDHPubKey@@ -2353,8 +2376,12 @@ kha ksa ) = do- let bs = leftPadTo 32 (i2osp x)- putWord32be . fromIntegral . B.length $ bs+ let bs =+ maybe+ (error "intToFixedWidth @32: input exceeds target")+ unSizedByteArray+ (intToFixedWidth @32 x)+ putWord32be (fromIntegral (byteWidth @32)) putByteString bs put kha put ksa@@ -2364,8 +2391,12 @@ kha ksa ) = do- let bs = leftPadTo 56 (i2osp x)- putWord32be . fromIntegral . B.length $ bs+ let bs =+ maybe+ (error "intToFixedWidth @56: input exceeds target")+ unSizedByteArray+ (intToFixedWidth @56 x)+ putWord32be (fromIntegral (byteWidth @56)) putByteString bs put kha put ksa@@ -2486,12 +2517,16 @@ | otherwise = do MPI x <- get case _pubkey pkp of- EdDSAPubKey P.EdSigningCurve25519 _ ->- return $- EdDSAPrivateKey P.EdSigningCurve25519 (leftPadTo 32 (i2osp x))- EdDSAPubKey P.EdSigningCurve448 _ ->- return $- EdDSAPrivateKey P.EdSigningCurve448 (leftPadTo 57 (i2osp x))+ EdDSAPubKey P.EdSigningCurve25519 _ -> do+ bs <- case intToFixedWidth @32 x of+ Nothing -> fail "intToFixedWidth @32: input exceeds target"+ Just fwb -> pure (unSizedByteArray fwb)+ return $ EdDSAPrivateKey P.EdSigningCurve25519 bs+ EdDSAPubKey P.EdSigningCurve448 _ -> do+ bs <- case intToFixedWidth @57 x of+ Nothing -> fail "intToFixedWidth @57: input exceeds target"+ Just fwb -> pure (unSizedByteArray fwb)+ return $ EdDSAPrivateKey P.EdSigningCurve448 bs _ -> return $ UnknownSKey (BL.fromStrict (i2osp x)) getMLKEMPrivateKey :: SomePKPayload -> Get SKey@@ -2524,8 +2559,10 @@ Ed25519PrivateKey <$> getByteString 32 | otherwise = do MPI x <- get- return $- EdDSAPrivateKey P.EdSigningCurve25519 (leftPadTo 32 (i2osp x))+ bs <- case intToFixedWidth @32 x of+ Nothing -> fail "intToFixedWidth @32: input exceeds target"+ Just fwb -> pure (unSizedByteArray fwb)+ return $ EdDSAPrivateKey P.EdSigningCurve25519 bs getEd448PrivateKey :: SomePKPayload -> Get SKey getEd448PrivateKey pkp@@ -2709,7 +2746,9 @@ putPubkeyV4Fixed :: Int -> P.EdSigningCurve -> PKey -> Put putPubkeyV4Fixed targetLen expectedCurve (EdDSAPubKey curve (NativeEPoint (EPoint x))) | curve == expectedCurve =- putByteString (leftPadTo targetLen (i2osp x))+ case leftPadTo targetLen (i2osp x) of+ Nothing -> error "leftPadTo: input exceeds target"+ Just bs -> putByteString bs putPubkeyV4Fixed _ _ pk = putPubkey pk getSKAddendum :: SomePKPayload -> Get SKAddendum@@ -2757,7 +2796,7 @@ sk <- getSecretKey pkpSome checksum <- getWord16be let expectedChecksum =- checksum16Bytes (BL.toStrict (BL.take secretLen rest))+ checksum16 (BL.toStrict (BL.take secretLen rest)) when (checksum /= expectedChecksum) $ fail ( "legacy unencrypted secret-key checksum mismatch: expected "@@ -2782,7 +2821,7 @@ sk <- getSecretKey pkpSome checksum <- getWord16be let expectedChecksum =- checksum16Bytes (BL.toStrict (BL.take secretLen rest))+ checksum16 (BL.toStrict (BL.take secretLen rest)) when (checksum /= expectedChecksum) $ fail ( "legacy unencrypted secret-key checksum mismatch: expected "@@ -2957,19 +2996,10 @@ putLazyByteString skb putWord16be ( if checksum == 0- then checksum16Bytes (BL.toStrict skb)+ then checksum16 (BL.toStrict skb) else checksum ) -checksum16Bytes :: B.ByteString -> Word16-checksum16Bytes =- B.foldl'- ( \a b ->- fromIntegral- ((fromIntegral a + fromIntegral b) `mod` (65536 :: Integer))- )- 0- putSKAddendumForPKPayload :: SomePKPayload -> SKAddendum -> Put putSKAddendumForPKPayload pkp ska = case fromSKAddendumForPKPayload pkp ska of@@ -3545,21 +3575,33 @@ if pka == BTypes.Ed25519 then case NE.toList mpis of [MPI r, MPI s] -> do- putByteString (padN 32 r)- putByteString (padN 32 s)+ putFixedWidthBytes $+ maybe+ (error "intToFixedWidth @32: input exceeds target")+ id+ (intToFixedWidth @32 r)+ putFixedWidthBytes $+ maybe+ (error "intToFixedWidth @32: input exceeds target")+ id+ (intToFixedWidth @32 s) _ -> error "Ed25519 v4 signatures must have two MPIs" else if pka == BTypes.Ed448 then case NE.toList mpis of [MPI r, MPI s] -> do- putByteString (padN 57 r)- putByteString (padN 57 s)+ putFixedWidthBytes $+ maybe+ (error "intToFixedWidth @57: input exceeds target")+ id+ (intToFixedWidth @57 r)+ putFixedWidthBytes $+ maybe+ (error "intToFixedWidth @57: input exceeds target")+ id+ (intToFixedWidth @57 s) _ -> error "Ed448 v4 signatures must have two MPIs" else F.mapM_ put mpis- where- padN n i =- let bs = i2osp i- in B.replicate (max 0 (n - B.length bs)) 0 <> bs putSignaturePayload (SigV6 st pka ha salt hashed unhashed left16 mpis) = do let expectedSaltSize = maybe@@ -3596,21 +3638,33 @@ if pka == BTypes.Ed25519 then case NE.toList mpis of [MPI r, MPI s] -> do- putByteString (padN 32 r)- putByteString (padN 32 s)+ putFixedWidthBytes $+ maybe+ (error "intToFixedWidth @32: input exceeds target")+ id+ (intToFixedWidth @32 r)+ putFixedWidthBytes $+ maybe+ (error "intToFixedWidth @32: input exceeds target")+ id+ (intToFixedWidth @32 s) _ -> error "Ed25519 v6 signatures must have two MPIs" else if pka == BTypes.Ed448 then case NE.toList mpis of [MPI r, MPI s] -> do- putByteString (padN 57 r)- putByteString (padN 57 s)+ putFixedWidthBytes $+ maybe+ (error "intToFixedWidth @57: input exceeds target")+ id+ (intToFixedWidth @57 r)+ putFixedWidthBytes $+ maybe+ (error "intToFixedWidth @57: input exceeds target")+ id+ (intToFixedWidth @57 s) _ -> error "Ed448 v6 signatures must have two MPIs" else F.mapM_ put mpis- where- padN n i =- let bs = i2osp i- in B.replicate (max 0 (n - B.length bs)) 0 <> bs putSignaturePayload (SigVOther pv bs) = do putWord8 pv putLazyByteString bs
Codec/Encryption/OpenPGP/Signatures.hs view
@@ -88,6 +88,7 @@ import Data.Bifunctor (first) import Data.Binary.Put (runPut) import qualified Data.ByteArray as BA+import Data.ByteArray.Sized (sizedByteArray, unSizedByteArray) import qualified Data.ByteString as B import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL@@ -104,7 +105,13 @@ import Data.Time.Clock (UTCTime (..), addUTCTime, diffUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Word (Word16, Word8)-import GHC.TypeLits (ErrorMessage (..), TypeError)+import GHC.TypeLits+ ( ErrorMessage (..)+ , KnownNat+ , Nat+ , TypeError+ , type (+)+ ) import Codec.Encryption.OpenPGP.Expirations ( isPKTimeValidWithSelfSignatures@@ -116,8 +123,13 @@ , fingerprint ) import Codec.Encryption.OpenPGP.Internal- ( PktStreamContext (..)+ ( -- Fixed-width byte arrays+ FixedWidthBytes+ , PktStreamContext (..)+ , bsToFixedWidth+ , byteWidth , emptyPSC+ , intToFixedWidth , issuer , issuerFP , leftPadTo@@ -1235,74 +1247,100 @@ verificationError (SignatureMismatch ECDSA (fingerprint pub)) ecdsaVerify _ _ _ _ _ = verificationError (SignatureShapeMismatch ECDSA) ed25519Verify sigPka pub (r :| [s]) hd pkey bs =- case edPointToRawPublic 32 pkey of+ case edPointToRawPublic @32 pkey of Left BadPrefix -> verificationError (SignatureEncodingInvalidBadPrefix sigPka) Left (BadLength label expected actual) -> verificationError (SignatureEncodingInvalidLength sigPka label expected actual) Right rawPub ->- case cf2es (Ed25519.publicKey rawPub) of+ case cf2es (Ed25519.publicKey (unSizedByteArray rawPub)) of Left err -> verificationError (SignatureEncodingInvalidCrypto sigPka err) Right ep ->- case cf2es- ( Ed25519.signature- (leftPadTo 32 (i2osp (unMPI r)) <> leftPadTo 32 (i2osp (unMPI s)))- ) of- Left err ->- verificationError (SignatureEncodingInvalidCrypto sigPka err)- Right es ->- let prehash = crazyHash hd bs :: B.ByteString- in if Ed25519.verify ep prehash es- then Right pub- else- verificationError (SignatureMismatch sigPka (fingerprint pub))+ case ( intToFixedWidth @32 (unMPI r)+ , intToFixedWidth @32 (unMPI s)+ ) of+ (Just rBS, Just sBS) ->+ case cf2es+ ( Ed25519.signature+ (unSizedByteArray rBS <> unSizedByteArray sBS)+ ) of+ Left err ->+ verificationError+ (SignatureEncodingInvalidCrypto sigPka err)+ Right es ->+ let prehash = crazyHash hd bs :: B.ByteString+ in if Ed25519.verify ep prehash es+ then Right pub+ else+ verificationError+ (SignatureMismatch sigPka (fingerprint pub))+ _ ->+ verificationError+ (SignatureEncodingInvalidLength sigPka "intToFixedWidth" 32 0) ed25519Verify sigPka _ _ _ _ _ = verificationError (SignatureShapeMismatch sigPka) ed448Verify sigPka pub (r :| [s]) hd pkey bs =- case edPointToRawPublic 57 pkey of+ case edPointToRawPublic @57 pkey of Left BadPrefix -> verificationError (SignatureEncodingInvalidBadPrefix sigPka) Left (BadLength label expected actual) -> verificationError (SignatureEncodingInvalidLength sigPka label expected actual) Right rawPub ->- case cf2es (Ed448.publicKey rawPub) of+ case cf2es (Ed448.publicKey (unSizedByteArray rawPub)) of Left err -> verificationError (SignatureEncodingInvalidCrypto sigPka err) Right ep ->- case cf2es- ( Ed448.signature- (leftPadTo 57 (i2osp (unMPI r)) <> leftPadTo 57 (i2osp (unMPI s)))- ) of- Left err ->- verificationError (SignatureEncodingInvalidCrypto sigPka err)- Right es ->- let prehash = crazyHash hd bs :: B.ByteString- in if Ed448.verify ep prehash es- then Right pub- else- verificationError (SignatureMismatch sigPka (fingerprint pub))+ case ( intToFixedWidth @57 (unMPI r)+ , intToFixedWidth @57 (unMPI s)+ ) of+ (Just rBS, Just sBS) ->+ case cf2es+ ( Ed448.signature+ (unSizedByteArray rBS <> unSizedByteArray sBS)+ ) of+ Left err ->+ verificationError+ (SignatureEncodingInvalidCrypto sigPka err)+ Right es ->+ let prehash = crazyHash hd bs :: B.ByteString+ in if Ed448.verify ep prehash es+ then Right pub+ else+ verificationError+ (SignatureMismatch sigPka (fingerprint pub))+ _ ->+ verificationError+ (SignatureEncodingInvalidLength sigPka "intToFixedWidth" 57 0) ed448Verify sigPka _ _ _ _ _ = verificationError (SignatureShapeMismatch sigPka)- edPointToRawPublic expectedLen (NativeEPoint (EPoint x)) =+ edPointToRawPublic+ :: forall n+ . KnownNat n+ => EdPoint -> Either EdEncodingError (FixedWidthBytes n)+ edPointToRawPublic (NativeEPoint (EPoint x)) =+ case intToFixedWidth @n x of+ Nothing -> Left (BadLength "native" (byteWidth @n) (B.length (i2osp x)))+ Just fwb -> Right fwb+ edPointToRawPublic (PrefixedNativeEPoint (EPoint x)) = let bs = i2osp x- l = B.length bs- in if l > expectedLen- then Left (BadLength "native" expectedLen l)- else Right (leftPadTo expectedLen bs)- edPointToRawPublic expectedLen (PrefixedNativeEPoint (EPoint x)) = do- prefixed <-- exactLengthPublic (expectedLen + 1) "prefixed-native" (i2osp x)- if B.head prefixed /= 0x40- then Left BadPrefix- else Right (B.tail prefixed)- exactLengthPublic expectedLen label bs- | B.length bs == expectedLen = Right bs- | otherwise = Left (BadLength label expectedLen (B.length bs))- pad32 bs = leftPadTo 32 bs- padN n bs = leftPadTo n bs+ expectedLen = byteWidth @n + 1+ in if B.length bs /= expectedLen+ then Left (BadLength "prefixed-native" expectedLen (B.length bs))+ else+ if B.head bs /= 0x40+ then Left BadPrefix+ else case leftPadTo (byteWidth @n) (B.tail bs) of+ Nothing ->+ Left+ (BadLength "leftPadTo" (byteWidth @n) (B.length (B.tail bs)))+ Just padded -> case sizedByteArray padded of+ Nothing ->+ Left+ (BadLength "sizedByteArray" (byteWidth @n) (B.length padded))+ Just fwb -> Right fwb cf2es = eitherCryptoError rsaVerify pub mpis hd pkey bs = case rsaMPItoSig pkey mpis of@@ -1319,9 +1357,7 @@ rsaMPItoSig pkey (s :| []) = let sz = RSATypes.public_size pkey raw = i2osp (unMPI s)- in if B.length raw > sz- then Nothing- else Just (leftPadTo sz raw)+ in leftPadTo sz raw rsaMPItoSig _ _ = Nothing crazyHash h = BA.convert . hashWith h
Codec/Encryption/OpenPGP/Types/Internal/Base.hs view
@@ -1306,7 +1306,7 @@ pretty (SignatureSalt bs) = prettyBS bs instance A.ToJSON SignatureSalt where- toJSON (SignatureSalt bs) = A.toJSON (B.unpack bs)+ toJSON = A.toJSON . bsToHexUpper . unSignatureSalt data SignaturePayloadVersion = SigPayloadV3@@ -1892,7 +1892,7 @@ pretty = pretty . ("iv:" ++) . bsToHexUpper . op IV instance A.ToJSON IV where- toJSON = A.toJSON . show . op IV+ toJSON = A.toJSON . bsToHexUpper . op IV data LiteralDataType = BinaryData@@ -1981,7 +1981,7 @@ pretty = pretty . ("salt:" ++) . bsToHexUpper . op Salt instance A.ToJSON Salt where- toJSON = A.toJSON . show . op Salt+ toJSON = A.toJSON . bsToHexUpper . op Salt newtype Salt8 = Salt8@@ -2010,7 +2010,7 @@ pretty . ("salt8:" ++) . bsToHexUpper . op Salt8 instance A.ToJSON Salt8 where- toJSON = A.toJSON . show . op Salt8+ toJSON = A.toJSON . bsToHexUpper . op Salt8 newtype Salt16 = Salt16@@ -2042,7 +2042,7 @@ . op Salt16 instance A.ToJSON Salt16 where- toJSON = A.toJSON . show . op Salt16+ toJSON = A.toJSON . bsToHexUpper . op Salt16 -- FIXME: these functions should be in a separate module salt8FromSalt :: Salt -> Maybe Salt8@@ -2224,7 +2224,7 @@ = NISTP256 | NISTP384 | NISTP521- | Curve25519 -- FIXME: rename this to Curve25519 legacy+ | Curve25519 -- FIXME: rename this to Curve25519 legacy | Curve448 deriving (Data, Eq, Generic, Ord, Show, Typeable)
Data/Conduit/OpenPGP/Decrypt.hs view
@@ -72,7 +72,7 @@ import qualified Data.IxSet.Typed as IxSet import Data.List (intercalate, nub) import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (catMaybes, isNothing, mapMaybe)+import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe) import Data.Word (Word64, Word8) import qualified "crypton" Crypto.Cipher.Types as CCT @@ -90,12 +90,15 @@ ) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint) import Codec.Encryption.OpenPGP.Internal- ( checksum16- , checksum16Bytes+ ( bsToFixedWidth+ , checksum16+ , checksum16BE , chunksOf8 , edPointBytes , encodeWord64be+ , intToFixedWidth , leftPadTo+ , unSizedByteArray , xorBS ) import Codec.Encryption.OpenPGP.Internal.CryptoECDH@@ -1913,9 +1916,9 @@ either fail pure (classifyPKESKUnwrapCase pkesk keyInfo) case unwrapCase of PKESKUnwrapV3RSA privateKey mpi ->- rsaUnwrap- privateKey- (leftPadTo (rsaModulusBytes privateKey) (i2osp (unMPI mpi)))+ case leftPadTo (rsaModulusBytes privateKey) (i2osp (unMPI mpi)) of+ Nothing -> fail "leftPadTo: input exceeds target"+ Just padded -> rsaUnwrap privateKey padded PKESKUnwrapV6RSA privateKey esk -> do normalized <- either fail pure (normalizePKESKv6RSAEsk privateKey esk)@@ -2003,7 +2006,9 @@ ++ " > " ++ show modulusLen )- pure (leftPadTo modulusLen mpiPayload)+ case leftPadTo modulusLen mpiPayload of+ Nothing -> Left "leftPadTo: input exceeds target"+ Just padded -> pure padded ecdhUnwrap recipientCtx pka mpis privateKey = do recipientPKP <-@@ -2188,8 +2193,14 @@ pure (pkeskRecipientPKPayload recipientCtx) case pka of- X25519 -> v6X25519Unwrap recipientPKP (leftPadTo 32 privateKeyRaw) esk- X448 -> v6X448Unwrap recipientPKP (leftPadTo 56 privateKeyRaw) esk+ X25519 ->+ case bsToFixedWidth @32 privateKeyRaw of+ Nothing -> fail "X25519 private key material exceeds 32 bytes"+ Just padded -> v6X25519Unwrap recipientPKP (unSizedByteArray padded) esk+ X448 ->+ case bsToFixedWidth @56 privateKeyRaw of+ Nothing -> fail "X448 private key material exceeds 56 bytes"+ Just padded -> v6X448Unwrap recipientPKP (unSizedByteArray padded) esk _ -> fail ( "X25519/X448 PKESKv6 unwrap only supports X25519/X448 packets; got "@@ -2207,7 +2218,7 @@ either fail pure . first show . CE.eitherCryptoError- $ C25519.secretKey (leftPadTo 32 recipientSecretRaw)+ $ C25519.secretKey recipientSecretRaw ephPub <- either fail pure . first show@@ -2245,17 +2256,20 @@ resolveX25519SecretRaw recipientPKP privateKey = do recipientPublicRaw <- extractX25519RecipientPublic recipientPKP- let secretBE = leftPadTo 32 (i2osp (ECDSA.private_d privateKey))- candidates = [secretBE, B.reverse secretBE]- matchesCandidate candidate =- case CE.eitherCryptoError (C25519.secretKey candidate) of- Right sk ->- let derivedPub = BA.convert (C25519.toPublic sk) :: B.ByteString- in derivedPub == recipientPublicRaw- Left _ -> False- case filter matchesCandidate candidates of- (candidate : _) -> Right candidate- [] -> Right secretBE+ case intToFixedWidth @32 (ECDSA.private_d privateKey) of+ Nothing -> Left "X25519 private key scalar exceeds 32 bytes"+ Just secretFWB ->+ let secretBE = unSizedByteArray secretFWB+ candidates = [secretBE, B.reverse secretBE]+ matchesCandidate candidate =+ case CE.eitherCryptoError (C25519.secretKey candidate) of+ Right sk ->+ let derivedPub = BA.convert (C25519.toPublic sk) :: B.ByteString+ in derivedPub == recipientPublicRaw+ Left _ -> False+ in case filter matchesCandidate candidates of+ (candidate : _) -> Right candidate+ [] -> Right secretBE v6X448Unwrap recipientPKP recipientSecretRaw esk = do recipientPublicRaw <-@@ -2268,7 +2282,7 @@ either fail pure . first show . CE.eitherCryptoError- $ C448.secretKey (leftPadTo 56 recipientSecretRaw)+ $ C448.secretKey recipientSecretRaw ephPub <- either fail pure . first show@@ -2298,7 +2312,7 @@ either fail pure . first show . CE.eitherCryptoError- $ C25519.secretKey (leftPadTo 32 recipientSecretRaw)+ $ C25519.secretKey recipientSecretRaw ephPub <- either fail pure . first show@@ -2328,7 +2342,7 @@ Right ( B.singleton (fromIntegral (fromFVal sessionAlgorithm)) <> rawKey- <> checksum16Bytes rawKey+ <> checksum16BE rawKey ) case rfc9580Result of Right result -> pure result@@ -2424,16 +2438,17 @@ let observedLen = B.length (unLegacyECDHWrappedRFC3394Ciphertext wrapped) plausibleWrappedLens = legacyECDHRFC3394WrappedLengths reconstructed =- [ LegacyECDHWrappedRFC3394Ciphertext- ( if observedLen == targetLen- then unLegacyECDHWrappedRFC3394Ciphertext wrapped- else- leftPadTo- targetLen- (unLegacyECDHWrappedRFC3394Ciphertext wrapped)- )+ [ LegacyECDHWrappedRFC3394Ciphertext padded | targetLen <- plausibleWrappedLens , targetLen >= observedLen+ , let raw = unLegacyECDHWrappedRFC3394Ciphertext wrapped+ , let padded =+ if observedLen == targetLen+ then raw+ else+ fromMaybe+ (error "leftPadTo: input exceeds target")+ (leftPadTo targetLen raw) ] in nub (wrapped : reconstructed) @@ -2493,7 +2508,7 @@ ) = B.singleton (fromIntegral (fromFVal sessionAlgorithm)) <> sessionKey- <> checksum16Bytes sessionKey+ <> checksum16BE sessionKey parsePKESKv6ECDHEsk :: PubKeyAlgorithm
hOpenPGP.cabal view
@@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP-Version: 3.7+Version: 3.7.1 Synopsis: native Haskell implementation of OpenPGP (RFC9580) Description: native Haskell implementation of OpenPGP (RFC9580), with some backwards compatibility Homepage: https://salsa.debian.org/clint/hOpenPGP@@ -347,4 +347,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git- tag: v3.7+ tag: v3.7.1
tests/Tests/Common.hs view
@@ -163,7 +163,7 @@ , fingerprint ) import Codec.Encryption.OpenPGP.Internal- ( checksum16Bytes+ ( checksum16BE , emptyPSC , lastPrimaryKey , lastSubkey@@ -485,7 +485,7 @@ expected = B.singleton (fromFVal AES256) <> keyBytes- <> checksum16Bytes keyBytes+ <> checksum16BE keyBytes case encodeOpenPGPSessionMaterial AES256 (SessionKey keyBytes) of Left err -> assertFailure
tests/Tests/Encryption.hs view
@@ -94,6 +94,8 @@ , pkeskSessionAlgorithm , pkeskV3SessionMaterial , recipientCapabilitiesFromSubpacketPayloads+ , recipientCapabilityAdvertisesSEIPDv1Support+ , recipientCapabilityAdvertisesSEIPDv2Support , recipientEncryptionTarget , recipientEncryptionTargetFromTKAtTimestampWithPolicy , recipientEncryptionTargetFromTKWithPolicy@@ -108,7 +110,7 @@ , keyIdFromFingerprint ) import Codec.Encryption.OpenPGP.Internal- ( checksum16Bytes+ ( checksum16BE , point2MBS ) import Codec.Encryption.OpenPGP.Internal.HOBlockCipher@@ -183,6 +185,7 @@ , selectRecipientKeyInfoByRawRecipientId , setKeyTimestamp , setKeyVersion+ , signCertificationAt , signDirectKeyWithRSAExtrasAt , signSubkeyBindingWithRSAExtrasAt , signSubkeyRevocationWithRSAAt@@ -809,6 +812,9 @@ "recipientEncryptionTargetsFromTKAtTimestamp extracts typed AEAD preferences" testRecipientEncryptionTargetsFromTKAtTimestampExtractsTypedAEADPreferences , testCase+ "recipientEncryptionTargetsFromTKAtTimestamp handles SEIPDv2-only Features without SEIPDv1"+ testRecipientEncryptionTargetsFromTKAtTimestampHandlesSEIPDv2OnlyFeatures+ , testCase "recipientEncryptionTargetFromTKAtTimestampWithPolicy filters subkey self-signatures by timestamp" testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering , testCase@@ -4069,6 +4075,80 @@ [] -> assertFailure "Expected at least one TK-derived target" +testRecipientEncryptionTargetsFromTKAtTimestampHandlesSEIPDv2OnlyFeatures+ :: Assertion+testRecipientEncryptionTargetsFromTKAtTimestampHandlesSEIPDv2OnlyFeatures = do+ (primary, signingKey) <- loadUnencryptedRsaSigner+ (subkey, _privateKey) <- loadUnencryptedRsaSigner+ let signatureTime = ThirtyTwoBitTimeStamp 1700000000+ uidText = "test@example.com"+ uid = UserId uidText+ certSig <-+ signCertificationAt+ primary+ signingKey+ uid+ signatureTime+ [ SigSubPacket+ False+ (Features (Set.fromList [FeatureSEIPDv2]))+ , SigSubPacket+ False+ (PreferredAEADCiphersuites [(AES256, OCB)])+ ]+ subkeyBindingSig <-+ signSubkeyBindingWithRSAExtrasAt+ primary+ subkey+ signingKey+ signatureTime+ [ SigSubPacket+ False+ (KeyFlags (Set.fromList [EncryptCommunicationsKey]))+ ]+ let tk =+ TK+ { _tkPrimaryKey = KeyPktPublicPrimary primary+ , _tkRevs = []+ , _tkDirectKeySigs = []+ , _tkUIDs = [(uidText, [certSig])]+ , _tkUAts = []+ , _tkSubs = [(KeyPktPublicSubkey subkey, [subkeyBindingSig])]+ }+ report =+ recipientEncryptionTargetsReportFromTKAtTimestamp+ signatureTime+ tk+ acceptedTargets = recipientEncryptionTargetsAccepted report+ case acceptedTargets of+ (target : _) -> do+ assertBool+ "Key with SEIPDv2-only Features should be accepted as encryption target"+ True+ case recipientEncryptionTargetCapabilities target of+ Nothing ->+ assertFailure+ "Expected TK-derived target to include extracted capabilities"+ Just caps -> do+ assertEqual+ "recipientCapabilityAdvertisesSEIPDv1Support should be False for SEIPDv2-only key"+ False+ (recipientCapabilityAdvertisesSEIPDv1Support caps)+ assertEqual+ "recipientCapabilityAdvertisesSEIPDv2Support should be True for SEIPDv2-only key"+ True+ (recipientCapabilityAdvertisesSEIPDv2Support caps)+ assertEqual+ "self-signature capability extraction should include AEAD ciphersuite preferences"+ [(AES256, OCB)]+ (recipientCapabilityPreferredCiphersuites caps)+ assertEqual+ "self-signature capability extraction should include subkey key flags"+ (Set.fromList [EncryptCommunicationsKey])+ (recipientCapabilityKeyFlags caps)+ [] ->+ assertFailure "Expected at least one accepted TK-derived target"+ testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering :: Assertion testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering = do@@ -5168,7 +5248,7 @@ publicKey ( B.singleton (fromFVal AES256) <> sessionKey- <> checksum16Bytes sessionKey+ <> checksum16BE sessionKey ) :: IO (Either RSA.Error B.ByteString) )@@ -5246,7 +5326,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> checksum16Bytes sessionKey+ <> checksum16BE sessionKey <> B.replicate 5 0 sharedSecret = BA.convert@@ -5356,7 +5436,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> checksum16Bytes sessionKey+ <> checksum16BE sessionKey <> B.replicate 5 0 sharedSecret = BA.convert@@ -6781,7 +6861,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> checksum16Bytes sessionKey+ <> checksum16BE sessionKey <> B.replicate 5 0 sharedSecret = BA.convert@@ -6927,7 +7007,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> checksum16Bytes sessionKey+ <> checksum16BE sessionKey <> B.replicate 5 0 sharedSecret = BA.convert@@ -7076,7 +7156,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKeyBytes- <> checksum16Bytes sessionKeyBytes+ <> checksum16BE sessionKeyBytes <> B.replicate 5 0 wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession in (SessionKey sessionKeyBytes, wrappedSession)@@ -7201,7 +7281,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> checksum16Bytes sessionKey+ <> checksum16BE sessionKey <> B.replicate 5 0 sharedSecret = BA.convert@@ -7294,7 +7374,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> checksum16Bytes sessionKey+ <> checksum16BE sessionKey <> B.replicate 5 0 recipientSecret = case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of@@ -7416,7 +7496,7 @@ encodedSession = B.singleton (fromFVal AES256) <> sessionKey- <> checksum16Bytes sessionKey+ <> checksum16BE sessionKey <> B.replicate 5 0 recipientSecret = case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of@@ -7697,7 +7777,7 @@ let encodedWithChecksum = B.singleton (fromFVal sa) <> sessionKey- <> checksum16Bytes sessionKey+ <> checksum16BE sessionKey encryptedEsk <- case withSymmetricCipher sa kek $ \cipher -> paddedCfbEncrypt
tests/Tests/MessageAndArmor.hs view
@@ -46,8 +46,7 @@ import Codec.Encryption.OpenPGP.BlockCipher (keySize) import Codec.Encryption.OpenPGP.CFB- ( OpenPGPCFBModeW (..)- , decryptPreservingNonce+ ( decryptPreservingNonce ) import Codec.Encryption.OpenPGP.Compression (decompressPkt) import Codec.Encryption.OpenPGP.Encrypt
tests/Tests/Serialization.hs view
@@ -31,7 +31,7 @@ import Data.Conduit.Serialization.Binary (conduitGet) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE-import Data.Maybe (listToMaybe)+import Data.Maybe (fromMaybe, listToMaybe) import qualified Data.Set as Set import Data.Word (Word8) import Test.Tasty (TestTree, testGroup)@@ -374,15 +374,8 @@ (testTKSerialization "secring.gpg") ] , testGroup- "Argon2 S2K group"- [ testCase- "Argon2 SKESK packet roundtrip"- testArgon2S2KPacketRoundTrip- ]- , testGroup "RFC9580 SEIPD v2 group"- [ testCase "SEIPD v2 packet roundtrip" testSEIPDv2PacketRoundTrip- , testCase+ [ testCase "SEIPD v2 rejects invalid chunk size" testSEIPDv2RejectInvalidChunkSize , testCase@@ -511,18 +504,6 @@ ++ show err Right _canonical -> pure () -testArgon2S2KPacketRoundTrip :: Assertion-testArgon2S2KPacketRoundTrip = do- let s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15- pkt =- SKESKPkt- (SKESKPayloadV4Packet (SKESKPayloadV4 AES128 s2k Nothing))- encoded = runPut (put pkt)- assertEqual- "Argon2 S2K SKESK packet roundtrip"- (Right pkt)- (runGetTest (get :: Get Pkt) encoded)- testIssuerFingerprintRejectsUnknownVersion :: Assertion testIssuerFingerprintRejectsUnknownVersion = do let encoded =@@ -672,7 +653,16 @@ assertEqual "point serialization should pad coordinates to the fixed field width (RFC 9580 §13.2)" ( Just- (B.cons 0x04 (leftPadTo 32 (i2osp 1) <> leftPadTo 32 (i2osp 1)))+ ( B.cons+ 0x04+ ( fromMaybe+ (error "leftPadTo: input exceeds target")+ (leftPadTo 32 (i2osp 1))+ <> fromMaybe+ (error "leftPadTo: input exceeds target")+ (leftPadTo 32 (i2osp 1))+ )+ ) ) (point2MBS (ECCT.getCurveByName ECCT.SEC_p256r1) (ECCT.Point 1 1)) @@ -690,18 +680,6 @@ ( B.length <$> point2MBS (ECCT.getCurveByName ECCT.SEC_p521r1) (ECCT.Point 1 1) )--testSEIPDv2PacketRoundTrip :: Assertion-testSEIPDv2PacketRoundTrip = do- let salt = Salt (B.pack [0x00 .. 0x1f])- pkt =- SymEncIntegrityProtectedDataPkt- (SEIPD2 AES256 OCB 16 salt "\x01\x02\x03\x04")- encoded = runPut (put pkt)- assertEqual- "SEIPD v2 packet roundtrip"- (Right pkt)- (runGetTest (get :: Get Pkt) encoded) testSEIPDv2RejectInvalidChunkSize :: Assertion testSEIPDv2RejectInvalidChunkSize = do