diff --git a/Codec/Encryption/OpenPGP/Encrypt.hs b/Codec/Encryption/OpenPGP/Encrypt.hs --- a/Codec/Encryption/OpenPGP/Encrypt.hs +++ b/Codec/Encryption/OpenPGP/Encrypt.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Internal.hs b/Codec/Encryption/OpenPGP/Internal.hs --- a/Codec/Encryption/OpenPGP/Internal.hs +++ b/Codec/Encryption/OpenPGP/Internal.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs b/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs --- a/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs +++ b/Codec/Encryption/OpenPGP/Internal/CryptoECDH.hs @@ -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)) diff --git a/Codec/Encryption/OpenPGP/Policy.hs b/Codec/Encryption/OpenPGP/Policy.hs --- a/Codec/Encryption/OpenPGP/Policy.hs +++ b/Codec/Encryption/OpenPGP/Policy.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Serialize.hs b/Codec/Encryption/OpenPGP/Serialize.hs --- a/Codec/Encryption/OpenPGP/Serialize.hs +++ b/Codec/Encryption/OpenPGP/Serialize.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Signatures.hs b/Codec/Encryption/OpenPGP/Signatures.hs --- a/Codec/Encryption/OpenPGP/Signatures.hs +++ b/Codec/Encryption/OpenPGP/Signatures.hs @@ -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 diff --git a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs --- a/Codec/Encryption/OpenPGP/Types/Internal/Base.hs +++ b/Codec/Encryption/OpenPGP/Types/Internal/Base.hs @@ -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) diff --git a/Data/Conduit/OpenPGP/Decrypt.hs b/Data/Conduit/OpenPGP/Decrypt.hs --- a/Data/Conduit/OpenPGP/Decrypt.hs +++ b/Data/Conduit/OpenPGP/Decrypt.hs @@ -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 diff --git a/hOpenPGP.cabal b/hOpenPGP.cabal --- a/hOpenPGP.cabal +++ b/hOpenPGP.cabal @@ -1,6 +1,6 @@ Cabal-version: 3.4 Name: hOpenPGP -Version: 3.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 diff --git a/tests/Tests/Common.hs b/tests/Tests/Common.hs --- a/tests/Tests/Common.hs +++ b/tests/Tests/Common.hs @@ -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 diff --git a/tests/Tests/Encryption.hs b/tests/Tests/Encryption.hs --- a/tests/Tests/Encryption.hs +++ b/tests/Tests/Encryption.hs @@ -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 diff --git a/tests/Tests/MessageAndArmor.hs b/tests/Tests/MessageAndArmor.hs --- a/tests/Tests/MessageAndArmor.hs +++ b/tests/Tests/MessageAndArmor.hs @@ -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 diff --git a/tests/Tests/Serialization.hs b/tests/Tests/Serialization.hs --- a/tests/Tests/Serialization.hs +++ b/tests/Tests/Serialization.hs @@ -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